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 $key (keys %input_expr) {
197 $input_expr{$key} =~ s/;*\s+\z//;
201 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
202 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
203 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
205 foreach my $key (keys %output_expr) {
207 BEGIN { $^H |= 0x00200000};
209 my ($t, $with_size, $arg, $sarg) =
210 ($output_expr{$key} =~
211 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
212 \s* \( \s* $cast \$arg \s* ,
213 \s* ( (??{ $bal }) ) # Set from
214 ( (??{ $size }) )? # Possible sizeof set-from
217 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
220 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
222 # Match an XS keyword
223 $BLOCK_re= '\s*(' . join('|', qw(
224 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
225 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
226 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
230 our ($C_group_rex, $C_arg);
231 # Group in C (no support for comments or literals)
232 $C_group_rex = qr/ [({\[]
233 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
235 # Chunk in C without comma at toplevel (no comments):
236 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
237 | (??{ $C_group_rex })
238 | " (?: (?> [^\\"]+ )
240 )* " # String literal
241 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
244 # Identify the version of xsubpp used
247 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
248 * contents of $filename. Do not edit this file, edit $filename instead.
250 * ANY CHANGES MADE HERE WILL BE LOST!
257 print("#line 1 \"$filepathname\"\n")
263 my $podstartline = $.;
266 # We can't just write out a /* */ comment, as our embedded
267 # POD might itself be in a comment. We can't put a /**/
268 # comment inside #if 0, as the C standard says that the source
269 # file is decomposed into preprocessing characters in the stage
270 # before preprocessing commands are executed.
271 # I don't want to leave the text as barewords, because the spec
272 # isn't clear whether macros are expanded before or after
273 # preprocessing commands are executed, and someone pathological
274 # may just have defined one of the 3 words as a macro that does
275 # something strange. Multiline strings are illegal in C, so
276 # the "" we write must be a string literal. And they aren't
277 # concatenated until 2 steps later, so we are safe.
279 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
280 printf("#line %d \"$filepathname\"\n", $. + 1)
286 # At this point $. is at end of file so die won't state the start
287 # of the problem, and as we haven't yet read any lines &death won't
288 # show the correct line in the message either.
289 die ("Error: Unterminated pod in $filename, line $podstartline\n")
292 last if ($Package, $Prefix) =
293 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
297 unless (defined $_) {
298 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
299 exit 0; # Not a fatal error for the caller process
303 #ifndef PERL_UNUSED_VAR
304 # define PERL_UNUSED_VAR(var) if (0) var = var
309 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
315 while (fetch_para()) {
316 # Print initial preprocessor statements and blank lines
317 while (@line && $line[0] !~ /^[^\#]/) {
318 my $line = shift(@line);
320 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
322 if ($statement eq 'if') {
323 $XSS_work_idx = @XSStack;
324 push(@XSStack, {type => 'if'});
326 death ("Error: `$statement' with no matching `if'")
327 if $XSStack[-1]{type} ne 'if';
328 if ($XSStack[-1]{varname}) {
329 push(@InitFileCode, "#endif\n");
330 push(@BootCode, "#endif");
333 my(@fns) = keys %{$XSStack[-1]{functions}};
334 if ($statement ne 'endif') {
335 # Hide the functions defined in other #if branches, and reset.
336 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
337 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
339 my($tmp) = pop(@XSStack);
340 0 while (--$XSS_work_idx
341 && $XSStack[$XSS_work_idx]{type} ne 'if');
342 # Keep all new defined functions
343 push(@fns, keys %{$tmp->{other_functions}});
344 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
349 next PARAGRAPH unless @line;
351 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
352 # We are inside an #if, but have not yet #defined its xsubpp variable.
353 print "#define $cpp_next_tmp 1\n\n";
354 push(@InitFileCode, "#if $cpp_next_tmp\n");
355 push(@BootCode, "#if $cpp_next_tmp");
356 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
359 death ("Code is not inside a function"
360 ." (maybe last function was ended by a blank line "
361 ." followed by a statement on column one?)")
362 if $line[0] =~ /^\s/;
364 my ($class, $externC, $static, $elipsis, $wantRETVAL, $RETVAL_no_return);
365 my (@fake_INPUT_pre); # For length(s) generated variables
368 # initialize info arrays
374 undef($processing_arg_with_types) ;
375 undef(%argtype_seen) ;
379 undef($proto_in_this_xsub) ;
380 undef($scope_in_this_xsub) ;
382 undef($prepush_done);
383 $interface_macro = 'XSINTERFACE_FUNC' ;
384 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
385 $ProtoThisXSUB = $WantPrototypes ;
390 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
391 &{"${kwd}_handler"}() ;
392 next PARAGRAPH unless @line ;
396 if (check_keyword("BOOT")) {
398 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
399 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
400 push (@BootCode, @line, "") ;
405 # extract return type, function name and arguments
406 ($ret_type) = TidyType($_);
407 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
409 # Allow one-line ANSI-like declaration
412 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
414 # a function definition needs at least 2 lines
415 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
418 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
419 $static = 1 if $ret_type =~ s/^static\s+//;
421 $func_header = shift(@line);
422 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
423 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
425 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
426 $class = "$4 $class" if $4;
427 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
428 ($clean_func_name = $func_name) =~ s/^$Prefix//;
429 $Full_func_name = "${Packid}_$clean_func_name";
431 $Full_func_name = $SymSet->addsym($Full_func_name);
434 # Check for duplicate function definition
435 for my $tmp (@XSStack) {
436 next unless defined $tmp->{functions}{$Full_func_name};
437 Warn("Warning: duplicate function definition '$clean_func_name' detected");
440 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
441 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
444 $orig_args =~ s/\\\s*/ /g; # process line continuations
447 my %only_C_inlist; # Not in the signature of Perl function
448 if ($process_argtypes and $orig_args =~ /\S/) {
449 my $args = "$orig_args ,";
450 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
451 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
455 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
456 my ($pre, $name) = ($arg =~ /(.*?) \s*
457 \b ( \w+ | length\( \s*\w+\s* \) )
459 next unless defined($pre) && length($pre);
462 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
464 $out_type = $type if $type ne 'IN';
465 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
466 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
469 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
470 $name = "XSauto_length_of_$1";
472 die "Default value on length() argument: `$_'"
475 if (length $pre or $islength) { # Has a type
477 push @fake_INPUT_pre, $arg;
479 push @fake_INPUT, $arg;
481 # warn "pushing '$arg'\n";
482 $argtype_seen{$name}++;
483 $_ = "$name$default"; # Assigns to @args
485 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
486 push @outlist, $name if $out_type =~ /OUTLIST$/;
487 $in_out{$name} = $out_type if $out_type;
490 @args = split(/\s*,\s*/, $orig_args);
491 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
494 @args = split(/\s*,\s*/, $orig_args);
496 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
498 next if $out_type eq 'IN';
499 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
500 push @outlist, $name if $out_type =~ /OUTLIST$/;
501 $in_out{$_} = $out_type;
505 if (defined($class)) {
506 my $arg0 = ((defined($static) or $func_name eq 'new')
508 unshift(@args, $arg0);
509 ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
514 my $report_args = '';
515 foreach my $i (0 .. $#args) {
516 if ($args[$i] =~ s/\.\.\.//) {
518 if ($args[$i] eq '' && $i == $#args) {
519 $report_args .= ", ...";
524 if ($only_C_inlist{$args[$i]}) {
525 push @args_num, undef;
527 push @args_num, ++$num_args;
528 $report_args .= ", $args[$i]";
530 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
533 $defaults{$args[$i]} = $2;
534 $defaults{$args[$i]} =~ s/"/\\"/g;
536 $proto_arg[$i+1] = '$' ;
538 $min_args = $num_args - $extra_args;
539 $report_args =~ s/"/\\"/g;
540 $report_args =~ s/^,\s+//;
541 my @func_args = @args;
542 shift @func_args if defined($class);
545 s/^/&/ if $in_out{$_};
547 $func_args = join(", ", @func_args);
548 @args_match{@args} = @args_num;
550 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
551 $CODE = grep(/^\s*CODE\s*:/, @line);
552 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
553 # to set explicit return values.
554 $EXPLICIT_RETURN = ($CODE &&
555 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
556 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
557 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
559 $xsreturn = 1 if $EXPLICIT_RETURN;
561 $externC = $externC ? qq[extern "C"] : "";
563 # print function header
566 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
567 #XS(XS_${Full_func_name})
575 print Q(<<"EOF") if $ALIAS ;
578 print Q(<<"EOF") if $INTERFACE ;
579 # dXSFUNCTION($ret_type);
582 $cond = ($min_args ? qq(items < $min_args) : 0);
583 } elsif ($min_args == $num_args) {
584 $cond = qq(items != $min_args);
586 $cond = qq(items < $min_args || items > $num_args);
589 print Q(<<"EOF") if $except;
595 { print Q(<<"EOF") if $cond }
597 # Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "$report_args");
600 { print Q(<<"EOF") if $cond }
602 # Perl_croak(aTHX_ "Usage: %s(%s)", "$pname", "$report_args");
605 # cv doesn't seem to be used, in most cases unless we go in
606 # the if of this else
608 # PERL_UNUSED_VAR(cv); /* -W */
611 #gcc -Wall: if an xsub has PPCODE is used
612 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
613 #hence `ax' (setup by dXSARGS) is unused
614 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
615 #but such a move could break third-party extensions
616 print Q(<<"EOF") if $PPCODE;
617 # PERL_UNUSED_VAR(ax); /* -Wall */
620 print Q(<<"EOF") if $PPCODE;
624 # Now do a block of some sort.
627 $cond = ''; # last CASE: condidional
628 push(@line, "$END:");
629 push(@line_no, $line_no[-1]);
633 &CASE_handler if check_keyword("CASE");
638 # do initialization of input variables
646 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
648 print Q(<<"EOF") if $ScopeThisXSUB;
653 if (!$thisdone && defined($class)) {
654 if (defined($static) or $func_name eq 'new') {
656 $var_types{"CLASS"} = "char *";
657 &generate_init("char *", 1, "CLASS");
661 $var_types{"THIS"} = "$class *";
662 &generate_init("$class *", 1, "THIS");
667 if (/^\s*NOT_IMPLEMENTED_YET/) {
668 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
671 if ($ret_type ne "void") {
672 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
674 $args_match{"RETVAL"} = 0;
675 $var_types{"RETVAL"} = $ret_type;
677 if $WantOptimize and $targetable{$type_kind{$ret_type}};
680 if (@fake_INPUT or @fake_INPUT_pre) {
681 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
683 $processing_arg_with_types = 1;
688 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
690 if (check_keyword("PPCODE")) {
692 death ("PPCODE must be last thing") if @line;
693 print "\tLEAVE;\n" if $ScopeThisXSUB;
694 print "\tPUTBACK;\n\treturn;\n";
695 } elsif (check_keyword("CODE")) {
697 } elsif (defined($class) and $func_name eq "DESTROY") {
699 print "delete THIS;\n";
702 if ($ret_type ne "void") {
706 if (defined($static)) {
707 if ($func_name eq 'new') {
708 $func_name = "$class";
712 } elsif (defined($class)) {
713 if ($func_name eq 'new') {
714 $func_name .= " $class";
719 $func_name =~ s/^\Q$args{'s'}//
720 if exists $args{'s'};
721 $func_name = 'XSFUNCTION' if $interface;
722 print "$func_name($func_args);\n";
726 # do output variables
727 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
728 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
729 # $wantRETVAL set if 'RETVAL =' autogenerated
730 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
732 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
734 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
735 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
737 # all OUTPUT done, so now push the return value on the stack
738 if ($gotRETVAL && $RETVAL_code) {
739 print "\t$RETVAL_code\n";
740 } elsif ($gotRETVAL || $wantRETVAL) {
741 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
743 my $type = $ret_type;
745 # 0: type, 1: with_size, 2: how, 3: how_size
746 if ($t and not $t->[1] and $t->[0] eq 'p') {
747 # PUSHp corresponds to setpvn. Treate setpv directly
748 my $what = eval qq("$t->[2]");
751 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
755 my $what = eval qq("$t->[2]");
759 $size = '' unless defined $size;
760 $size = eval qq("$size");
762 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
766 # RETVAL almost never needs SvSETMAGIC()
767 &generate_output($ret_type, 0, 'RETVAL', 0);
771 $xsreturn = 1 if $ret_type ne "void";
774 print "\tXSprePUSH;" if $c and not $prepush_done;
775 print "\tEXTEND(SP,$c);\n" if $c;
777 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
780 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
782 print Q(<<"EOF") if $ScopeThisXSUB;
785 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
789 # print function trailer
793 print Q(<<"EOF") if $except;
796 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
799 if (check_keyword("CASE")) {
800 blurt ("Error: No `CASE:' at top of function")
802 $_ = "CASE: $_"; # Restore CASE: label
805 last if $_ eq "$END:";
806 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
809 print Q(<<"EOF") if $except;
811 # Perl_croak(aTHX_ errbuf);
815 print Q(<<"EOF") unless $PPCODE;
816 # XSRETURN($xsreturn);
819 print Q(<<"EOF") unless $PPCODE;
829 my $newXS = "newXS" ;
832 # Build the prototype string for the xsub
833 if ($ProtoThisXSUB) {
834 $newXS = "newXSproto";
836 if ($ProtoThisXSUB eq 2) {
837 # User has specified empty prototype
839 elsif ($ProtoThisXSUB eq 1) {
841 if ($min_args < $num_args) {
843 $proto_arg[$min_args] .= ";" ;
845 push @proto_arg, "$s\@"
848 $proto = join ("", grep defined, @proto_arg);
851 # User has specified a prototype
852 $proto = $ProtoThisXSUB;
854 $proto = qq{, "$proto"};
858 $XsubAliases{$pname} = 0
859 unless defined $XsubAliases{$pname} ;
860 while ( ($name, $value) = each %XsubAliases) {
861 push(@InitFileCode, Q(<<"EOF"));
862 # cv = newXS(\"$name\", XS_$Full_func_name, file);
863 # XSANY.any_i32 = $value ;
865 push(@InitFileCode, Q(<<"EOF")) if $proto;
866 # sv_setpv((SV*)cv$proto) ;
870 elsif (@Attributes) {
871 push(@InitFileCode, Q(<<"EOF"));
872 # cv = newXS(\"$pname\", XS_$Full_func_name, file);
873 # apply_attrs_string("$Package", cv, "@Attributes", 0);
877 while ( ($name, $value) = each %Interfaces) {
878 $name = "$Package\::$name" unless $name =~ /::/;
879 push(@InitFileCode, Q(<<"EOF"));
880 # cv = newXS(\"$name\", XS_$Full_func_name, file);
881 # $interface_macro_set(cv,$value) ;
883 push(@InitFileCode, Q(<<"EOF")) if $proto;
884 # sv_setpv((SV*)cv$proto) ;
890 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
894 if ($Overload) # make it findable with fetchmethod
897 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
898 #XS(XS_${Packid}_nil)
904 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
905 /* Making a sub named "${Package}::()" allows the package */
906 /* to be findable via fetchmethod(), and causes */
907 /* overload::Overloaded("${Package}") to return true. */
908 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
909 MAKE_FETCHMETHOD_WORK
912 # print initialization routine
921 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
922 #XS(boot_$Module_cname)
934 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
936 print Q(<<"EOF") if $Full_func_name;
937 # char* file = __FILE__;
943 # PERL_UNUSED_VAR(cv); /* -W */
944 # PERL_UNUSED_VAR(items); /* -W */
947 print Q(<<"EOF") if $WantVersionChk ;
948 # XS_VERSION_BOOTCHECK ;
952 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
958 print Q(<<"EOF") if ($Overload);
959 # /* register the overloading (type 'A') magic */
960 # PL_amagic_generation++;
961 # /* The magic for overload gets a GV* via gv_fetchmeth as */
962 # /* mentioned above, and looks in the SV* slot of it for */
963 # /* the "fallback" status. */
965 # get_sv( "${Package}::()", TRUE ),
972 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
978 print "\n /* Initialisation Section */\n\n" ;
981 print "\n /* End of Initialisation Section */\n\n" ;
987 call_list(PL_scopestack_ix, PL_unitcheckav);
996 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1001 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1007 sub errors { $errors }
1009 sub standard_typemap_locations {
1010 # Add all the default typemap locations to the search path
1011 my @tm = qw(typemap);
1013 my $updir = File::Spec->updir;
1014 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1015 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1017 unshift @tm, File::Spec->catfile($dir, 'typemap');
1018 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1020 foreach my $dir (@INC) {
1021 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1022 unshift @tm, $file if -e $file;
1029 $_[0] =~ s/^\s+|\s+$//go ;
1036 # rationalise any '*' by joining them into bunches and removing whitespace
1040 # change multiple whitespace into a single space
1043 # trim leading & trailing whitespace
1044 TrimWhitespace($_) ;
1049 # Input: ($_, @line) == unparsed input.
1050 # Output: ($_, @line) == (rest of line, following lines).
1051 # Return: the matched keyword if found, otherwise 0
1053 $_ = shift(@line) while !/\S/ && @line;
1054 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1058 # the "do" is required for right semantics
1059 do { $_ = shift(@line) } while !/\S/ && @line;
1061 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1062 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1063 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1066 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1072 while (!/\S/ && @line) {
1076 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1083 sub process_keyword($)
1088 &{"${kwd}_handler"}()
1089 while $kwd = check_keyword($pattern) ;
1093 blurt ("Error: `CASE:' after unconditional `CASE:'")
1094 if $condnum && $cond eq '';
1096 TrimWhitespace($cond);
1097 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1102 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1103 last if /^\s*NOT_IMPLEMENTED_YET/;
1104 next unless /\S/; # skip blank lines
1106 TrimWhitespace($_) ;
1109 # remove trailing semicolon if no initialisation
1110 s/\s*;$//g unless /[=;+].*\S/ ;
1112 # Process the length(foo) declarations
1113 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1114 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1115 $lengthof{$2} = $name;
1116 # $islengthof{$name} = $1;
1117 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1120 # check for optional initialisation code
1122 $var_init = $1 if s/\s*([=;+].*)$//s ;
1123 $var_init =~ s/"/\\"/g;
1126 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1127 or blurt("Error: invalid argument declaration '$line'"), next;
1129 # Check for duplicate definitions
1130 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1131 if $arg_list{$var_name}++
1132 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1134 $thisdone |= $var_name eq "THIS";
1135 $retvaldone |= $var_name eq "RETVAL";
1136 $var_types{$var_name} = $var_type;
1137 # XXXX This check is a safeguard against the unfinished conversion of
1138 # generate_init(). When generate_init() is fixed,
1139 # one can use 2-args map_type() unconditionally.
1140 if ($var_type =~ / \( \s* \* \s* \) /x) {
1141 # Function pointers are not yet supported with &output_init!
1142 print "\t" . &map_type($var_type, $var_name);
1145 print "\t" . &map_type($var_type);
1148 $var_num = $args_match{$var_name};
1150 $proto_arg[$var_num] = ProtoString($var_type)
1152 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1153 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1154 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1155 and $var_init !~ /\S/) {
1156 if ($name_printed) {
1159 print "\t$var_name;\n";
1161 } elsif ($var_init =~ /\S/) {
1162 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1163 } elsif ($var_num) {
1164 # generate initialization code
1165 &generate_init($var_type, $var_num, $var_name, $name_printed);
1172 sub OUTPUT_handler {
1173 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1175 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1176 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1179 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1180 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1181 if $outargs{$outarg} ++ ;
1182 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1183 # deal with RETVAL last
1184 $RETVAL_code = $outcode ;
1188 blurt ("Error: OUTPUT $outarg not an argument"), next
1189 unless defined($args_match{$outarg});
1190 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1191 unless defined $var_types{$outarg} ;
1192 $var_num = $args_match{$outarg};
1194 print "\t$outcode\n";
1195 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1197 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1199 delete $in_out{$outarg} # No need to auto-OUTPUT
1200 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1204 sub C_ARGS_handler() {
1205 my $in = merge_section();
1207 TrimWhitespace($in);
1211 sub INTERFACE_MACRO_handler() {
1212 my $in = merge_section();
1214 TrimWhitespace($in);
1215 if ($in =~ /\s/) { # two
1216 ($interface_macro, $interface_macro_set) = split ' ', $in;
1218 $interface_macro = $in;
1219 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1221 $interface = 1; # local
1222 $Interfaces = 1; # global
1225 sub INTERFACE_handler() {
1226 my $in = merge_section();
1228 TrimWhitespace($in);
1230 foreach (split /[\s,]+/, $in) {
1232 $name =~ s/^$Prefix//;
1233 $Interfaces{$name} = $_;
1236 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1238 $interface = 1; # local
1239 $Interfaces = 1; # global
1242 sub CLEANUP_handler() { print_section() }
1243 sub PREINIT_handler() { print_section() }
1244 sub POSTCALL_handler() { print_section() }
1245 sub INIT_handler() { print_section() }
1250 my ($orig) = $line ;
1254 # Parse alias definitions
1256 # alias = value alias = value ...
1258 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1260 $orig_alias = $alias ;
1263 # check for optional package definition in the alias
1264 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1266 # check for duplicate alias name & duplicate value
1267 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1268 if defined $XsubAliases{$alias} ;
1270 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1271 if $XsubAliasValues{$value} ;
1274 $XsubAliases{$alias} = $value ;
1275 $XsubAliasValues{$value} = $orig_alias ;
1278 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1282 sub ATTRS_handler ()
1284 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1286 TrimWhitespace($_) ;
1287 push @Attributes, $_;
1291 sub ALIAS_handler ()
1293 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1295 TrimWhitespace($_) ;
1296 GetAliases($_) if $_ ;
1300 sub OVERLOAD_handler()
1302 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1304 TrimWhitespace($_) ;
1305 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1306 $Overload = 1 unless $Overload;
1307 my $overload = "$Package\::(".$1 ;
1309 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1314 sub FALLBACK_handler()
1316 # the rest of the current line should contain either TRUE,
1319 TrimWhitespace($_) ;
1321 TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
1322 FALSE => "PL_sv_no", 0 => "PL_sv_no",
1323 UNDEF => "PL_sv_undef",
1326 # check for valid FALLBACK value
1327 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1329 $Fallback = $map{uc $_} ;
1333 sub REQUIRE_handler ()
1335 # the rest of the current line should contain a version number
1338 TrimWhitespace($Ver) ;
1340 death ("Error: REQUIRE expects a version number")
1343 # check that the version number is of the form n.n
1344 death ("Error: REQUIRE: expected a number, got '$Ver'")
1345 unless $Ver =~ /^\d+(\.\d*)?/ ;
1347 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1348 unless $VERSION >= $Ver ;
1351 sub VERSIONCHECK_handler ()
1353 # the rest of the current line should contain either ENABLE or
1356 TrimWhitespace($_) ;
1358 # check for ENABLE/DISABLE
1359 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1360 unless /^(ENABLE|DISABLE)/i ;
1362 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1363 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1367 sub PROTOTYPE_handler ()
1371 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1372 if $proto_in_this_xsub ++ ;
1374 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1377 TrimWhitespace($_) ;
1378 if ($_ eq 'DISABLE') {
1380 } elsif ($_ eq 'ENABLE') {
1383 # remove any whitespace
1385 death("Error: Invalid prototype '$_'")
1386 unless ValidProtoString($_) ;
1387 $ProtoThisXSUB = C_string($_) ;
1391 # If no prototype specified, then assume empty prototype ""
1392 $ProtoThisXSUB = 2 unless $specified ;
1398 sub SCOPE_handler ()
1400 death("Error: Only 1 SCOPE declaration allowed per xsub")
1401 if $scope_in_this_xsub ++ ;
1403 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1405 TrimWhitespace($_) ;
1406 if ($_ =~ /^DISABLE/i) {
1408 } elsif ($_ =~ /^ENABLE/i) {
1415 sub PROTOTYPES_handler ()
1417 # the rest of the current line should contain either ENABLE or
1420 TrimWhitespace($_) ;
1422 # check for ENABLE/DISABLE
1423 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1424 unless /^(ENABLE|DISABLE)/i ;
1426 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1427 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1432 sub INCLUDE_handler ()
1434 # the rest of the current line should contain a valid filename
1436 TrimWhitespace($_) ;
1438 death("INCLUDE: filename missing")
1441 death("INCLUDE: output pipe is illegal")
1444 # simple minded recursion detector
1445 death("INCLUDE loop detected")
1446 if $IncludedFiles{$_} ;
1448 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1450 # Save the current file context.
1453 LastLine => $lastline,
1454 LastLineNo => $lastline_no,
1456 LineNo => \@line_no,
1457 Filename => $filename,
1458 Filepathname => $filepathname,
1462 $FH = Symbol::gensym();
1465 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1469 #/* INCLUDE: Including '$_' from '$filename' */
1473 $filepathname = $filename = $_ ;
1475 # Prime the pump by reading the first
1478 # skip leading blank lines
1480 last unless /^\s*$/ ;
1490 return 0 unless $XSStack[-1]{type} eq 'file' ;
1492 my $data = pop @XSStack ;
1493 my $ThisFile = $filename ;
1494 my $isPipe = ($filename =~ /\|\s*$/) ;
1496 -- $IncludedFiles{$filename}
1501 $FH = $data->{Handle} ;
1502 # $filename is the leafname, which for some reason isused for diagnostic
1503 # messages, whereas $filepathname is the full pathname, and is used for
1505 $filename = $data->{Filename} ;
1506 $filepathname = $data->{Filepathname} ;
1507 $lastline = $data->{LastLine} ;
1508 $lastline_no = $data->{LastLineNo} ;
1509 @line = @{ $data->{Line} } ;
1510 @line_no = @{ $data->{LineNo} } ;
1512 if ($isPipe and $? ) {
1514 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1520 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1527 sub ValidProtoString ($)
1531 if ( $string =~ /^$proto_re+$/ ) {
1542 $string =~ s[\\][\\\\]g ;
1550 $proto_letter{$type} or "\$" ;
1554 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1556 my ($cpp, $cpplevel);
1558 if ($cpp =~ /^\#\s*if/) {
1560 } elsif (!$cpplevel) {
1561 Warn("Warning: #else/elif/endif without #if in this function");
1562 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1563 if $XSStack[-1]{type} eq 'if';
1565 } elsif ($cpp =~ /^\#\s*endif/) {
1569 Warn("Warning: #if without #endif in this function") if $cpplevel;
1577 $text =~ s/\[\[/{/g;
1578 $text =~ s/\]\]/}/g;
1582 # Read next xsub into @line from ($lastline, <$FH>).
1585 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1586 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1589 return PopFile() if !defined $lastline;
1592 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1594 $Package = defined($2) ? $2 : ''; # keep -w happy
1595 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1596 $Prefix = quotemeta $Prefix ;
1597 ($Module_cname = $Module) =~ s/\W/_/g;
1598 ($Packid = $Package) =~ tr/:/_/;
1599 $Packprefix = $Package;
1600 $Packprefix .= "::" if $Packprefix ne "";
1605 # Skip embedded PODs
1606 while ($lastline =~ /^=/) {
1607 while ($lastline = <$FH>) {
1608 last if ($lastline =~ /^=cut\s*$/);
1610 death ("Error: Unterminated pod") unless $lastline;
1613 $lastline =~ s/^\s+$//;
1615 if ($lastline !~ /^\s*#/ ||
1617 # ANSI: if ifdef ifndef elif else endif define undef
1619 # gcc: warning include_next
1621 # others: ident (gcc notes that some cpps have this one)
1622 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1623 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1624 push(@line, $lastline);
1625 push(@line_no, $lastline_no) ;
1628 # Read next line and continuation lines
1629 last unless defined($lastline = <$FH>);
1632 $lastline .= $tmp_line
1633 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1636 $lastline =~ s/^\s+$//;
1638 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1643 local($type, $num, $var, $init, $name_printed) = @_;
1644 local($arg) = "ST(" . ($num - 1) . ")";
1646 if ( $init =~ /^=/ ) {
1647 if ($name_printed) {
1648 eval qq/print " $init\\n"/;
1650 eval qq/print "\\t$var $init\\n"/;
1654 if ( $init =~ s/^\+// && $num ) {
1655 &generate_init($type, $num, $var, $name_printed);
1656 } elsif ($name_printed) {
1660 eval qq/print "\\t$var;\\n"/;
1664 $deferred .= eval qq/"\\n\\t$init\\n"/;
1671 # work out the line number
1672 my $line_no = $line_no[@line_no - @line -1] ;
1674 print STDERR "@_ in $filename, line $line_no\n" ;
1690 local($type, $num, $var) = @_;
1691 local($arg) = "ST(" . ($num - 1) . ")";
1692 local($argoff) = $num - 1;
1696 $type = TidyType($type) ;
1697 blurt("Error: '$type' not in typemap"), return
1698 unless defined($type_kind{$type});
1700 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1701 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1702 $tk = $type_kind{$type};
1703 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1704 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1705 print "\t$var" unless $name_printed;
1706 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1707 die "default value not supported with length(NAME) supplied"
1708 if defined $defaults{$var};
1711 $type =~ tr/:/_/ unless $hiertype;
1712 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1713 unless defined $input_expr{$tk} ;
1714 $expr = $input_expr{$tk};
1715 if ($expr =~ /DO_ARRAY_ELEM/) {
1716 blurt("Error: '$subtype' not in typemap"), return
1717 unless defined($type_kind{$subtype});
1718 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1719 unless defined $input_expr{$type_kind{$subtype}} ;
1720 $subexpr = $input_expr{$type_kind{$subtype}};
1721 $subexpr =~ s/\$type/\$subtype/g;
1722 $subexpr =~ s/ntype/subtype/g;
1723 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1724 $subexpr =~ s/\n\t/\n\t\t/g;
1725 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1726 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1727 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1729 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1732 if (defined($defaults{$var})) {
1733 $expr =~ s/(\t+)/$1 /g;
1735 if ($name_printed) {
1738 eval qq/print "\\t$var;\\n"/;
1741 if ($defaults{$var} eq 'NO_INIT') {
1742 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1744 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1747 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1748 if ($name_printed) {
1751 eval qq/print "\\t$var;\\n"/;
1754 $deferred .= eval qq/"\\n$expr;\\n"/;
1757 die "panic: do not know how to handle this branch for function pointers"
1759 eval qq/print "$expr;\\n"/;
1764 sub generate_output {
1765 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1766 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1767 local($argoff) = $num - 1;
1770 $type = TidyType($type) ;
1771 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1772 print "\t$arg = sv_newmortal();\n";
1773 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1774 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1776 blurt("Error: '$type' not in typemap"), return
1777 unless defined($type_kind{$type});
1778 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1779 unless defined $output_expr{$type_kind{$type}} ;
1780 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1781 $ntype =~ s/\(\)//g;
1782 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1783 $expr = $output_expr{$type_kind{$type}};
1784 if ($expr =~ /DO_ARRAY_ELEM/) {
1785 blurt("Error: '$subtype' not in typemap"), return
1786 unless defined($type_kind{$subtype});
1787 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1788 unless defined $output_expr{$type_kind{$subtype}} ;
1789 $subexpr = $output_expr{$type_kind{$subtype}};
1790 $subexpr =~ s/ntype/subtype/g;
1791 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1792 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1793 $subexpr =~ s/\n\t/\n\t\t/g;
1794 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1795 eval "print qq\a$expr\a";
1797 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1798 } elsif ($var eq 'RETVAL') {
1799 if ($expr =~ /^\t\$arg = new/) {
1800 # We expect that $arg has refcnt 1, so we need to
1802 eval "print qq\a$expr\a";
1804 print "\tsv_2mortal(ST($num));\n";
1805 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1806 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1807 # We expect that $arg has refcnt >=1, so we need
1809 eval "print qq\a$expr\a";
1811 print "\tsv_2mortal(ST(0));\n";
1812 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1814 # Just hope that the entry would safely write it
1815 # over an already mortalized value. By
1816 # coincidence, something like $arg = &sv_undef
1818 print "\tST(0) = sv_newmortal();\n";
1819 eval "print qq\a$expr\a";
1821 # new mortals don't have set magic
1823 } elsif ($do_push) {
1824 print "\tPUSHs(sv_newmortal());\n";
1826 eval "print qq\a$expr\a";
1828 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1829 } elsif ($arg =~ /^ST\(\d+\)$/) {
1830 eval "print qq\a$expr\a";
1832 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1838 my($type, $varname) = @_;
1840 # C++ has :: in types too so skip this
1841 $type =~ tr/:/_/ unless $hiertype;
1842 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1844 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1845 (substr $type, pos $type, 0) = " $varname ";
1847 $type .= "\t$varname";
1854 #########################################################
1856 ExtUtils::ParseXS::CountLines;
1858 use vars qw($SECTION_END_MARKER);
1861 my ($class, $cfile, $fh) = @_;
1862 $cfile =~ s/\\/\\\\/g;
1863 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1865 return bless {buffer => '',
1874 $self->{buffer} .= $_;
1875 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1877 ++ $self->{line_no};
1878 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1879 print {$self->{fh}} $line;
1887 $self->PRINT(sprintf($fmt, @_));
1891 # Not necessary if we're careful to end with a "\n"
1893 print {$self->{fh}} $self->{buffer};
1897 # This sub does nothing, but is neccessary for references to be released.
1901 return $SECTION_END_MARKER;
1910 ExtUtils::ParseXS - converts Perl XS code into C code
1914 use ExtUtils::ParseXS qw(process_file);
1916 process_file( filename => 'foo.xs' );
1918 process_file( filename => 'foo.xs',
1921 typemap => 'path/to/typemap',
1932 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1933 necessary to let C functions manipulate Perl values and creates the glue
1934 necessary to let Perl access those functions. The compiler uses typemaps to
1935 determine how to map C function parameters and variables to Perl values.
1937 The compiler will search for typemap files called I<typemap>. It will use
1938 the following search path to find default typemaps, with the rightmost
1939 typemap taking precedence.
1941 ../../../typemap:../../typemap:../typemap:typemap
1945 None by default. C<process_file()> may be exported upon request.
1954 This function processes an XS file and sends output to a C file.
1955 Named parameters control how the processing is done. The following
1956 parameters are accepted:
1962 Adds C<extern "C"> to the C code. Default is false.
1966 Retains C<::> in type names so that C++ hierachical types can be
1967 mapped. Default is false.
1971 Adds exception handling stubs to the C code. Default is false.
1975 Indicates that a user-supplied typemap should take precedence over the
1976 default typemaps. A single typemap may be specified as a string, or
1977 multiple typemaps can be specified in an array reference, with the
1978 last typemap having the highest precedence.
1982 Generates prototype code for all xsubs. Default is false.
1984 =item B<versioncheck>
1986 Makes sure at run time that the object file (derived from the C<.xs>
1987 file) and the C<.pm> files have the same version number. Default is
1990 =item B<linenumbers>
1992 Adds C<#line> directives to the C output so error messages will look
1993 like they came from the original XS file. Default is true.
1997 Enables certain optimizations. The only optimization that is currently
1998 affected is the use of I<target>s by the output C code (see L<perlguts>).
1999 Not optimizing may significantly slow down the generated code, but this is the way
2000 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2004 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2005 declarations. Default is true.
2009 Enable recognition of ANSI-like descriptions of function signature.
2014 I have no clue what this does. Strips function prefixes?
2020 This function returns the number of [a certain kind of] errors
2021 encountered during processing of the XS file.
2027 Based on xsubpp code, written by Larry Wall.
2029 Maintained by Ken Williams, <ken@mathforum.org>
2033 Copyright 2002-2003 Ken Williams. All rights reserved.
2035 This library is free software; you can redistribute it and/or
2036 modify it under the same terms as Perl itself.
2038 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2039 Porters, which was released under the same license terms.
2043 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.