1 package ExtUtils::ParseXS;
3 use 5.006; # We use /??{}/ in regexes
13 @EXPORT_OK = qw(process_file);
15 # use strict; # One of these days...
17 my(@XSStack); # Stack of conditionals and INCLUDEs
18 my($XSS_work_idx, $cpp_next_tmp);
20 use vars qw($VERSION);
23 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
24 $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
25 $WantOptimize $process_inout $process_argtypes @tm
26 $dir $filename $filepathname %IncludedFiles
27 %type_kind %proto_letter
28 %targetable $BLOCK_re $lastline $lastline_no
29 $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
30 $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
31 $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
32 $ProtoThisXSUB $ScopeThisXSUB $xsreturn
33 @line_no $ret_type $func_header $orig_args
34 ); # Add these just to get compilation to happen.
39 # Allow for $package->process_file(%hash) in the future
40 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
42 $ProtoUsed = exists $args{prototypes};
46 # 'C++' => 0, # Doesn't seem to *do* anything...
64 my ($Is_VMS, $SymSet);
67 # Establish set of global symbols with max length 28, since xsubpp
68 # will later add the 'XS_' prefix.
69 require ExtUtils::XSSymSet;
70 $SymSet = new ExtUtils::XSSymSet 28;
72 @XSStack = ({type => 'none'});
73 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
75 $FH = Symbol::gensym();
76 $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
79 $Fallback = '&PL_sv_undef';
81 # Most of the 1500 lines below uses these globals. We'll have to
82 # clean this up sometime, probably. For now, we just pull them out
85 $cplusplus = $args{'C++'};
86 $hiertype = $args{hiertype};
87 $WantPrototypes = $args{prototypes};
88 $WantVersionChk = $args{versioncheck};
89 $except = $args{except} ? ' TRY' : '';
90 $WantLineNumbers = $args{linenumbers};
91 $WantOptimize = $args{optimize};
92 $process_inout = $args{inout};
93 $process_argtypes = $args{argtypes};
94 @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
96 for ($args{filename}) {
97 die "Missing required parameter 'filename'" unless $_;
99 ($dir, $filename) = (dirname($_), basename($_));
100 $filepathname =~ s/\\/\\\\/g;
101 $IncludedFiles{$_}++;
104 # Open the input file
105 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
107 # Open the output file if given as a string. If they provide some
108 # other kind of reference, trust them that we can print to it.
109 if (not ref $args{output}) {
110 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
111 $args{outfile} = $args{output};
115 # Really, we shouldn't have to chdir() or select() in the first
116 # place. For now, just save & restore.
117 my $orig_cwd = cwd();
118 my $orig_fh = select();
122 my $csuffix = $args{csuffix};
124 if ($WantLineNumbers) {
126 if ( $args{outfile} ) {
127 $cfile = $args{outfile};
129 $cfile = $args{filename};
130 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
132 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
133 select PSEUDO_STDOUT;
135 select $args{output};
138 foreach my $typemap (@tm) {
139 die "Can't find $typemap in $pwd\n" unless -r $typemap;
142 push @tm, standard_typemap_locations();
144 foreach my $typemap (@tm) {
145 next unless -f $typemap ;
146 # skip directories, binary files etc.
147 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
149 open(TYPEMAP, $typemap)
150 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
151 my $mode = 'Typemap';
153 my $current = \$junk;
156 my $line_no = $. + 1;
158 $mode = 'Input'; $current = \$junk; next;
161 $mode = 'Output'; $current = \$junk; next;
163 if (/^TYPEMAP\s*$/) {
164 $mode = 'Typemap'; $current = \$junk; next;
166 if ($mode eq 'Typemap') {
170 # skip blank lines and comment lines
171 next if /^$/ or /^#/ ;
172 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
173 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
174 $type = TidyType($type) ;
175 $type_kind{$type} = $kind ;
176 # prototype defaults to '$'
177 $proto = "\$" unless $proto ;
178 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
179 unless ValidProtoString($proto) ;
180 $proto_letter{$type} = C_string($proto) ;
183 } elsif ($mode eq 'Input') {
185 $input_expr{$_} = '';
186 $current = \$input_expr{$_};
189 $output_expr{$_} = '';
190 $current = \$output_expr{$_};
196 foreach my $value (values %input_expr) {
197 $value =~ s/;*\s+\z//;
198 # Move C pre-processor instructions to column 1 to be strictly ANSI
199 # conformant. Some pre-processors are fussy about this.
200 $value =~ s/^\s+#/#/mg;
202 foreach my $value (values %output_expr) {
204 $value =~ s/^\s+#/#/mg;
208 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
209 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
210 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
212 foreach my $key (keys %output_expr) {
213 BEGIN { $^H |= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs
215 my ($t, $with_size, $arg, $sarg) =
216 ($output_expr{$key} =~
217 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
218 \s* \( \s* $cast \$arg \s* ,
219 \s* ( (??{ $bal }) ) # Set from
220 ( (??{ $size }) )? # Possible sizeof set-from
223 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
226 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
228 # Match an XS keyword
229 $BLOCK_re= '\s*(' . join('|', qw(
230 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
231 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
232 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
236 our ($C_group_rex, $C_arg);
237 # Group in C (no support for comments or literals)
238 $C_group_rex = qr/ [({\[]
239 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
241 # Chunk in C without comma at toplevel (no comments):
242 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
243 | (??{ $C_group_rex })
244 | " (?: (?> [^\\"]+ )
246 )* " # String literal
247 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
250 # Identify the version of xsubpp used
253 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
254 * contents of $filename. Do not edit this file, edit $filename instead.
256 * ANY CHANGES MADE HERE WILL BE LOST!
263 print("#line 1 \"$filepathname\"\n")
269 my $podstartline = $.;
272 # We can't just write out a /* */ comment, as our embedded
273 # POD might itself be in a comment. We can't put a /**/
274 # comment inside #if 0, as the C standard says that the source
275 # file is decomposed into preprocessing characters in the stage
276 # before preprocessing commands are executed.
277 # I don't want to leave the text as barewords, because the spec
278 # isn't clear whether macros are expanded before or after
279 # preprocessing commands are executed, and someone pathological
280 # may just have defined one of the 3 words as a macro that does
281 # something strange. Multiline strings are illegal in C, so
282 # the "" we write must be a string literal. And they aren't
283 # concatenated until 2 steps later, so we are safe.
285 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
286 printf("#line %d \"$filepathname\"\n", $. + 1)
292 # At this point $. is at end of file so die won't state the start
293 # of the problem, and as we haven't yet read any lines &death won't
294 # show the correct line in the message either.
295 die ("Error: Unterminated pod in $filename, line $podstartline\n")
298 last if ($Package, $Prefix) =
299 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
303 unless (defined $_) {
304 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
305 exit 0; # Not a fatal error for the caller process
308 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
311 #ifndef PERL_UNUSED_VAR
312 # define PERL_UNUSED_VAR(var) if (0) var = var
318 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
319 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
321 /* prototype to pass -Wmissing-prototypes */
323 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
326 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
328 const GV *const gv = CvGV(cv);
330 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
333 const char *const gvname = GvNAME(gv);
334 const HV *const stash = GvSTASH(gv);
335 const char *const hvname = stash ? HvNAME(stash) : NULL;
338 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
340 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
342 /* Pants. I don't think that it should be possible to get here. */
343 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
346 #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
348 #ifdef PERL_IMPLICIT_CONTEXT
349 #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
351 #define croak_xs_usage S_croak_xs_usage
358 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
364 while (fetch_para()) {
365 # Print initial preprocessor statements and blank lines
366 while (@line && $line[0] !~ /^[^\#]/) {
367 my $line = shift(@line);
369 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
371 if ($statement eq 'if') {
372 $XSS_work_idx = @XSStack;
373 push(@XSStack, {type => 'if'});
375 death ("Error: `$statement' with no matching `if'")
376 if $XSStack[-1]{type} ne 'if';
377 if ($XSStack[-1]{varname}) {
378 push(@InitFileCode, "#endif\n");
379 push(@BootCode, "#endif");
382 my(@fns) = keys %{$XSStack[-1]{functions}};
383 if ($statement ne 'endif') {
384 # Hide the functions defined in other #if branches, and reset.
385 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
386 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
388 my($tmp) = pop(@XSStack);
389 0 while (--$XSS_work_idx
390 && $XSStack[$XSS_work_idx]{type} ne 'if');
391 # Keep all new defined functions
392 push(@fns, keys %{$tmp->{other_functions}});
393 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
398 next PARAGRAPH unless @line;
400 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
401 # We are inside an #if, but have not yet #defined its xsubpp variable.
402 print "#define $cpp_next_tmp 1\n\n";
403 push(@InitFileCode, "#if $cpp_next_tmp\n");
404 push(@BootCode, "#if $cpp_next_tmp");
405 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
408 death ("Code is not inside a function"
409 ." (maybe last function was ended by a blank line "
410 ." followed by a statement on column one?)")
411 if $line[0] =~ /^\s/;
413 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
414 my (@fake_INPUT_pre); # For length(s) generated variables
417 # initialize info arrays
423 undef($processing_arg_with_types) ;
424 undef(%argtype_seen) ;
428 undef($proto_in_this_xsub) ;
429 undef($scope_in_this_xsub) ;
431 undef($prepush_done);
432 $interface_macro = 'XSINTERFACE_FUNC' ;
433 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
434 $ProtoThisXSUB = $WantPrototypes ;
439 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
440 &{"${kwd}_handler"}() ;
441 next PARAGRAPH unless @line ;
445 if (check_keyword("BOOT")) {
447 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
448 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
449 push (@BootCode, @line, "") ;
454 # extract return type, function name and arguments
455 ($ret_type) = TidyType($_);
456 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
458 # Allow one-line ANSI-like declaration
461 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
463 # a function definition needs at least 2 lines
464 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
467 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
468 $static = 1 if $ret_type =~ s/^static\s+//;
470 $func_header = shift(@line);
471 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
472 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
474 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
475 $class = "$4 $class" if $4;
476 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
477 ($clean_func_name = $func_name) =~ s/^$Prefix//;
478 $Full_func_name = "${Packid}_$clean_func_name";
480 $Full_func_name = $SymSet->addsym($Full_func_name);
483 # Check for duplicate function definition
484 for my $tmp (@XSStack) {
485 next unless defined $tmp->{functions}{$Full_func_name};
486 Warn("Warning: duplicate function definition '$clean_func_name' detected");
489 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
490 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
493 $orig_args =~ s/\\\s*/ /g; # process line continuations
496 my %only_C_inlist; # Not in the signature of Perl function
497 if ($process_argtypes and $orig_args =~ /\S/) {
498 my $args = "$orig_args ,";
499 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
500 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
504 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
505 my ($pre, $name) = ($arg =~ /(.*?) \s*
506 \b ( \w+ | length\( \s*\w+\s* \) )
508 next unless defined($pre) && length($pre);
511 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
513 $out_type = $type if $type ne 'IN';
514 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
515 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
518 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
519 $name = "XSauto_length_of_$1";
521 die "Default value on length() argument: `$_'"
524 if (length $pre or $islength) { # Has a type
526 push @fake_INPUT_pre, $arg;
528 push @fake_INPUT, $arg;
530 # warn "pushing '$arg'\n";
531 $argtype_seen{$name}++;
532 $_ = "$name$default"; # Assigns to @args
534 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
535 push @outlist, $name if $out_type =~ /OUTLIST$/;
536 $in_out{$name} = $out_type if $out_type;
539 @args = split(/\s*,\s*/, $orig_args);
540 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
543 @args = split(/\s*,\s*/, $orig_args);
545 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
547 next if $out_type eq 'IN';
548 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
549 push @outlist, $name if $out_type =~ /OUTLIST$/;
550 $in_out{$_} = $out_type;
554 if (defined($class)) {
555 my $arg0 = ((defined($static) or $func_name eq 'new')
557 unshift(@args, $arg0);
558 ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
563 my $report_args = '';
564 foreach my $i (0 .. $#args) {
565 if ($args[$i] =~ s/\.\.\.//) {
567 if ($args[$i] eq '' && $i == $#args) {
568 $report_args .= ", ...";
573 if ($only_C_inlist{$args[$i]}) {
574 push @args_num, undef;
576 push @args_num, ++$num_args;
577 $report_args .= ", $args[$i]";
579 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
582 $defaults{$args[$i]} = $2;
583 $defaults{$args[$i]} =~ s/"/\\"/g;
585 $proto_arg[$i+1] = '$' ;
587 $min_args = $num_args - $extra_args;
588 $report_args =~ s/"/\\"/g;
589 $report_args =~ s/^,\s+//;
590 my @func_args = @args;
591 shift @func_args if defined($class);
594 s/^/&/ if $in_out{$_};
596 $func_args = join(", ", @func_args);
597 @args_match{@args} = @args_num;
599 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
600 $CODE = grep(/^\s*CODE\s*:/, @line);
601 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
602 # to set explicit return values.
603 $EXPLICIT_RETURN = ($CODE &&
604 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
605 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
606 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
608 $xsreturn = 1 if $EXPLICIT_RETURN;
610 $externC = $externC ? qq[extern "C"] : "";
612 # print function header
615 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
616 #XS(XS_${Full_func_name})
624 print Q(<<"EOF") if $ALIAS ;
627 print Q(<<"EOF") if $INTERFACE ;
628 # dXSFUNCTION($ret_type);
631 $cond = ($min_args ? qq(items < $min_args) : 0);
632 } elsif ($min_args == $num_args) {
633 $cond = qq(items != $min_args);
635 $cond = qq(items < $min_args || items > $num_args);
638 print Q(<<"EOF") if $except;
646 # croak_xs_usage(cv, "$report_args");
649 # cv likely to be unused
651 # PERL_UNUSED_VAR(cv); /* -W */
655 #gcc -Wall: if an xsub has PPCODE is used
656 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
657 #hence `ax' (setup by dXSARGS) is unused
658 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
659 #but such a move could break third-party extensions
660 print Q(<<"EOF") if $PPCODE;
661 # PERL_UNUSED_VAR(ax); /* -Wall */
664 print Q(<<"EOF") if $PPCODE;
668 # Now do a block of some sort.
671 $cond = ''; # last CASE: condidional
672 push(@line, "$END:");
673 push(@line_no, $line_no[-1]);
677 &CASE_handler if check_keyword("CASE");
682 # do initialization of input variables
690 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
692 print Q(<<"EOF") if $ScopeThisXSUB;
697 if (!$thisdone && defined($class)) {
698 if (defined($static) or $func_name eq 'new') {
700 $var_types{"CLASS"} = "char *";
701 &generate_init("char *", 1, "CLASS");
705 $var_types{"THIS"} = "$class *";
706 &generate_init("$class *", 1, "THIS");
711 if (/^\s*NOT_IMPLEMENTED_YET/) {
712 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
715 if ($ret_type ne "void") {
716 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
718 $args_match{"RETVAL"} = 0;
719 $var_types{"RETVAL"} = $ret_type;
721 if $WantOptimize and $targetable{$type_kind{$ret_type}};
724 if (@fake_INPUT or @fake_INPUT_pre) {
725 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
727 $processing_arg_with_types = 1;
732 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
734 if (check_keyword("PPCODE")) {
736 death ("PPCODE must be last thing") if @line;
737 print "\tLEAVE;\n" if $ScopeThisXSUB;
738 print "\tPUTBACK;\n\treturn;\n";
739 } elsif (check_keyword("CODE")) {
741 } elsif (defined($class) and $func_name eq "DESTROY") {
743 print "delete THIS;\n";
746 if ($ret_type ne "void") {
750 if (defined($static)) {
751 if ($func_name eq 'new') {
752 $func_name = "$class";
756 } elsif (defined($class)) {
757 if ($func_name eq 'new') {
758 $func_name .= " $class";
763 $func_name =~ s/^\Q$args{'s'}//
764 if exists $args{'s'};
765 $func_name = 'XSFUNCTION' if $interface;
766 print "$func_name($func_args);\n";
770 # do output variables
771 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
772 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
773 # $wantRETVAL set if 'RETVAL =' autogenerated
774 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
776 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
778 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
779 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
781 # all OUTPUT done, so now push the return value on the stack
782 if ($gotRETVAL && $RETVAL_code) {
783 print "\t$RETVAL_code\n";
784 } elsif ($gotRETVAL || $wantRETVAL) {
785 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
787 my $type = $ret_type;
789 # 0: type, 1: with_size, 2: how, 3: how_size
790 if ($t and not $t->[1] and $t->[0] eq 'p') {
791 # PUSHp corresponds to setpvn. Treate setpv directly
792 my $what = eval qq("$t->[2]");
795 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
799 my $what = eval qq("$t->[2]");
803 $size = '' unless defined $size;
804 $size = eval qq("$size");
806 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
810 # RETVAL almost never needs SvSETMAGIC()
811 &generate_output($ret_type, 0, 'RETVAL', 0);
815 $xsreturn = 1 if $ret_type ne "void";
818 print "\tXSprePUSH;" if $c and not $prepush_done;
819 print "\tEXTEND(SP,$c);\n" if $c;
821 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
824 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
826 print Q(<<"EOF") if $ScopeThisXSUB;
829 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
833 # print function trailer
837 print Q(<<"EOF") if $except;
840 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
843 if (check_keyword("CASE")) {
844 blurt ("Error: No `CASE:' at top of function")
846 $_ = "CASE: $_"; # Restore CASE: label
849 last if $_ eq "$END:";
850 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
853 print Q(<<"EOF") if $except;
855 # Perl_croak(aTHX_ errbuf);
859 print Q(<<"EOF") unless $PPCODE;
860 # XSRETURN($xsreturn);
863 print Q(<<"EOF") unless $PPCODE;
873 my $newXS = "newXS" ;
876 # Build the prototype string for the xsub
877 if ($ProtoThisXSUB) {
878 $newXS = "newXSproto";
880 if ($ProtoThisXSUB eq 2) {
881 # User has specified empty prototype
883 elsif ($ProtoThisXSUB eq 1) {
885 if ($min_args < $num_args) {
887 $proto_arg[$min_args] .= ";" ;
889 push @proto_arg, "$s\@"
892 $proto = join ("", grep defined, @proto_arg);
895 # User has specified a prototype
896 $proto = $ProtoThisXSUB;
898 $proto = qq{, "$proto"};
902 $XsubAliases{$pname} = 0
903 unless defined $XsubAliases{$pname} ;
904 while ( ($name, $value) = each %XsubAliases) {
905 push(@InitFileCode, Q(<<"EOF"));
906 # cv = newXS(\"$name\", XS_$Full_func_name, file);
907 # XSANY.any_i32 = $value ;
909 push(@InitFileCode, Q(<<"EOF")) if $proto;
910 # sv_setpv((SV*)cv$proto) ;
914 elsif (@Attributes) {
915 push(@InitFileCode, Q(<<"EOF"));
916 # cv = newXS(\"$pname\", XS_$Full_func_name, file);
917 # apply_attrs_string("$Package", cv, "@Attributes", 0);
921 while ( ($name, $value) = each %Interfaces) {
922 $name = "$Package\::$name" unless $name =~ /::/;
923 push(@InitFileCode, Q(<<"EOF"));
924 # cv = newXS(\"$name\", XS_$Full_func_name, file);
925 # $interface_macro_set(cv,$value) ;
927 push(@InitFileCode, Q(<<"EOF")) if $proto;
928 # sv_setpv((SV*)cv$proto) ;
934 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
938 if ($Overload) # make it findable with fetchmethod
941 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
942 #XS(XS_${Packid}_nil)
949 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
950 /* Making a sub named "${Package}::()" allows the package */
951 /* to be findable via fetchmethod(), and causes */
952 /* overload::Overloaded("${Package}") to return true. */
953 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
954 MAKE_FETCHMETHOD_WORK
957 # print initialization routine
966 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
967 #XS(boot_$Module_cname)
979 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
981 print Q(<<"EOF") if $Full_func_name;
982 # const char* file = __FILE__;
988 # PERL_UNUSED_VAR(cv); /* -W */
989 # PERL_UNUSED_VAR(items); /* -W */
992 print Q(<<"EOF") if $WantVersionChk ;
993 # XS_VERSION_BOOTCHECK ;
997 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1003 print Q(<<"EOF") if ($Overload);
1004 # /* register the overloading (type 'A') magic */
1005 # PL_amagic_generation++;
1006 # /* The magic for overload gets a GV* via gv_fetchmeth as */
1007 # /* mentioned above, and looks in the SV* slot of it for */
1008 # /* the "fallback" status. */
1010 # get_sv( "${Package}::()", TRUE ),
1015 print @InitFileCode;
1017 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1023 print "\n /* Initialisation Section */\n\n" ;
1026 print "\n /* End of Initialisation Section */\n\n" ;
1032 call_list(PL_scopestack_ix, PL_unitcheckav);
1042 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1047 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1053 sub errors { $errors }
1055 sub standard_typemap_locations {
1056 # Add all the default typemap locations to the search path
1057 my @tm = qw(typemap);
1059 my $updir = File::Spec->updir;
1060 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1061 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1063 unshift @tm, File::Spec->catfile($dir, 'typemap');
1064 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1066 foreach my $dir (@INC) {
1067 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1068 unshift @tm, $file if -e $file;
1075 $_[0] =~ s/^\s+|\s+$//go ;
1082 # rationalise any '*' by joining them into bunches and removing whitespace
1086 # change multiple whitespace into a single space
1089 # trim leading & trailing whitespace
1090 TrimWhitespace($_) ;
1095 # Input: ($_, @line) == unparsed input.
1096 # Output: ($_, @line) == (rest of line, following lines).
1097 # Return: the matched keyword if found, otherwise 0
1099 $_ = shift(@line) while !/\S/ && @line;
1100 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1104 # the "do" is required for right semantics
1105 do { $_ = shift(@line) } while !/\S/ && @line;
1107 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1108 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1109 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1112 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1118 while (!/\S/ && @line) {
1122 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1129 sub process_keyword($)
1134 &{"${kwd}_handler"}()
1135 while $kwd = check_keyword($pattern) ;
1139 blurt ("Error: `CASE:' after unconditional `CASE:'")
1140 if $condnum && $cond eq '';
1142 TrimWhitespace($cond);
1143 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1148 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1149 last if /^\s*NOT_IMPLEMENTED_YET/;
1150 next unless /\S/; # skip blank lines
1152 TrimWhitespace($_) ;
1155 # remove trailing semicolon if no initialisation
1156 s/\s*;$//g unless /[=;+].*\S/ ;
1158 # Process the length(foo) declarations
1159 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1160 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1161 $lengthof{$2} = $name;
1162 # $islengthof{$name} = $1;
1163 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1166 # check for optional initialisation code
1168 $var_init = $1 if s/\s*([=;+].*)$//s ;
1169 $var_init =~ s/"/\\"/g;
1172 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1173 or blurt("Error: invalid argument declaration '$line'"), next;
1175 # Check for duplicate definitions
1176 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1177 if $arg_list{$var_name}++
1178 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1180 $thisdone |= $var_name eq "THIS";
1181 $retvaldone |= $var_name eq "RETVAL";
1182 $var_types{$var_name} = $var_type;
1183 # XXXX This check is a safeguard against the unfinished conversion of
1184 # generate_init(). When generate_init() is fixed,
1185 # one can use 2-args map_type() unconditionally.
1186 if ($var_type =~ / \( \s* \* \s* \) /x) {
1187 # Function pointers are not yet supported with &output_init!
1188 print "\t" . &map_type($var_type, $var_name);
1191 print "\t" . &map_type($var_type);
1194 $var_num = $args_match{$var_name};
1196 $proto_arg[$var_num] = ProtoString($var_type)
1198 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1199 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1200 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1201 and $var_init !~ /\S/) {
1202 if ($name_printed) {
1205 print "\t$var_name;\n";
1207 } elsif ($var_init =~ /\S/) {
1208 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1209 } elsif ($var_num) {
1210 # generate initialization code
1211 &generate_init($var_type, $var_num, $var_name, $name_printed);
1218 sub OUTPUT_handler {
1219 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1221 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1222 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1225 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1226 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1227 if $outargs{$outarg} ++ ;
1228 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1229 # deal with RETVAL last
1230 $RETVAL_code = $outcode ;
1234 blurt ("Error: OUTPUT $outarg not an argument"), next
1235 unless defined($args_match{$outarg});
1236 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1237 unless defined $var_types{$outarg} ;
1238 $var_num = $args_match{$outarg};
1240 print "\t$outcode\n";
1241 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1243 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1245 delete $in_out{$outarg} # No need to auto-OUTPUT
1246 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1250 sub C_ARGS_handler() {
1251 my $in = merge_section();
1253 TrimWhitespace($in);
1257 sub INTERFACE_MACRO_handler() {
1258 my $in = merge_section();
1260 TrimWhitespace($in);
1261 if ($in =~ /\s/) { # two
1262 ($interface_macro, $interface_macro_set) = split ' ', $in;
1264 $interface_macro = $in;
1265 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1267 $interface = 1; # local
1268 $Interfaces = 1; # global
1271 sub INTERFACE_handler() {
1272 my $in = merge_section();
1274 TrimWhitespace($in);
1276 foreach (split /[\s,]+/, $in) {
1278 $name =~ s/^$Prefix//;
1279 $Interfaces{$name} = $_;
1282 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1284 $interface = 1; # local
1285 $Interfaces = 1; # global
1288 sub CLEANUP_handler() { print_section() }
1289 sub PREINIT_handler() { print_section() }
1290 sub POSTCALL_handler() { print_section() }
1291 sub INIT_handler() { print_section() }
1296 my ($orig) = $line ;
1300 # Parse alias definitions
1302 # alias = value alias = value ...
1304 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1306 $orig_alias = $alias ;
1309 # check for optional package definition in the alias
1310 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1312 # check for duplicate alias name & duplicate value
1313 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1314 if defined $XsubAliases{$alias} ;
1316 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1317 if $XsubAliasValues{$value} ;
1320 $XsubAliases{$alias} = $value ;
1321 $XsubAliasValues{$value} = $orig_alias ;
1324 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1328 sub ATTRS_handler ()
1330 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1332 TrimWhitespace($_) ;
1333 push @Attributes, $_;
1337 sub ALIAS_handler ()
1339 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1341 TrimWhitespace($_) ;
1342 GetAliases($_) if $_ ;
1346 sub OVERLOAD_handler()
1348 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1350 TrimWhitespace($_) ;
1351 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1352 $Overload = 1 unless $Overload;
1353 my $overload = "$Package\::(".$1 ;
1355 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1360 sub FALLBACK_handler()
1362 # the rest of the current line should contain either TRUE,
1365 TrimWhitespace($_) ;
1367 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1368 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1369 UNDEF => "&PL_sv_undef",
1372 # check for valid FALLBACK value
1373 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1375 $Fallback = $map{uc $_} ;
1379 sub REQUIRE_handler ()
1381 # the rest of the current line should contain a version number
1384 TrimWhitespace($Ver) ;
1386 death ("Error: REQUIRE expects a version number")
1389 # check that the version number is of the form n.n
1390 death ("Error: REQUIRE: expected a number, got '$Ver'")
1391 unless $Ver =~ /^\d+(\.\d*)?/ ;
1393 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1394 unless $VERSION >= $Ver ;
1397 sub VERSIONCHECK_handler ()
1399 # the rest of the current line should contain either ENABLE or
1402 TrimWhitespace($_) ;
1404 # check for ENABLE/DISABLE
1405 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1406 unless /^(ENABLE|DISABLE)/i ;
1408 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1409 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1413 sub PROTOTYPE_handler ()
1417 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1418 if $proto_in_this_xsub ++ ;
1420 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1423 TrimWhitespace($_) ;
1424 if ($_ eq 'DISABLE') {
1426 } elsif ($_ eq 'ENABLE') {
1429 # remove any whitespace
1431 death("Error: Invalid prototype '$_'")
1432 unless ValidProtoString($_) ;
1433 $ProtoThisXSUB = C_string($_) ;
1437 # If no prototype specified, then assume empty prototype ""
1438 $ProtoThisXSUB = 2 unless $specified ;
1444 sub SCOPE_handler ()
1446 death("Error: Only 1 SCOPE declaration allowed per xsub")
1447 if $scope_in_this_xsub ++ ;
1449 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1451 TrimWhitespace($_) ;
1452 if ($_ =~ /^DISABLE/i) {
1454 } elsif ($_ =~ /^ENABLE/i) {
1461 sub PROTOTYPES_handler ()
1463 # the rest of the current line should contain either ENABLE or
1466 TrimWhitespace($_) ;
1468 # check for ENABLE/DISABLE
1469 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1470 unless /^(ENABLE|DISABLE)/i ;
1472 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1473 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1478 sub INCLUDE_handler ()
1480 # the rest of the current line should contain a valid filename
1482 TrimWhitespace($_) ;
1484 death("INCLUDE: filename missing")
1487 death("INCLUDE: output pipe is illegal")
1490 # simple minded recursion detector
1491 death("INCLUDE loop detected")
1492 if $IncludedFiles{$_} ;
1494 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1496 # Save the current file context.
1499 LastLine => $lastline,
1500 LastLineNo => $lastline_no,
1502 LineNo => \@line_no,
1503 Filename => $filename,
1504 Filepathname => $filepathname,
1508 $FH = Symbol::gensym();
1511 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1515 #/* INCLUDE: Including '$_' from '$filename' */
1519 $filepathname = $filename = $_ ;
1521 # Prime the pump by reading the first
1524 # skip leading blank lines
1526 last unless /^\s*$/ ;
1536 return 0 unless $XSStack[-1]{type} eq 'file' ;
1538 my $data = pop @XSStack ;
1539 my $ThisFile = $filename ;
1540 my $isPipe = ($filename =~ /\|\s*$/) ;
1542 -- $IncludedFiles{$filename}
1547 $FH = $data->{Handle} ;
1548 # $filename is the leafname, which for some reason isused for diagnostic
1549 # messages, whereas $filepathname is the full pathname, and is used for
1551 $filename = $data->{Filename} ;
1552 $filepathname = $data->{Filepathname} ;
1553 $lastline = $data->{LastLine} ;
1554 $lastline_no = $data->{LastLineNo} ;
1555 @line = @{ $data->{Line} } ;
1556 @line_no = @{ $data->{LineNo} } ;
1558 if ($isPipe and $? ) {
1560 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1566 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1573 sub ValidProtoString ($)
1577 if ( $string =~ /^$proto_re+$/ ) {
1588 $string =~ s[\\][\\\\]g ;
1596 $proto_letter{$type} or "\$" ;
1600 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1602 my ($cpp, $cpplevel);
1604 if ($cpp =~ /^\#\s*if/) {
1606 } elsif (!$cpplevel) {
1607 Warn("Warning: #else/elif/endif without #if in this function");
1608 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1609 if $XSStack[-1]{type} eq 'if';
1611 } elsif ($cpp =~ /^\#\s*endif/) {
1615 Warn("Warning: #if without #endif in this function") if $cpplevel;
1623 $text =~ s/\[\[/{/g;
1624 $text =~ s/\]\]/}/g;
1628 # Read next xsub into @line from ($lastline, <$FH>).
1631 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1632 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1635 return PopFile() if !defined $lastline;
1638 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1640 $Package = defined($2) ? $2 : ''; # keep -w happy
1641 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1642 $Prefix = quotemeta $Prefix ;
1643 ($Module_cname = $Module) =~ s/\W/_/g;
1644 ($Packid = $Package) =~ tr/:/_/;
1645 $Packprefix = $Package;
1646 $Packprefix .= "::" if $Packprefix ne "";
1651 # Skip embedded PODs
1652 while ($lastline =~ /^=/) {
1653 while ($lastline = <$FH>) {
1654 last if ($lastline =~ /^=cut\s*$/);
1656 death ("Error: Unterminated pod") unless $lastline;
1659 $lastline =~ s/^\s+$//;
1661 if ($lastline !~ /^\s*#/ ||
1663 # ANSI: if ifdef ifndef elif else endif define undef
1665 # gcc: warning include_next
1667 # others: ident (gcc notes that some cpps have this one)
1668 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1669 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1670 push(@line, $lastline);
1671 push(@line_no, $lastline_no) ;
1674 # Read next line and continuation lines
1675 last unless defined($lastline = <$FH>);
1678 $lastline .= $tmp_line
1679 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1682 $lastline =~ s/^\s+$//;
1684 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1689 local($type, $num, $var, $init, $name_printed) = @_;
1690 local($arg) = "ST(" . ($num - 1) . ")";
1692 if ( $init =~ /^=/ ) {
1693 if ($name_printed) {
1694 eval qq/print " $init\\n"/;
1696 eval qq/print "\\t$var $init\\n"/;
1700 if ( $init =~ s/^\+// && $num ) {
1701 &generate_init($type, $num, $var, $name_printed);
1702 } elsif ($name_printed) {
1706 eval qq/print "\\t$var;\\n"/;
1710 $deferred .= eval qq/"\\n\\t$init\\n"/;
1717 # work out the line number
1718 my $line_no = $line_no[@line_no - @line -1] ;
1720 print STDERR "@_ in $filename, line $line_no\n" ;
1736 local($type, $num, $var) = @_;
1737 local($arg) = "ST(" . ($num - 1) . ")";
1738 local($argoff) = $num - 1;
1742 $type = TidyType($type) ;
1743 blurt("Error: '$type' not in typemap"), return
1744 unless defined($type_kind{$type});
1746 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1747 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1748 $tk = $type_kind{$type};
1749 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1750 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1751 print "\t$var" unless $name_printed;
1752 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1753 die "default value not supported with length(NAME) supplied"
1754 if defined $defaults{$var};
1757 $type =~ tr/:/_/ unless $hiertype;
1758 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1759 unless defined $input_expr{$tk} ;
1760 $expr = $input_expr{$tk};
1761 if ($expr =~ /DO_ARRAY_ELEM/) {
1762 blurt("Error: '$subtype' not in typemap"), return
1763 unless defined($type_kind{$subtype});
1764 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1765 unless defined $input_expr{$type_kind{$subtype}} ;
1766 $subexpr = $input_expr{$type_kind{$subtype}};
1767 $subexpr =~ s/\$type/\$subtype/g;
1768 $subexpr =~ s/ntype/subtype/g;
1769 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1770 $subexpr =~ s/\n\t/\n\t\t/g;
1771 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1772 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1773 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1775 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1778 if (defined($defaults{$var})) {
1779 $expr =~ s/(\t+)/$1 /g;
1781 if ($name_printed) {
1784 eval qq/print "\\t$var;\\n"/;
1787 if ($defaults{$var} eq 'NO_INIT') {
1788 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1790 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1793 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1794 if ($name_printed) {
1797 eval qq/print "\\t$var;\\n"/;
1800 $deferred .= eval qq/"\\n$expr;\\n"/;
1803 die "panic: do not know how to handle this branch for function pointers"
1805 eval qq/print "$expr;\\n"/;
1810 sub generate_output {
1811 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1812 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1813 local($argoff) = $num - 1;
1816 $type = TidyType($type) ;
1817 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1818 print "\t$arg = sv_newmortal();\n";
1819 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1820 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1822 blurt("Error: '$type' not in typemap"), return
1823 unless defined($type_kind{$type});
1824 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1825 unless defined $output_expr{$type_kind{$type}} ;
1826 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1827 $ntype =~ s/\(\)//g;
1828 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1829 $expr = $output_expr{$type_kind{$type}};
1830 if ($expr =~ /DO_ARRAY_ELEM/) {
1831 blurt("Error: '$subtype' not in typemap"), return
1832 unless defined($type_kind{$subtype});
1833 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1834 unless defined $output_expr{$type_kind{$subtype}} ;
1835 $subexpr = $output_expr{$type_kind{$subtype}};
1836 $subexpr =~ s/ntype/subtype/g;
1837 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1838 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1839 $subexpr =~ s/\n\t/\n\t\t/g;
1840 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1841 eval "print qq\a$expr\a";
1843 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1844 } elsif ($var eq 'RETVAL') {
1845 if ($expr =~ /^\t\$arg = new/) {
1846 # We expect that $arg has refcnt 1, so we need to
1848 eval "print qq\a$expr\a";
1850 print "\tsv_2mortal(ST($num));\n";
1851 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1852 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1853 # We expect that $arg has refcnt >=1, so we need
1855 eval "print qq\a$expr\a";
1857 print "\tsv_2mortal(ST(0));\n";
1858 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1860 # Just hope that the entry would safely write it
1861 # over an already mortalized value. By
1862 # coincidence, something like $arg = &sv_undef
1864 print "\tST(0) = sv_newmortal();\n";
1865 eval "print qq\a$expr\a";
1867 # new mortals don't have set magic
1869 } elsif ($do_push) {
1870 print "\tPUSHs(sv_newmortal());\n";
1872 eval "print qq\a$expr\a";
1874 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1875 } elsif ($arg =~ /^ST\(\d+\)$/) {
1876 eval "print qq\a$expr\a";
1878 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1884 my($type, $varname) = @_;
1886 # C++ has :: in types too so skip this
1887 $type =~ tr/:/_/ unless $hiertype;
1888 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1890 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1891 (substr $type, pos $type, 0) = " $varname ";
1893 $type .= "\t$varname";
1900 #########################################################
1902 ExtUtils::ParseXS::CountLines;
1904 use vars qw($SECTION_END_MARKER);
1907 my ($class, $cfile, $fh) = @_;
1908 $cfile =~ s/\\/\\\\/g;
1909 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1911 return bless {buffer => '',
1920 $self->{buffer} .= $_;
1921 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1923 ++ $self->{line_no};
1924 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1925 print {$self->{fh}} $line;
1933 $self->PRINT(sprintf($fmt, @_));
1937 # Not necessary if we're careful to end with a "\n"
1939 print {$self->{fh}} $self->{buffer};
1943 # This sub does nothing, but is neccessary for references to be released.
1947 return $SECTION_END_MARKER;
1956 ExtUtils::ParseXS - converts Perl XS code into C code
1960 use ExtUtils::ParseXS qw(process_file);
1962 process_file( filename => 'foo.xs' );
1964 process_file( filename => 'foo.xs',
1967 typemap => 'path/to/typemap',
1978 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1979 necessary to let C functions manipulate Perl values and creates the glue
1980 necessary to let Perl access those functions. The compiler uses typemaps to
1981 determine how to map C function parameters and variables to Perl values.
1983 The compiler will search for typemap files called I<typemap>. It will use
1984 the following search path to find default typemaps, with the rightmost
1985 typemap taking precedence.
1987 ../../../typemap:../../typemap:../typemap:typemap
1991 None by default. C<process_file()> may be exported upon request.
2000 This function processes an XS file and sends output to a C file.
2001 Named parameters control how the processing is done. The following
2002 parameters are accepted:
2008 Adds C<extern "C"> to the C code. Default is false.
2012 Retains C<::> in type names so that C++ hierachical types can be
2013 mapped. Default is false.
2017 Adds exception handling stubs to the C code. Default is false.
2021 Indicates that a user-supplied typemap should take precedence over the
2022 default typemaps. A single typemap may be specified as a string, or
2023 multiple typemaps can be specified in an array reference, with the
2024 last typemap having the highest precedence.
2028 Generates prototype code for all xsubs. Default is false.
2030 =item B<versioncheck>
2032 Makes sure at run time that the object file (derived from the C<.xs>
2033 file) and the C<.pm> files have the same version number. Default is
2036 =item B<linenumbers>
2038 Adds C<#line> directives to the C output so error messages will look
2039 like they came from the original XS file. Default is true.
2043 Enables certain optimizations. The only optimization that is currently
2044 affected is the use of I<target>s by the output C code (see L<perlguts>).
2045 Not optimizing may significantly slow down the generated code, but this is the way
2046 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2050 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2051 declarations. Default is true.
2055 Enable recognition of ANSI-like descriptions of function signature.
2060 I have no clue what this does. Strips function prefixes?
2066 This function returns the number of [a certain kind of] errors
2067 encountered during processing of the XS file.
2073 Based on xsubpp code, written by Larry Wall.
2075 Maintained by Ken Williams, <ken@mathforum.org>
2079 Copyright 2002-2003 Ken Williams. All rights reserved.
2081 This library is free software; you can redistribute it and/or
2082 modify it under the same terms as Perl itself.
2084 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2085 Porters, which was released under the same license terms.
2089 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.