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" ;
990 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
995 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1001 sub errors { $errors }
1003 sub standard_typemap_locations {
1004 # Add all the default typemap locations to the search path
1005 my @tm = qw(typemap);
1007 my $updir = File::Spec->updir;
1008 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1009 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1011 unshift @tm, File::Spec->catfile($dir, 'typemap');
1012 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1014 foreach my $dir (@INC) {
1015 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1016 unshift @tm, $file if -e $file;
1023 $_[0] =~ s/^\s+|\s+$//go ;
1030 # rationalise any '*' by joining them into bunches and removing whitespace
1034 # change multiple whitespace into a single space
1037 # trim leading & trailing whitespace
1038 TrimWhitespace($_) ;
1043 # Input: ($_, @line) == unparsed input.
1044 # Output: ($_, @line) == (rest of line, following lines).
1045 # Return: the matched keyword if found, otherwise 0
1047 $_ = shift(@line) while !/\S/ && @line;
1048 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1052 # the "do" is required for right semantics
1053 do { $_ = shift(@line) } while !/\S/ && @line;
1055 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1056 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1057 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1060 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1066 while (!/\S/ && @line) {
1070 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1077 sub process_keyword($)
1082 &{"${kwd}_handler"}()
1083 while $kwd = check_keyword($pattern) ;
1087 blurt ("Error: `CASE:' after unconditional `CASE:'")
1088 if $condnum && $cond eq '';
1090 TrimWhitespace($cond);
1091 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1096 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1097 last if /^\s*NOT_IMPLEMENTED_YET/;
1098 next unless /\S/; # skip blank lines
1100 TrimWhitespace($_) ;
1103 # remove trailing semicolon if no initialisation
1104 s/\s*;$//g unless /[=;+].*\S/ ;
1106 # Process the length(foo) declarations
1107 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1108 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1109 $lengthof{$2} = $name;
1110 # $islengthof{$name} = $1;
1111 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1114 # check for optional initialisation code
1116 $var_init = $1 if s/\s*([=;+].*)$//s ;
1117 $var_init =~ s/"/\\"/g;
1120 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1121 or blurt("Error: invalid argument declaration '$line'"), next;
1123 # Check for duplicate definitions
1124 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1125 if $arg_list{$var_name}++
1126 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1128 $thisdone |= $var_name eq "THIS";
1129 $retvaldone |= $var_name eq "RETVAL";
1130 $var_types{$var_name} = $var_type;
1131 # XXXX This check is a safeguard against the unfinished conversion of
1132 # generate_init(). When generate_init() is fixed,
1133 # one can use 2-args map_type() unconditionally.
1134 if ($var_type =~ / \( \s* \* \s* \) /x) {
1135 # Function pointers are not yet supported with &output_init!
1136 print "\t" . &map_type($var_type, $var_name);
1139 print "\t" . &map_type($var_type);
1142 $var_num = $args_match{$var_name};
1144 $proto_arg[$var_num] = ProtoString($var_type)
1146 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1147 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1148 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1149 and $var_init !~ /\S/) {
1150 if ($name_printed) {
1153 print "\t$var_name;\n";
1155 } elsif ($var_init =~ /\S/) {
1156 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1157 } elsif ($var_num) {
1158 # generate initialization code
1159 &generate_init($var_type, $var_num, $var_name, $name_printed);
1166 sub OUTPUT_handler {
1167 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1169 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1170 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1173 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1174 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1175 if $outargs{$outarg} ++ ;
1176 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1177 # deal with RETVAL last
1178 $RETVAL_code = $outcode ;
1182 blurt ("Error: OUTPUT $outarg not an argument"), next
1183 unless defined($args_match{$outarg});
1184 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1185 unless defined $var_types{$outarg} ;
1186 $var_num = $args_match{$outarg};
1188 print "\t$outcode\n";
1189 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1191 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1193 delete $in_out{$outarg} # No need to auto-OUTPUT
1194 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1198 sub C_ARGS_handler() {
1199 my $in = merge_section();
1201 TrimWhitespace($in);
1205 sub INTERFACE_MACRO_handler() {
1206 my $in = merge_section();
1208 TrimWhitespace($in);
1209 if ($in =~ /\s/) { # two
1210 ($interface_macro, $interface_macro_set) = split ' ', $in;
1212 $interface_macro = $in;
1213 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1215 $interface = 1; # local
1216 $Interfaces = 1; # global
1219 sub INTERFACE_handler() {
1220 my $in = merge_section();
1222 TrimWhitespace($in);
1224 foreach (split /[\s,]+/, $in) {
1226 $name =~ s/^$Prefix//;
1227 $Interfaces{$name} = $_;
1230 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1232 $interface = 1; # local
1233 $Interfaces = 1; # global
1236 sub CLEANUP_handler() { print_section() }
1237 sub PREINIT_handler() { print_section() }
1238 sub POSTCALL_handler() { print_section() }
1239 sub INIT_handler() { print_section() }
1244 my ($orig) = $line ;
1248 # Parse alias definitions
1250 # alias = value alias = value ...
1252 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1254 $orig_alias = $alias ;
1257 # check for optional package definition in the alias
1258 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1260 # check for duplicate alias name & duplicate value
1261 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1262 if defined $XsubAliases{$alias} ;
1264 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1265 if $XsubAliasValues{$value} ;
1268 $XsubAliases{$alias} = $value ;
1269 $XsubAliasValues{$value} = $orig_alias ;
1272 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1276 sub ATTRS_handler ()
1278 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1280 TrimWhitespace($_) ;
1281 push @Attributes, $_;
1285 sub ALIAS_handler ()
1287 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1289 TrimWhitespace($_) ;
1290 GetAliases($_) if $_ ;
1294 sub OVERLOAD_handler()
1296 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1298 TrimWhitespace($_) ;
1299 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1300 $Overload = 1 unless $Overload;
1301 my $overload = "$Package\::(".$1 ;
1303 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1308 sub FALLBACK_handler()
1310 # the rest of the current line should contain either TRUE,
1313 TrimWhitespace($_) ;
1315 TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
1316 FALSE => "PL_sv_no", 0 => "PL_sv_no",
1317 UNDEF => "PL_sv_undef",
1320 # check for valid FALLBACK value
1321 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1323 $Fallback = $map{uc $_} ;
1327 sub REQUIRE_handler ()
1329 # the rest of the current line should contain a version number
1332 TrimWhitespace($Ver) ;
1334 death ("Error: REQUIRE expects a version number")
1337 # check that the version number is of the form n.n
1338 death ("Error: REQUIRE: expected a number, got '$Ver'")
1339 unless $Ver =~ /^\d+(\.\d*)?/ ;
1341 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1342 unless $VERSION >= $Ver ;
1345 sub VERSIONCHECK_handler ()
1347 # the rest of the current line should contain either ENABLE or
1350 TrimWhitespace($_) ;
1352 # check for ENABLE/DISABLE
1353 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1354 unless /^(ENABLE|DISABLE)/i ;
1356 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1357 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1361 sub PROTOTYPE_handler ()
1365 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1366 if $proto_in_this_xsub ++ ;
1368 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1371 TrimWhitespace($_) ;
1372 if ($_ eq 'DISABLE') {
1374 } elsif ($_ eq 'ENABLE') {
1377 # remove any whitespace
1379 death("Error: Invalid prototype '$_'")
1380 unless ValidProtoString($_) ;
1381 $ProtoThisXSUB = C_string($_) ;
1385 # If no prototype specified, then assume empty prototype ""
1386 $ProtoThisXSUB = 2 unless $specified ;
1392 sub SCOPE_handler ()
1394 death("Error: Only 1 SCOPE declaration allowed per xsub")
1395 if $scope_in_this_xsub ++ ;
1397 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1399 TrimWhitespace($_) ;
1400 if ($_ =~ /^DISABLE/i) {
1402 } elsif ($_ =~ /^ENABLE/i) {
1409 sub PROTOTYPES_handler ()
1411 # the rest of the current line should contain either ENABLE or
1414 TrimWhitespace($_) ;
1416 # check for ENABLE/DISABLE
1417 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1418 unless /^(ENABLE|DISABLE)/i ;
1420 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1421 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1426 sub INCLUDE_handler ()
1428 # the rest of the current line should contain a valid filename
1430 TrimWhitespace($_) ;
1432 death("INCLUDE: filename missing")
1435 death("INCLUDE: output pipe is illegal")
1438 # simple minded recursion detector
1439 death("INCLUDE loop detected")
1440 if $IncludedFiles{$_} ;
1442 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1444 # Save the current file context.
1447 LastLine => $lastline,
1448 LastLineNo => $lastline_no,
1450 LineNo => \@line_no,
1451 Filename => $filename,
1452 Filepathname => $filepathname,
1456 $FH = Symbol::gensym();
1459 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1463 #/* INCLUDE: Including '$_' from '$filename' */
1467 $filepathname = $filename = $_ ;
1469 # Prime the pump by reading the first
1472 # skip leading blank lines
1474 last unless /^\s*$/ ;
1484 return 0 unless $XSStack[-1]{type} eq 'file' ;
1486 my $data = pop @XSStack ;
1487 my $ThisFile = $filename ;
1488 my $isPipe = ($filename =~ /\|\s*$/) ;
1490 -- $IncludedFiles{$filename}
1495 $FH = $data->{Handle} ;
1496 # $filename is the leafname, which for some reason isused for diagnostic
1497 # messages, whereas $filepathname is the full pathname, and is used for
1499 $filename = $data->{Filename} ;
1500 $filepathname = $data->{Filepathname} ;
1501 $lastline = $data->{LastLine} ;
1502 $lastline_no = $data->{LastLineNo} ;
1503 @line = @{ $data->{Line} } ;
1504 @line_no = @{ $data->{LineNo} } ;
1506 if ($isPipe and $? ) {
1508 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1514 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1521 sub ValidProtoString ($)
1525 if ( $string =~ /^$proto_re+$/ ) {
1536 $string =~ s[\\][\\\\]g ;
1544 $proto_letter{$type} or "\$" ;
1548 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1550 my ($cpp, $cpplevel);
1552 if ($cpp =~ /^\#\s*if/) {
1554 } elsif (!$cpplevel) {
1555 Warn("Warning: #else/elif/endif without #if in this function");
1556 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1557 if $XSStack[-1]{type} eq 'if';
1559 } elsif ($cpp =~ /^\#\s*endif/) {
1563 Warn("Warning: #if without #endif in this function") if $cpplevel;
1571 $text =~ s/\[\[/{/g;
1572 $text =~ s/\]\]/}/g;
1576 # Read next xsub into @line from ($lastline, <$FH>).
1579 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1580 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1583 return PopFile() if !defined $lastline;
1586 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1588 $Package = defined($2) ? $2 : ''; # keep -w happy
1589 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1590 $Prefix = quotemeta $Prefix ;
1591 ($Module_cname = $Module) =~ s/\W/_/g;
1592 ($Packid = $Package) =~ tr/:/_/;
1593 $Packprefix = $Package;
1594 $Packprefix .= "::" if $Packprefix ne "";
1599 # Skip embedded PODs
1600 while ($lastline =~ /^=/) {
1601 while ($lastline = <$FH>) {
1602 last if ($lastline =~ /^=cut\s*$/);
1604 death ("Error: Unterminated pod") unless $lastline;
1607 $lastline =~ s/^\s+$//;
1609 if ($lastline !~ /^\s*#/ ||
1611 # ANSI: if ifdef ifndef elif else endif define undef
1613 # gcc: warning include_next
1615 # others: ident (gcc notes that some cpps have this one)
1616 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1617 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1618 push(@line, $lastline);
1619 push(@line_no, $lastline_no) ;
1622 # Read next line and continuation lines
1623 last unless defined($lastline = <$FH>);
1626 $lastline .= $tmp_line
1627 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1630 $lastline =~ s/^\s+$//;
1632 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1637 local($type, $num, $var, $init, $name_printed) = @_;
1638 local($arg) = "ST(" . ($num - 1) . ")";
1640 if ( $init =~ /^=/ ) {
1641 if ($name_printed) {
1642 eval qq/print " $init\\n"/;
1644 eval qq/print "\\t$var $init\\n"/;
1648 if ( $init =~ s/^\+// && $num ) {
1649 &generate_init($type, $num, $var, $name_printed);
1650 } elsif ($name_printed) {
1654 eval qq/print "\\t$var;\\n"/;
1658 $deferred .= eval qq/"\\n\\t$init\\n"/;
1665 # work out the line number
1666 my $line_no = $line_no[@line_no - @line -1] ;
1668 print STDERR "@_ in $filename, line $line_no\n" ;
1684 local($type, $num, $var) = @_;
1685 local($arg) = "ST(" . ($num - 1) . ")";
1686 local($argoff) = $num - 1;
1690 $type = TidyType($type) ;
1691 blurt("Error: '$type' not in typemap"), return
1692 unless defined($type_kind{$type});
1694 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1695 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1696 $tk = $type_kind{$type};
1697 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1698 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1699 print "\t$var" unless $name_printed;
1700 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1701 die "default value not supported with length(NAME) supplied"
1702 if defined $defaults{$var};
1705 $type =~ tr/:/_/ unless $hiertype;
1706 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1707 unless defined $input_expr{$tk} ;
1708 $expr = $input_expr{$tk};
1709 if ($expr =~ /DO_ARRAY_ELEM/) {
1710 blurt("Error: '$subtype' not in typemap"), return
1711 unless defined($type_kind{$subtype});
1712 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1713 unless defined $input_expr{$type_kind{$subtype}} ;
1714 $subexpr = $input_expr{$type_kind{$subtype}};
1715 $subexpr =~ s/\$type/\$subtype/g;
1716 $subexpr =~ s/ntype/subtype/g;
1717 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1718 $subexpr =~ s/\n\t/\n\t\t/g;
1719 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1720 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1721 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1723 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1726 if (defined($defaults{$var})) {
1727 $expr =~ s/(\t+)/$1 /g;
1729 if ($name_printed) {
1732 eval qq/print "\\t$var;\\n"/;
1735 if ($defaults{$var} eq 'NO_INIT') {
1736 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1738 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1741 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1742 if ($name_printed) {
1745 eval qq/print "\\t$var;\\n"/;
1748 $deferred .= eval qq/"\\n$expr;\\n"/;
1751 die "panic: do not know how to handle this branch for function pointers"
1753 eval qq/print "$expr;\\n"/;
1758 sub generate_output {
1759 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1760 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1761 local($argoff) = $num - 1;
1764 $type = TidyType($type) ;
1765 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1766 print "\t$arg = sv_newmortal();\n";
1767 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1768 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1770 blurt("Error: '$type' not in typemap"), return
1771 unless defined($type_kind{$type});
1772 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1773 unless defined $output_expr{$type_kind{$type}} ;
1774 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1775 $ntype =~ s/\(\)//g;
1776 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1777 $expr = $output_expr{$type_kind{$type}};
1778 if ($expr =~ /DO_ARRAY_ELEM/) {
1779 blurt("Error: '$subtype' not in typemap"), return
1780 unless defined($type_kind{$subtype});
1781 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1782 unless defined $output_expr{$type_kind{$subtype}} ;
1783 $subexpr = $output_expr{$type_kind{$subtype}};
1784 $subexpr =~ s/ntype/subtype/g;
1785 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1786 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1787 $subexpr =~ s/\n\t/\n\t\t/g;
1788 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1789 eval "print qq\a$expr\a";
1791 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1792 } elsif ($var eq 'RETVAL') {
1793 if ($expr =~ /^\t\$arg = new/) {
1794 # We expect that $arg has refcnt 1, so we need to
1796 eval "print qq\a$expr\a";
1798 print "\tsv_2mortal(ST($num));\n";
1799 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1800 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1801 # We expect that $arg has refcnt >=1, so we need
1803 eval "print qq\a$expr\a";
1805 print "\tsv_2mortal(ST(0));\n";
1806 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1808 # Just hope that the entry would safely write it
1809 # over an already mortalized value. By
1810 # coincidence, something like $arg = &sv_undef
1812 print "\tST(0) = sv_newmortal();\n";
1813 eval "print qq\a$expr\a";
1815 # new mortals don't have set magic
1817 } elsif ($do_push) {
1818 print "\tPUSHs(sv_newmortal());\n";
1820 eval "print qq\a$expr\a";
1822 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1823 } elsif ($arg =~ /^ST\(\d+\)$/) {
1824 eval "print qq\a$expr\a";
1826 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1832 my($type, $varname) = @_;
1834 # C++ has :: in types too so skip this
1835 $type =~ tr/:/_/ unless $hiertype;
1836 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1838 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1839 (substr $type, pos $type, 0) = " $varname ";
1841 $type .= "\t$varname";
1848 #########################################################
1850 ExtUtils::ParseXS::CountLines;
1852 use vars qw($SECTION_END_MARKER);
1855 my ($class, $cfile, $fh) = @_;
1856 $cfile =~ s/\\/\\\\/g;
1857 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1859 return bless {buffer => '',
1868 $self->{buffer} .= $_;
1869 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1871 ++ $self->{line_no};
1872 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1873 print {$self->{fh}} $line;
1881 $self->PRINT(sprintf($fmt, @_));
1885 # Not necessary if we're careful to end with a "\n"
1887 print {$self->{fh}} $self->{buffer};
1891 # This sub does nothing, but is neccessary for references to be released.
1895 return $SECTION_END_MARKER;
1904 ExtUtils::ParseXS - converts Perl XS code into C code
1908 use ExtUtils::ParseXS qw(process_file);
1910 process_file( filename => 'foo.xs' );
1912 process_file( filename => 'foo.xs',
1915 typemap => 'path/to/typemap',
1926 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1927 necessary to let C functions manipulate Perl values and creates the glue
1928 necessary to let Perl access those functions. The compiler uses typemaps to
1929 determine how to map C function parameters and variables to Perl values.
1931 The compiler will search for typemap files called I<typemap>. It will use
1932 the following search path to find default typemaps, with the rightmost
1933 typemap taking precedence.
1935 ../../../typemap:../../typemap:../typemap:typemap
1939 None by default. C<process_file()> may be exported upon request.
1948 This function processes an XS file and sends output to a C file.
1949 Named parameters control how the processing is done. The following
1950 parameters are accepted:
1956 Adds C<extern "C"> to the C code. Default is false.
1960 Retains C<::> in type names so that C++ hierachical types can be
1961 mapped. Default is false.
1965 Adds exception handling stubs to the C code. Default is false.
1969 Indicates that a user-supplied typemap should take precedence over the
1970 default typemaps. A single typemap may be specified as a string, or
1971 multiple typemaps can be specified in an array reference, with the
1972 last typemap having the highest precedence.
1976 Generates prototype code for all xsubs. Default is false.
1978 =item B<versioncheck>
1980 Makes sure at run time that the object file (derived from the C<.xs>
1981 file) and the C<.pm> files have the same version number. Default is
1984 =item B<linenumbers>
1986 Adds C<#line> directives to the C output so error messages will look
1987 like they came from the original XS file. Default is true.
1991 Enables certain optimizations. The only optimization that is currently
1992 affected is the use of I<target>s by the output C code (see L<perlguts>).
1993 Not optimizing may significantly slow down the generated code, but this is the way
1994 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
1998 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
1999 declarations. Default is true.
2003 Enable recognition of ANSI-like descriptions of function signature.
2008 I have no clue what this does. Strips function prefixes?
2014 This function returns the number of [a certain kind of] errors
2015 encountered during processing of the XS file.
2021 Based on xsubpp code, written by Larry Wall.
2023 Maintained by Ken Williams, <ken@mathforum.org>
2027 Copyright 2002-2003 Ken Williams. All rights reserved.
2029 This library is free software; you can redistribute it and/or
2030 modify it under the same terms as Perl itself.
2032 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2033 Porters, which was released under the same license terms.
2037 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.