1 package ExtUtils::ParseXS;
3 use 5.006; # We use /??{}/ in regexes
12 @EXPORT_OK = qw(process_file);
14 # use strict; # One of these days...
16 my(@XSStack); # Stack of conditionals and INCLUDEs
17 my($XSS_work_idx, $cpp_next_tmp);
19 use vars qw($VERSION);
21 $VERSION = eval $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...
63 my ($Is_VMS, $SymSet);
66 # Establish set of global symbols with max length 28, since xsubpp
67 # will later add the 'XS_' prefix.
68 require ExtUtils::XSSymSet;
69 $SymSet = new ExtUtils::XSSymSet 28;
71 @XSStack = ({type => 'none'});
72 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
75 $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
78 $Fallback = 'PL_sv_undef';
80 # Most of the 1500 lines below uses these globals. We'll have to
81 # clean this up sometime, probably. For now, we just pull them out
84 $cplusplus = $args{'C++'};
85 $hiertype = $args{hiertype};
86 $WantPrototypes = $args{prototypes};
87 $WantVersionChk = $args{versioncheck};
88 $except = $args{except} ? ' TRY' : '';
89 $WantLineNumbers = $args{linenumbers};
90 $WantOptimize = $args{optimize};
91 $process_inout = $args{inout};
92 $process_argtypes = $args{argtypes};
93 @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
95 for ($args{filename}) {
96 die "Missing required parameter 'filename'" unless $_;
98 ($dir, $filename) = (dirname($_), basename($_));
99 $filepathname =~ s/\\/\\\\/g;
100 $IncludedFiles{$_}++;
103 # Open the input file
104 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
106 # Open the output file if given as a string. If they provide some
107 # other kind of reference, trust them that we can print to it.
108 if (not ref $args{output}) {
109 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
110 $args{outfile} = $args{output};
114 # Really, we shouldn't have to chdir() or select() in the first
115 # place. For now, just save & restore.
116 my $orig_cwd = cwd();
117 my $orig_fh = select();
122 if ($WantLineNumbers) {
124 if ( $args{outfile} ) {
125 $cfile = $args{outfile};
127 $cfile = $args{filename};
128 $cfile =~ s/\.xs$/.c/i or $cfile .= ".c";
130 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
131 select PSEUDO_STDOUT;
133 select $args{output};
136 foreach my $typemap (@tm) {
137 die "Can't find $typemap in $pwd\n" unless -r $typemap;
140 push @tm, standard_typemap_locations();
142 foreach my $typemap (@tm) {
143 next unless -f $typemap ;
144 # skip directories, binary files etc.
145 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
147 open(TYPEMAP, $typemap)
148 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
149 my $mode = 'Typemap';
151 my $current = \$junk;
154 my $line_no = $. + 1;
156 $mode = 'Input'; $current = \$junk; next;
159 $mode = 'Output'; $current = \$junk; next;
161 if (/^TYPEMAP\s*$/) {
162 $mode = 'Typemap'; $current = \$junk; next;
164 if ($mode eq 'Typemap') {
168 # skip blank lines and comment lines
169 next if /^$/ or /^#/ ;
170 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
171 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
172 $type = TidyType($type) ;
173 $type_kind{$type} = $kind ;
174 # prototype defaults to '$'
175 $proto = "\$" unless $proto ;
176 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
177 unless ValidProtoString($proto) ;
178 $proto_letter{$type} = C_string($proto) ;
181 } elsif ($mode eq 'Input') {
183 $input_expr{$_} = '';
184 $current = \$input_expr{$_};
187 $output_expr{$_} = '';
188 $current = \$output_expr{$_};
194 foreach my $key (keys %input_expr) {
195 $input_expr{$key} =~ s/;*\s+\z//;
198 my ($bal, $cast, $size);
199 $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
200 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
201 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
203 foreach my $key (keys %output_expr) {
206 my ($t, $with_size, $arg, $sarg) =
207 ($output_expr{$key} =~
208 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
209 \s* \( \s* $cast \$arg \s* ,
210 \s* ( (??{ $bal }) ) # Set from
211 ( (??{ $size }) )? # Possible sizeof set-from
214 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
217 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
219 # Match an XS keyword
220 $BLOCK_re= '\s*(' . join('|', qw(
221 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
222 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
223 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
227 my ($C_group_rex, $C_arg);
228 # Group in C (no support for comments or literals)
229 $C_group_rex = qr/ [({\[]
230 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
232 # Chunk in C without comma at toplevel (no comments):
233 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
234 | (??{ $C_group_rex })
235 | " (?: (?> [^\\"]+ )
237 )* " # String literal
238 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
241 # Identify the version of xsubpp used
244 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
245 * contents of $filename. Do not edit this file, edit $filename instead.
247 * ANY CHANGES MADE HERE WILL BE LOST!
254 print("#line 1 \"$filepathname\"\n")
260 my $podstartline = $.;
263 # We can't just write out a /* */ comment, as our embedded
264 # POD might itself be in a comment. We can't put a /**/
265 # comment inside #if 0, as the C standard says that the source
266 # file is decomposed into preprocessing characters in the stage
267 # before preprocessing commands are executed.
268 # I don't want to leave the text as barewords, because the spec
269 # isn't clear whether macros are expanded before or after
270 # preprocessing commands are executed, and someone pathological
271 # may just have defined one of the 3 words as a macro that does
272 # something strange. Multiline strings are illegal in C, so
273 # the "" we write must be a string literal. And they aren't
274 # concatenated until 2 steps later, so we are safe.
276 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
277 printf("#line %d \"$filepathname\"\n", $. + 1)
283 # At this point $. is at end of file so die won't state the start
284 # of the problem, and as we haven't yet read any lines &death won't
285 # show the correct line in the message either.
286 die ("Error: Unterminated pod in $filename, line $podstartline\n")
289 last if ($Package, $Prefix) =
290 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
294 unless (defined $_) {
295 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
296 exit 0; # Not a fatal error for the caller process
300 #ifndef PERL_UNUSED_VAR
301 # define PERL_UNUSED_VAR(var) if (0) var = var
306 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
312 while (fetch_para()) {
313 # Print initial preprocessor statements and blank lines
314 while (@line && $line[0] !~ /^[^\#]/) {
315 my $line = shift(@line);
317 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
319 if ($statement eq 'if') {
320 $XSS_work_idx = @XSStack;
321 push(@XSStack, {type => 'if'});
323 death ("Error: `$statement' with no matching `if'")
324 if $XSStack[-1]{type} ne 'if';
325 if ($XSStack[-1]{varname}) {
326 push(@InitFileCode, "#endif\n");
327 push(@BootCode, "#endif");
330 my(@fns) = keys %{$XSStack[-1]{functions}};
331 if ($statement ne 'endif') {
332 # Hide the functions defined in other #if branches, and reset.
333 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
334 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
336 my($tmp) = pop(@XSStack);
337 0 while (--$XSS_work_idx
338 && $XSStack[$XSS_work_idx]{type} ne 'if');
339 # Keep all new defined functions
340 push(@fns, keys %{$tmp->{other_functions}});
341 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
346 next PARAGRAPH unless @line;
348 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
349 # We are inside an #if, but have not yet #defined its xsubpp variable.
350 print "#define $cpp_next_tmp 1\n\n";
351 push(@InitFileCode, "#if $cpp_next_tmp\n");
352 push(@BootCode, "#if $cpp_next_tmp");
353 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
356 death ("Code is not inside a function"
357 ." (maybe last function was ended by a blank line "
358 ." followed by a statement on column one?)")
359 if $line[0] =~ /^\s/;
361 my ($class, $static, $elipsis, $wantRETVAL, $RETVAL_no_return);
362 my (@fake_INPUT_pre); # For length(s) generated variables
365 # initialize info arrays
371 undef($processing_arg_with_types) ;
372 undef(%argtype_seen) ;
376 undef($proto_in_this_xsub) ;
377 undef($scope_in_this_xsub) ;
379 undef($prepush_done);
380 $interface_macro = 'XSINTERFACE_FUNC' ;
381 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
382 $ProtoThisXSUB = $WantPrototypes ;
387 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
388 &{"${kwd}_handler"}() ;
389 next PARAGRAPH unless @line ;
393 if (check_keyword("BOOT")) {
395 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
396 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
397 push (@BootCode, @line, "") ;
402 # extract return type, function name and arguments
403 ($ret_type) = TidyType($_);
404 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
406 # Allow one-line ANSI-like declaration
409 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
411 # a function definition needs at least 2 lines
412 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
415 $static = 1 if $ret_type =~ s/^static\s+//;
417 $func_header = shift(@line);
418 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
419 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
421 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
422 $class = "$4 $class" if $4;
423 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
424 ($clean_func_name = $func_name) =~ s/^$Prefix//;
425 $Full_func_name = "${Packid}_$clean_func_name";
427 $Full_func_name = $SymSet->addsym($Full_func_name);
430 # Check for duplicate function definition
431 for my $tmp (@XSStack) {
432 next unless defined $tmp->{functions}{$Full_func_name};
433 Warn("Warning: duplicate function definition '$clean_func_name' detected");
436 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
437 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
440 $orig_args =~ s/\\\s*/ /g; # process line continuations
443 my %only_C_inlist; # Not in the signature of Perl function
444 if ($process_argtypes and $orig_args =~ /\S/) {
445 my $args = "$orig_args ,";
446 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
447 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
451 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
452 my ($pre, $name) = ($arg =~ /(.*?) \s*
453 \b ( \w+ | length\( \s*\w+\s* \) )
455 next unless defined($pre) && length($pre);
458 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
460 $out_type = $type if $type ne 'IN';
461 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
462 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
465 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
466 $name = "XSauto_length_of_$1";
468 die "Default value on length() argument: `$_'"
471 if (length $pre or $islength) { # Has a type
473 push @fake_INPUT_pre, $arg;
475 push @fake_INPUT, $arg;
477 # warn "pushing '$arg'\n";
478 $argtype_seen{$name}++;
479 $_ = "$name$default"; # Assigns to @args
481 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
482 push @outlist, $name if $out_type =~ /OUTLIST$/;
483 $in_out{$name} = $out_type if $out_type;
486 @args = split(/\s*,\s*/, $orig_args);
487 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
490 @args = split(/\s*,\s*/, $orig_args);
492 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
494 next if $out_type eq 'IN';
495 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
496 push @outlist, $name if $out_type =~ /OUTLIST$/;
497 $in_out{$_} = $out_type;
501 if (defined($class)) {
502 my $arg0 = ((defined($static) or $func_name eq 'new')
504 unshift(@args, $arg0);
505 ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
510 my $report_args = '';
511 foreach my $i (0 .. $#args) {
512 if ($args[$i] =~ s/\.\.\.//) {
514 if ($args[$i] eq '' && $i == $#args) {
515 $report_args .= ", ...";
520 if ($only_C_inlist{$args[$i]}) {
521 push @args_num, undef;
523 push @args_num, ++$num_args;
524 $report_args .= ", $args[$i]";
526 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
529 $defaults{$args[$i]} = $2;
530 $defaults{$args[$i]} =~ s/"/\\"/g;
532 $proto_arg[$i+1] = '$' ;
534 $min_args = $num_args - $extra_args;
535 $report_args =~ s/"/\\"/g;
536 $report_args =~ s/^,\s+//;
537 my @func_args = @args;
538 shift @func_args if defined($class);
541 s/^/&/ if $in_out{$_};
543 $func_args = join(", ", @func_args);
544 @args_match{@args} = @args_num;
546 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
547 $CODE = grep(/^\s*CODE\s*:/, @line);
548 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
549 # to set explicit return values.
550 $EXPLICIT_RETURN = ($CODE &&
551 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
552 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
553 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
555 $xsreturn = 1 if $EXPLICIT_RETURN;
557 # print function header
559 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
560 #XS(XS_${Full_func_name})
564 print Q(<<"EOF") if $ALIAS ;
567 print Q(<<"EOF") if $INTERFACE ;
568 # dXSFUNCTION($ret_type);
571 $cond = ($min_args ? qq(items < $min_args) : 0);
572 } elsif ($min_args == $num_args) {
573 $cond = qq(items != $min_args);
575 $cond = qq(items < $min_args || items > $num_args);
578 print Q(<<"EOF") if $except;
584 { print Q(<<"EOF") if $cond }
586 # Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv)));
589 { print Q(<<"EOF") if $cond }
591 # Perl_croak(aTHX_ "Usage: $pname($report_args)");
594 # cv doesn't seem to be used, in most cases unless we go in
595 # the if of this else
597 # PERL_UNUSED_VAR(cv); /* -W */
600 #gcc -Wall: if an xsub has PPCODE is used
601 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
602 #hence `ax' (setup by dXSARGS) is unused
603 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
604 #but such a move could break third-party extensions
605 print Q(<<"EOF") if $PPCODE;
606 # PERL_UNUSED_VAR(ax); /* -Wall */
609 print Q(<<"EOF") if $PPCODE;
613 # Now do a block of some sort.
616 $cond = ''; # last CASE: condidional
617 push(@line, "$END:");
618 push(@line_no, $line_no[-1]);
622 &CASE_handler if check_keyword("CASE");
627 # do initialization of input variables
635 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
637 print Q(<<"EOF") if $ScopeThisXSUB;
642 if (!$thisdone && defined($class)) {
643 if (defined($static) or $func_name eq 'new') {
645 $var_types{"CLASS"} = "char *";
646 &generate_init("char *", 1, "CLASS");
650 $var_types{"THIS"} = "$class *";
651 &generate_init("$class *", 1, "THIS");
656 if (/^\s*NOT_IMPLEMENTED_YET/) {
657 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
660 if ($ret_type ne "void") {
661 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
663 $args_match{"RETVAL"} = 0;
664 $var_types{"RETVAL"} = $ret_type;
666 if $WantOptimize and $targetable{$type_kind{$ret_type}};
669 if (@fake_INPUT or @fake_INPUT_pre) {
670 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
672 $processing_arg_with_types = 1;
677 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
679 if (check_keyword("PPCODE")) {
681 death ("PPCODE must be last thing") if @line;
682 print "\tLEAVE;\n" if $ScopeThisXSUB;
683 print "\tPUTBACK;\n\treturn;\n";
684 } elsif (check_keyword("CODE")) {
686 } elsif (defined($class) and $func_name eq "DESTROY") {
688 print "delete THIS;\n";
691 if ($ret_type ne "void") {
695 if (defined($static)) {
696 if ($func_name eq 'new') {
697 $func_name = "$class";
701 } elsif (defined($class)) {
702 if ($func_name eq 'new') {
703 $func_name .= " $class";
708 $func_name =~ s/^\Q$args{'s'}//
709 if exists $args{'s'};
710 $func_name = 'XSFUNCTION' if $interface;
711 print "$func_name($func_args);\n";
715 # do output variables
716 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
717 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
718 # $wantRETVAL set if 'RETVAL =' autogenerated
719 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
721 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
723 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
724 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
726 # all OUTPUT done, so now push the return value on the stack
727 if ($gotRETVAL && $RETVAL_code) {
728 print "\t$RETVAL_code\n";
729 } elsif ($gotRETVAL || $wantRETVAL) {
730 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
732 my $type = $ret_type;
734 # 0: type, 1: with_size, 2: how, 3: how_size
735 if ($t and not $t->[1] and $t->[0] eq 'p') {
736 # PUSHp corresponds to setpvn. Treate setpv directly
737 my $what = eval qq("$t->[2]");
740 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
744 my $what = eval qq("$t->[2]");
748 $size = '' unless defined $size;
749 $size = eval qq("$size");
751 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
755 # RETVAL almost never needs SvSETMAGIC()
756 &generate_output($ret_type, 0, 'RETVAL', 0);
760 $xsreturn = 1 if $ret_type ne "void";
763 print "\tXSprePUSH;" if $c and not $prepush_done;
764 print "\tEXTEND(SP,$c);\n" if $c;
766 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
769 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
771 print Q(<<"EOF") if $ScopeThisXSUB;
774 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
778 # print function trailer
782 print Q(<<"EOF") if $except;
785 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
788 if (check_keyword("CASE")) {
789 blurt ("Error: No `CASE:' at top of function")
791 $_ = "CASE: $_"; # Restore CASE: label
794 last if $_ eq "$END:";
795 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
798 print Q(<<"EOF") if $except;
800 # Perl_croak(aTHX_ errbuf);
804 print Q(<<"EOF") unless $PPCODE;
805 # XSRETURN($xsreturn);
808 print Q(<<"EOF") unless $PPCODE;
818 my $newXS = "newXS" ;
821 # Build the prototype string for the xsub
822 if ($ProtoThisXSUB) {
823 $newXS = "newXSproto";
825 if ($ProtoThisXSUB eq 2) {
826 # User has specified empty prototype
828 elsif ($ProtoThisXSUB eq 1) {
830 if ($min_args < $num_args) {
832 $proto_arg[$min_args] .= ";" ;
834 push @proto_arg, "$s\@"
837 $proto = join ("", grep defined, @proto_arg);
840 # User has specified a prototype
841 $proto = $ProtoThisXSUB;
843 $proto = qq{, "$proto"};
847 $XsubAliases{$pname} = 0
848 unless defined $XsubAliases{$pname} ;
849 while ( ($name, $value) = each %XsubAliases) {
850 push(@InitFileCode, Q(<<"EOF"));
851 # cv = newXS(\"$name\", XS_$Full_func_name, file);
852 # XSANY.any_i32 = $value ;
854 push(@InitFileCode, Q(<<"EOF")) if $proto;
855 # sv_setpv((SV*)cv$proto) ;
859 elsif (@Attributes) {
860 push(@InitFileCode, Q(<<"EOF"));
861 # cv = newXS(\"$pname\", XS_$Full_func_name, file);
862 # apply_attrs_string("$Package", cv, "@Attributes", 0);
866 while ( ($name, $value) = each %Interfaces) {
867 $name = "$Package\::$name" unless $name =~ /::/;
868 push(@InitFileCode, Q(<<"EOF"));
869 # cv = newXS(\"$name\", XS_$Full_func_name, file);
870 # $interface_macro_set(cv,$value) ;
872 push(@InitFileCode, Q(<<"EOF")) if $proto;
873 # sv_setpv((SV*)cv$proto) ;
879 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
883 if ($Overload) # make it findable with fetchmethod
886 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
887 #XS(XS_${Packid}_nil)
893 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
894 /* Making a sub named "${Package}::()" allows the package */
895 /* to be findable via fetchmethod(), and causes */
896 /* overload::Overloaded("${Package}") to return true. */
897 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
898 MAKE_FETCHMETHOD_WORK
901 # print initialization routine
910 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
911 #XS(boot_$Module_cname)
919 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
921 print Q(<<"EOF") if $Full_func_name;
922 # char* file = __FILE__;
928 # PERL_UNUSED_VAR(cv); /* -W */
929 # PERL_UNUSED_VAR(items); /* -W */
932 print Q(<<"EOF") if $WantVersionChk ;
933 # XS_VERSION_BOOTCHECK ;
937 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
943 print Q(<<"EOF") if ($Overload);
944 # /* register the overloading (type 'A') magic */
945 # PL_amagic_generation++;
946 # /* The magic for overload gets a GV* via gv_fetchmeth as */
947 # /* mentioned above, and looks in the SV* slot of it for */
948 # /* the "fallback" status. */
950 # get_sv( "${Package}::()", TRUE ),
957 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
963 print "\n /* Initialisation Section */\n\n" ;
966 print "\n /* End of Initialisation Section */\n\n" ;
975 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
980 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
985 sub errors { $errors }
987 sub standard_typemap_locations {
988 # Add all the default typemap locations to the search path
989 my @tm = qw(typemap);
991 my $updir = File::Spec->updir;
992 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
993 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
995 unshift @tm, File::Spec->catfile($dir, 'typemap');
996 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
998 foreach my $dir (@INC) {
999 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1000 unshift @tm, $file if -e $file;
1007 $_[0] =~ s/^\s+|\s+$//go ;
1014 # rationalise any '*' by joining them into bunches and removing whitespace
1018 # change multiple whitespace into a single space
1021 # trim leading & trailing whitespace
1022 TrimWhitespace($_) ;
1027 # Input: ($_, @line) == unparsed input.
1028 # Output: ($_, @line) == (rest of line, following lines).
1029 # Return: the matched keyword if found, otherwise 0
1031 $_ = shift(@line) while !/\S/ && @line;
1032 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1036 # the "do" is required for right semantics
1037 do { $_ = shift(@line) } while !/\S/ && @line;
1039 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1040 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1041 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1044 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1050 while (!/\S/ && @line) {
1054 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1061 sub process_keyword($)
1066 &{"${kwd}_handler"}()
1067 while $kwd = check_keyword($pattern) ;
1071 blurt ("Error: `CASE:' after unconditional `CASE:'")
1072 if $condnum && $cond eq '';
1074 TrimWhitespace($cond);
1075 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1080 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1081 last if /^\s*NOT_IMPLEMENTED_YET/;
1082 next unless /\S/; # skip blank lines
1084 TrimWhitespace($_) ;
1087 # remove trailing semicolon if no initialisation
1088 s/\s*;$//g unless /[=;+].*\S/ ;
1090 # Process the length(foo) declarations
1091 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1092 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1093 $lengthof{$2} = $name;
1094 # $islengthof{$name} = $1;
1095 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1098 # check for optional initialisation code
1100 $var_init = $1 if s/\s*([=;+].*)$//s ;
1101 $var_init =~ s/"/\\"/g;
1104 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1105 or blurt("Error: invalid argument declaration '$line'"), next;
1107 # Check for duplicate definitions
1108 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1109 if $arg_list{$var_name}++
1110 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1112 $thisdone |= $var_name eq "THIS";
1113 $retvaldone |= $var_name eq "RETVAL";
1114 $var_types{$var_name} = $var_type;
1115 # XXXX This check is a safeguard against the unfinished conversion of
1116 # generate_init(). When generate_init() is fixed,
1117 # one can use 2-args map_type() unconditionally.
1118 if ($var_type =~ / \( \s* \* \s* \) /x) {
1119 # Function pointers are not yet supported with &output_init!
1120 print "\t" . &map_type($var_type, $var_name);
1123 print "\t" . &map_type($var_type);
1126 $var_num = $args_match{$var_name};
1128 $proto_arg[$var_num] = ProtoString($var_type)
1130 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1131 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1132 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1133 and $var_init !~ /\S/) {
1134 if ($name_printed) {
1137 print "\t$var_name;\n";
1139 } elsif ($var_init =~ /\S/) {
1140 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1141 } elsif ($var_num) {
1142 # generate initialization code
1143 &generate_init($var_type, $var_num, $var_name, $name_printed);
1150 sub OUTPUT_handler {
1151 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1153 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1154 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1157 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1158 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1159 if $outargs{$outarg} ++ ;
1160 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1161 # deal with RETVAL last
1162 $RETVAL_code = $outcode ;
1166 blurt ("Error: OUTPUT $outarg not an argument"), next
1167 unless defined($args_match{$outarg});
1168 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1169 unless defined $var_types{$outarg} ;
1170 $var_num = $args_match{$outarg};
1172 print "\t$outcode\n";
1173 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1175 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1177 delete $in_out{$outarg} # No need to auto-OUTPUT
1178 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1182 sub C_ARGS_handler() {
1183 my $in = merge_section();
1185 TrimWhitespace($in);
1189 sub INTERFACE_MACRO_handler() {
1190 my $in = merge_section();
1192 TrimWhitespace($in);
1193 if ($in =~ /\s/) { # two
1194 ($interface_macro, $interface_macro_set) = split ' ', $in;
1196 $interface_macro = $in;
1197 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1199 $interface = 1; # local
1200 $Interfaces = 1; # global
1203 sub INTERFACE_handler() {
1204 my $in = merge_section();
1206 TrimWhitespace($in);
1208 foreach (split /[\s,]+/, $in) {
1209 $Interfaces{$_} = $_;
1212 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1214 $interface = 1; # local
1215 $Interfaces = 1; # global
1218 sub CLEANUP_handler() { print_section() }
1219 sub PREINIT_handler() { print_section() }
1220 sub POSTCALL_handler() { print_section() }
1221 sub INIT_handler() { print_section() }
1226 my ($orig) = $line ;
1230 # Parse alias definitions
1232 # alias = value alias = value ...
1234 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1236 $orig_alias = $alias ;
1239 # check for optional package definition in the alias
1240 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1242 # check for duplicate alias name & duplicate value
1243 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1244 if defined $XsubAliases{$alias} ;
1246 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1247 if $XsubAliasValues{$value} ;
1250 $XsubAliases{$alias} = $value ;
1251 $XsubAliasValues{$value} = $orig_alias ;
1254 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1258 sub ATTRS_handler ()
1260 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1262 TrimWhitespace($_) ;
1263 push @Attributes, $_;
1267 sub ALIAS_handler ()
1269 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1271 TrimWhitespace($_) ;
1272 GetAliases($_) if $_ ;
1276 sub OVERLOAD_handler()
1278 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1280 TrimWhitespace($_) ;
1281 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1282 $Overload = 1 unless $Overload;
1283 my $overload = "$Package\::(".$1 ;
1285 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1290 sub FALLBACK_handler()
1292 # the rest of the current line should contain either TRUE,
1295 TrimWhitespace($_) ;
1297 TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
1298 FALSE => "PL_sv_no", 0 => "PL_sv_no",
1299 UNDEF => "PL_sv_undef",
1302 # check for valid FALLBACK value
1303 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1305 $Fallback = $map{uc $_} ;
1309 sub REQUIRE_handler ()
1311 # the rest of the current line should contain a version number
1314 TrimWhitespace($Ver) ;
1316 death ("Error: REQUIRE expects a version number")
1319 # check that the version number is of the form n.n
1320 death ("Error: REQUIRE: expected a number, got '$Ver'")
1321 unless $Ver =~ /^\d+(\.\d*)?/ ;
1323 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1324 unless $VERSION >= $Ver ;
1327 sub VERSIONCHECK_handler ()
1329 # the rest of the current line should contain either ENABLE or
1332 TrimWhitespace($_) ;
1334 # check for ENABLE/DISABLE
1335 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1336 unless /^(ENABLE|DISABLE)/i ;
1338 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1339 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1343 sub PROTOTYPE_handler ()
1347 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1348 if $proto_in_this_xsub ++ ;
1350 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1353 TrimWhitespace($_) ;
1354 if ($_ eq 'DISABLE') {
1356 } elsif ($_ eq 'ENABLE') {
1359 # remove any whitespace
1361 death("Error: Invalid prototype '$_'")
1362 unless ValidProtoString($_) ;
1363 $ProtoThisXSUB = C_string($_) ;
1367 # If no prototype specified, then assume empty prototype ""
1368 $ProtoThisXSUB = 2 unless $specified ;
1374 sub SCOPE_handler ()
1376 death("Error: Only 1 SCOPE declaration allowed per xsub")
1377 if $scope_in_this_xsub ++ ;
1379 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1381 TrimWhitespace($_) ;
1382 if ($_ =~ /^DISABLE/i) {
1384 } elsif ($_ =~ /^ENABLE/i) {
1391 sub PROTOTYPES_handler ()
1393 # the rest of the current line should contain either ENABLE or
1396 TrimWhitespace($_) ;
1398 # check for ENABLE/DISABLE
1399 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1400 unless /^(ENABLE|DISABLE)/i ;
1402 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1403 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1408 sub INCLUDE_handler ()
1410 # the rest of the current line should contain a valid filename
1412 TrimWhitespace($_) ;
1414 death("INCLUDE: filename missing")
1417 death("INCLUDE: output pipe is illegal")
1420 # simple minded recursion detector
1421 death("INCLUDE loop detected")
1422 if $IncludedFiles{$_} ;
1424 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1426 # Save the current file context.
1429 LastLine => $lastline,
1430 LastLineNo => $lastline_no,
1432 LineNo => \@line_no,
1433 Filename => $filename,
1440 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1444 #/* INCLUDE: Including '$_' from '$filename' */
1450 # Prime the pump by reading the first
1453 # skip leading blank lines
1455 last unless /^\s*$/ ;
1465 return 0 unless $XSStack[-1]{type} eq 'file' ;
1467 my $data = pop @XSStack ;
1468 my $ThisFile = $filename ;
1469 my $isPipe = ($filename =~ /\|\s*$/) ;
1471 -- $IncludedFiles{$filename}
1476 $FH = $data->{Handle} ;
1477 $filename = $data->{Filename} ;
1478 $lastline = $data->{LastLine} ;
1479 $lastline_no = $data->{LastLineNo} ;
1480 @line = @{ $data->{Line} } ;
1481 @line_no = @{ $data->{LineNo} } ;
1483 if ($isPipe and $? ) {
1485 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1491 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1498 sub ValidProtoString ($)
1502 if ( $string =~ /^$proto_re+$/ ) {
1513 $string =~ s[\\][\\\\]g ;
1521 $proto_letter{$type} or "\$" ;
1525 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1527 my ($cpp, $cpplevel);
1529 if ($cpp =~ /^\#\s*if/) {
1531 } elsif (!$cpplevel) {
1532 Warn("Warning: #else/elif/endif without #if in this function");
1533 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1534 if $XSStack[-1]{type} eq 'if';
1536 } elsif ($cpp =~ /^\#\s*endif/) {
1540 Warn("Warning: #if without #endif in this function") if $cpplevel;
1548 $text =~ s/\[\[/{/g;
1549 $text =~ s/\]\]/}/g;
1553 # Read next xsub into @line from ($lastline, <$FH>).
1556 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1557 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1560 return PopFile() if !defined $lastline;
1563 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1565 $Package = defined($2) ? $2 : ''; # keep -w happy
1566 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1567 $Prefix = quotemeta $Prefix ;
1568 ($Module_cname = $Module) =~ s/\W/_/g;
1569 ($Packid = $Package) =~ tr/:/_/;
1570 $Packprefix = $Package;
1571 $Packprefix .= "::" if $Packprefix ne "";
1576 # Skip embedded PODs
1577 while ($lastline =~ /^=/) {
1578 while ($lastline = <$FH>) {
1579 last if ($lastline =~ /^=cut\s*$/);
1581 death ("Error: Unterminated pod") unless $lastline;
1584 $lastline =~ s/^\s+$//;
1586 if ($lastline !~ /^\s*#/ ||
1588 # ANSI: if ifdef ifndef elif else endif define undef
1590 # gcc: warning include_next
1592 # others: ident (gcc notes that some cpps have this one)
1593 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1594 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1595 push(@line, $lastline);
1596 push(@line_no, $lastline_no) ;
1599 # Read next line and continuation lines
1600 last unless defined($lastline = <$FH>);
1603 $lastline .= $tmp_line
1604 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1607 $lastline =~ s/^\s+$//;
1609 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1614 local($type, $num, $var, $init, $name_printed) = @_;
1615 local($arg) = "ST(" . ($num - 1) . ")";
1617 if ( $init =~ /^=/ ) {
1618 if ($name_printed) {
1619 eval qq/print " $init\\n"/;
1621 eval qq/print "\\t$var $init\\n"/;
1625 if ( $init =~ s/^\+// && $num ) {
1626 &generate_init($type, $num, $var, $name_printed);
1627 } elsif ($name_printed) {
1631 eval qq/print "\\t$var;\\n"/;
1635 $deferred .= eval qq/"\\n\\t$init\\n"/;
1642 # work out the line number
1643 my $line_no = $line_no[@line_no - @line -1] ;
1645 print STDERR "@_ in $filename, line $line_no\n" ;
1661 local($type, $num, $var) = @_;
1662 local($arg) = "ST(" . ($num - 1) . ")";
1663 local($argoff) = $num - 1;
1667 $type = TidyType($type) ;
1668 blurt("Error: '$type' not in typemap"), return
1669 unless defined($type_kind{$type});
1671 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1672 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1673 $tk = $type_kind{$type};
1674 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1675 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1676 print "\t$var" unless $name_printed;
1677 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1678 die "default value not supported with length(NAME) supplied"
1679 if defined $defaults{$var};
1682 $type =~ tr/:/_/ unless $hiertype;
1683 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1684 unless defined $input_expr{$tk} ;
1685 $expr = $input_expr{$tk};
1686 if ($expr =~ /DO_ARRAY_ELEM/) {
1687 blurt("Error: '$subtype' not in typemap"), return
1688 unless defined($type_kind{$subtype});
1689 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1690 unless defined $input_expr{$type_kind{$subtype}} ;
1691 $subexpr = $input_expr{$type_kind{$subtype}};
1692 $subexpr =~ s/\$type/\$subtype/g;
1693 $subexpr =~ s/ntype/subtype/g;
1694 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1695 $subexpr =~ s/\n\t/\n\t\t/g;
1696 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1697 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1698 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1700 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1703 if (defined($defaults{$var})) {
1704 $expr =~ s/(\t+)/$1 /g;
1706 if ($name_printed) {
1709 eval qq/print "\\t$var;\\n"/;
1712 if ($defaults{$var} eq 'NO_INIT') {
1713 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1715 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1718 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1719 if ($name_printed) {
1722 eval qq/print "\\t$var;\\n"/;
1725 $deferred .= eval qq/"\\n$expr;\\n"/;
1728 die "panic: do not know how to handle this branch for function pointers"
1730 eval qq/print "$expr;\\n"/;
1735 sub generate_output {
1736 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1737 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1738 local($argoff) = $num - 1;
1741 $type = TidyType($type) ;
1742 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1743 print "\t$arg = sv_newmortal();\n";
1744 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1745 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1747 blurt("Error: '$type' not in typemap"), return
1748 unless defined($type_kind{$type});
1749 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1750 unless defined $output_expr{$type_kind{$type}} ;
1751 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1752 $ntype =~ s/\(\)//g;
1753 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1754 $expr = $output_expr{$type_kind{$type}};
1755 if ($expr =~ /DO_ARRAY_ELEM/) {
1756 blurt("Error: '$subtype' not in typemap"), return
1757 unless defined($type_kind{$subtype});
1758 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1759 unless defined $output_expr{$type_kind{$subtype}} ;
1760 $subexpr = $output_expr{$type_kind{$subtype}};
1761 $subexpr =~ s/ntype/subtype/g;
1762 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1763 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1764 $subexpr =~ s/\n\t/\n\t\t/g;
1765 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1766 eval "print qq\a$expr\a";
1768 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1769 } elsif ($var eq 'RETVAL') {
1770 if ($expr =~ /^\t\$arg = new/) {
1771 # We expect that $arg has refcnt 1, so we need to
1773 eval "print qq\a$expr\a";
1775 print "\tsv_2mortal(ST($num));\n";
1776 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1777 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1778 # We expect that $arg has refcnt >=1, so we need
1780 eval "print qq\a$expr\a";
1782 print "\tsv_2mortal(ST(0));\n";
1783 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1785 # Just hope that the entry would safely write it
1786 # over an already mortalized value. By
1787 # coincidence, something like $arg = &sv_undef
1789 print "\tST(0) = sv_newmortal();\n";
1790 eval "print qq\a$expr\a";
1792 # new mortals don't have set magic
1794 } elsif ($do_push) {
1795 print "\tPUSHs(sv_newmortal());\n";
1797 eval "print qq\a$expr\a";
1799 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1800 } elsif ($arg =~ /^ST\(\d+\)$/) {
1801 eval "print qq\a$expr\a";
1803 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1809 my($type, $varname) = @_;
1811 # C++ has :: in types too so skip this
1812 $type =~ tr/:/_/ unless $hiertype;
1813 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1815 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1816 (substr $type, pos $type, 0) = " $varname ";
1818 $type .= "\t$varname";
1825 #########################################################
1827 ExtUtils::ParseXS::CountLines;
1829 use vars qw($SECTION_END_MARKER);
1832 my ($class, $cfile, $fh) = @_;
1833 $cfile =~ s/\\/\\\\/g;
1834 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1836 return bless {buffer => '',
1845 $self->{buffer} .= $_;
1846 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1848 ++ $self->{line_no};
1849 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1850 print {$self->{fh}} $line;
1858 $self->PRINT(sprintf($fmt, @_));
1862 # Not necessary if we're careful to end with a "\n"
1864 print {$self->{fh}} $self->{buffer};
1868 # This sub does nothing, but is neccessary for references to be released.
1872 return $SECTION_END_MARKER;
1881 ExtUtils::ParseXS - converts Perl XS code into C code
1885 use ExtUtils::ParseXS qw(process_file);
1887 process_file( filename => 'foo.xs' );
1889 process_file( filename => 'foo.xs',
1892 typemap => 'path/to/typemap',
1903 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1904 necessary to let C functions manipulate Perl values and creates the glue
1905 necessary to let Perl access those functions. The compiler uses typemaps to
1906 determine how to map C function parameters and variables to Perl values.
1908 The compiler will search for typemap files called I<typemap>. It will use
1909 the following search path to find default typemaps, with the rightmost
1910 typemap taking precedence.
1912 ../../../typemap:../../typemap:../typemap:typemap
1916 None by default. C<process_file()> may be exported upon request.
1925 This function processes an XS file and sends output to a C file.
1926 Named parameters control how the processing is done. The following
1927 parameters are accepted:
1933 Adds C<extern "C"> to the C code. Default is false.
1937 Retains C<::> in type names so that C++ hierachical types can be
1938 mapped. Default is false.
1942 Adds exception handling stubs to the C code. Default is false.
1946 Indicates that a user-supplied typemap should take precedence over the
1947 default typemaps. A single typemap may be specified as a string, or
1948 multiple typemaps can be specified in an array reference, with the
1949 last typemap having the highest precedence.
1953 Generates prototype code for all xsubs. Default is false.
1955 =item B<versioncheck>
1957 Makes sure at run time that the object file (derived from the C<.xs>
1958 file) and the C<.pm> files have the same version number. Default is
1961 =item B<linenumbers>
1963 Adds C<#line> directives to the C output so error messages will look
1964 like they came from the original XS file. Default is true.
1968 Enables certain optimizations. The only optimization that is currently
1969 affected is the use of I<target>s by the output C code (see L<perlguts>).
1970 Not optimizing may significantly slow down the generated code, but this is the way
1971 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
1975 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
1976 declarations. Default is true.
1980 Enable recognition of ANSI-like descriptions of function signature.
1985 I have no clue what this does. Strips function prefixes?
1991 This function returns the number of [a certain kind of] errors
1992 encountered during processing of the XS file.
1998 Based on xsubpp code, written by Larry Wall.
2000 Maintained by Ken Williams, <ken@mathforum.org>
2004 Copyright 2002-2003 Ken Williams. All rights reserved.
2006 This library is free software; you can redistribute it and/or
2007 modify it under the same terms as Perl itself.
2009 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2010 Porters, which was released under the same license terms.
2014 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.