1 package ExtUtils::ParseXS;
3 use 5.006; # We use /??{}/ in regexes
13 @EXPORT_OK = qw(process_file);
15 # use strict; # One of these days...
17 my(@XSStack); # Stack of conditionals and INCLUDEs
18 my($XSS_work_idx, $cpp_next_tmp);
20 use vars qw($VERSION);
23 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
24 $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
25 $WantOptimize $process_inout $process_argtypes @tm
26 $dir $filename $filepathname %IncludedFiles
27 %type_kind %proto_letter
28 %targetable $BLOCK_re $lastline $lastline_no
29 $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
30 $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
31 $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
32 $ProtoThisXSUB $ScopeThisXSUB $xsreturn
33 @line_no $ret_type $func_header $orig_args
34 ); # Add these just to get compilation to happen.
39 # Allow for $package->process_file(%hash) in the future
40 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
42 $ProtoUsed = exists $args{prototypes};
46 # 'C++' => 0, # Doesn't seem to *do* anything...
64 my ($Is_VMS, $SymSet);
67 # Establish set of global symbols with max length 28, since xsubpp
68 # will later add the 'XS_' prefix.
69 require ExtUtils::XSSymSet;
70 $SymSet = new ExtUtils::XSSymSet 28;
72 @XSStack = ({type => 'none'});
73 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
75 $FH = Symbol::gensym();
76 $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
79 $Fallback = '&PL_sv_undef';
81 # Most of the 1500 lines below uses these globals. We'll have to
82 # clean this up sometime, probably. For now, we just pull them out
85 $cplusplus = $args{'C++'};
86 $hiertype = $args{hiertype};
87 $WantPrototypes = $args{prototypes};
88 $WantVersionChk = $args{versioncheck};
89 $except = $args{except} ? ' TRY' : '';
90 $WantLineNumbers = $args{linenumbers};
91 $WantOptimize = $args{optimize};
92 $process_inout = $args{inout};
93 $process_argtypes = $args{argtypes};
94 @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
96 for ($args{filename}) {
97 die "Missing required parameter 'filename'" unless $_;
99 ($dir, $filename) = (dirname($_), basename($_));
100 $filepathname =~ s/\\/\\\\/g;
101 $IncludedFiles{$_}++;
104 # Open the input file
105 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
107 # Open the output file if given as a string. If they provide some
108 # other kind of reference, trust them that we can print to it.
109 if (not ref $args{output}) {
110 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
111 $args{outfile} = $args{output};
115 # Really, we shouldn't have to chdir() or select() in the first
116 # place. For now, just save & restore.
117 my $orig_cwd = cwd();
118 my $orig_fh = select();
122 my $csuffix = $args{csuffix};
124 if ($WantLineNumbers) {
126 if ( $args{outfile} ) {
127 $cfile = $args{outfile};
129 $cfile = $args{filename};
130 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
132 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
133 select PSEUDO_STDOUT;
135 select $args{output};
138 foreach my $typemap (@tm) {
139 die "Can't find $typemap in $pwd\n" unless -r $typemap;
142 push @tm, standard_typemap_locations();
144 foreach my $typemap (@tm) {
145 next unless -f $typemap ;
146 # skip directories, binary files etc.
147 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
149 open(TYPEMAP, $typemap)
150 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
151 my $mode = 'Typemap';
153 my $current = \$junk;
156 my $line_no = $. + 1;
158 $mode = 'Input'; $current = \$junk; next;
161 $mode = 'Output'; $current = \$junk; next;
163 if (/^TYPEMAP\s*$/) {
164 $mode = 'Typemap'; $current = \$junk; next;
166 if ($mode eq 'Typemap') {
170 # skip blank lines and comment lines
171 next if /^$/ or /^#/ ;
172 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
173 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
174 $type = TidyType($type) ;
175 $type_kind{$type} = $kind ;
176 # prototype defaults to '$'
177 $proto = "\$" unless $proto ;
178 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
179 unless ValidProtoString($proto) ;
180 $proto_letter{$type} = C_string($proto) ;
183 } elsif ($mode eq 'Input') {
185 $input_expr{$_} = '';
186 $current = \$input_expr{$_};
189 $output_expr{$_} = '';
190 $current = \$output_expr{$_};
196 foreach my $value (values %input_expr) {
197 $value =~ s/;*\s+\z//;
198 # Move C pre-processor instructions to column 1 to be strictly ANSI
199 # conformant. Some pre-processors are fussy about this.
200 $value =~ s/^\s+#/#/mg;
202 foreach my $value (values %output_expr) {
204 $value =~ s/^\s+#/#/mg;
208 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
209 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
210 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
212 foreach my $key (keys %output_expr) {
213 BEGIN { $^H |= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs
215 my ($t, $with_size, $arg, $sarg) =
216 ($output_expr{$key} =~
217 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
218 \s* \( \s* $cast \$arg \s* ,
219 \s* ( (??{ $bal }) ) # Set from
220 ( (??{ $size }) )? # Possible sizeof set-from
223 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
226 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
228 # Match an XS keyword
229 $BLOCK_re= '\s*(' . join('|', qw(
230 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
231 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
232 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
236 our ($C_group_rex, $C_arg);
237 # Group in C (no support for comments or literals)
238 $C_group_rex = qr/ [({\[]
239 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
241 # Chunk in C without comma at toplevel (no comments):
242 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
243 | (??{ $C_group_rex })
244 | " (?: (?> [^\\"]+ )
246 )* " # String literal
247 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
250 # Identify the version of xsubpp used
253 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
254 * contents of $filename. Do not edit this file, edit $filename instead.
256 * ANY CHANGES MADE HERE WILL BE LOST!
263 print("#line 1 \"$filepathname\"\n")
269 my $podstartline = $.;
272 # We can't just write out a /* */ comment, as our embedded
273 # POD might itself be in a comment. We can't put a /**/
274 # comment inside #if 0, as the C standard says that the source
275 # file is decomposed into preprocessing characters in the stage
276 # before preprocessing commands are executed.
277 # I don't want to leave the text as barewords, because the spec
278 # isn't clear whether macros are expanded before or after
279 # preprocessing commands are executed, and someone pathological
280 # may just have defined one of the 3 words as a macro that does
281 # something strange. Multiline strings are illegal in C, so
282 # the "" we write must be a string literal. And they aren't
283 # concatenated until 2 steps later, so we are safe.
285 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
286 printf("#line %d \"$filepathname\"\n", $. + 1)
292 # At this point $. is at end of file so die won't state the start
293 # of the problem, and as we haven't yet read any lines &death won't
294 # show the correct line in the message either.
295 die ("Error: Unterminated pod in $filename, line $podstartline\n")
298 last if ($Package, $Prefix) =
299 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
303 unless (defined $_) {
304 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
305 exit 0; # Not a fatal error for the caller process
309 #ifndef PERL_UNUSED_VAR
310 # define PERL_UNUSED_VAR(var) if (0) var = var
315 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
321 while (fetch_para()) {
322 # Print initial preprocessor statements and blank lines
323 while (@line && $line[0] !~ /^[^\#]/) {
324 my $line = shift(@line);
326 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
328 if ($statement eq 'if') {
329 $XSS_work_idx = @XSStack;
330 push(@XSStack, {type => 'if'});
332 death ("Error: `$statement' with no matching `if'")
333 if $XSStack[-1]{type} ne 'if';
334 if ($XSStack[-1]{varname}) {
335 push(@InitFileCode, "#endif\n");
336 push(@BootCode, "#endif");
339 my(@fns) = keys %{$XSStack[-1]{functions}};
340 if ($statement ne 'endif') {
341 # Hide the functions defined in other #if branches, and reset.
342 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
343 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
345 my($tmp) = pop(@XSStack);
346 0 while (--$XSS_work_idx
347 && $XSStack[$XSS_work_idx]{type} ne 'if');
348 # Keep all new defined functions
349 push(@fns, keys %{$tmp->{other_functions}});
350 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
355 next PARAGRAPH unless @line;
357 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
358 # We are inside an #if, but have not yet #defined its xsubpp variable.
359 print "#define $cpp_next_tmp 1\n\n";
360 push(@InitFileCode, "#if $cpp_next_tmp\n");
361 push(@BootCode, "#if $cpp_next_tmp");
362 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
365 death ("Code is not inside a function"
366 ." (maybe last function was ended by a blank line "
367 ." followed by a statement on column one?)")
368 if $line[0] =~ /^\s/;
370 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
371 my (@fake_INPUT_pre); # For length(s) generated variables
374 # initialize info arrays
380 undef($processing_arg_with_types) ;
381 undef(%argtype_seen) ;
385 undef($proto_in_this_xsub) ;
386 undef($scope_in_this_xsub) ;
388 undef($prepush_done);
389 $interface_macro = 'XSINTERFACE_FUNC' ;
390 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
391 $ProtoThisXSUB = $WantPrototypes ;
396 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
397 &{"${kwd}_handler"}() ;
398 next PARAGRAPH unless @line ;
402 if (check_keyword("BOOT")) {
404 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
405 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
406 push (@BootCode, @line, "") ;
411 # extract return type, function name and arguments
412 ($ret_type) = TidyType($_);
413 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
415 # Allow one-line ANSI-like declaration
418 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
420 # a function definition needs at least 2 lines
421 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
424 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
425 $static = 1 if $ret_type =~ s/^static\s+//;
427 $func_header = shift(@line);
428 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
429 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
431 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
432 $class = "$4 $class" if $4;
433 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
434 ($clean_func_name = $func_name) =~ s/^$Prefix//;
435 $Full_func_name = "${Packid}_$clean_func_name";
437 $Full_func_name = $SymSet->addsym($Full_func_name);
440 # Check for duplicate function definition
441 for my $tmp (@XSStack) {
442 next unless defined $tmp->{functions}{$Full_func_name};
443 Warn("Warning: duplicate function definition '$clean_func_name' detected");
446 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
447 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
450 $orig_args =~ s/\\\s*/ /g; # process line continuations
453 my %only_C_inlist; # Not in the signature of Perl function
454 if ($process_argtypes and $orig_args =~ /\S/) {
455 my $args = "$orig_args ,";
456 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
457 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
461 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
462 my ($pre, $name) = ($arg =~ /(.*?) \s*
463 \b ( \w+ | length\( \s*\w+\s* \) )
465 next unless defined($pre) && length($pre);
468 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
470 $out_type = $type if $type ne 'IN';
471 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
472 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
475 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
476 $name = "XSauto_length_of_$1";
478 die "Default value on length() argument: `$_'"
481 if (length $pre or $islength) { # Has a type
483 push @fake_INPUT_pre, $arg;
485 push @fake_INPUT, $arg;
487 # warn "pushing '$arg'\n";
488 $argtype_seen{$name}++;
489 $_ = "$name$default"; # Assigns to @args
491 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
492 push @outlist, $name if $out_type =~ /OUTLIST$/;
493 $in_out{$name} = $out_type if $out_type;
496 @args = split(/\s*,\s*/, $orig_args);
497 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
500 @args = split(/\s*,\s*/, $orig_args);
502 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
504 next if $out_type eq 'IN';
505 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
506 push @outlist, $name if $out_type =~ /OUTLIST$/;
507 $in_out{$_} = $out_type;
511 if (defined($class)) {
512 my $arg0 = ((defined($static) or $func_name eq 'new')
514 unshift(@args, $arg0);
515 ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
520 my $report_args = '';
521 foreach my $i (0 .. $#args) {
522 if ($args[$i] =~ s/\.\.\.//) {
524 if ($args[$i] eq '' && $i == $#args) {
525 $report_args .= ", ...";
530 if ($only_C_inlist{$args[$i]}) {
531 push @args_num, undef;
533 push @args_num, ++$num_args;
534 $report_args .= ", $args[$i]";
536 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
539 $defaults{$args[$i]} = $2;
540 $defaults{$args[$i]} =~ s/"/\\"/g;
542 $proto_arg[$i+1] = '$' ;
544 $min_args = $num_args - $extra_args;
545 $report_args =~ s/"/\\"/g;
546 $report_args =~ s/^,\s+//;
547 my @func_args = @args;
548 shift @func_args if defined($class);
551 s/^/&/ if $in_out{$_};
553 $func_args = join(", ", @func_args);
554 @args_match{@args} = @args_num;
556 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
557 $CODE = grep(/^\s*CODE\s*:/, @line);
558 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
559 # to set explicit return values.
560 $EXPLICIT_RETURN = ($CODE &&
561 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
562 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
563 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
565 $xsreturn = 1 if $EXPLICIT_RETURN;
567 $externC = $externC ? qq[extern "C"] : "";
569 # print function header
572 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
573 #XS(XS_${Full_func_name})
581 print Q(<<"EOF") if $ALIAS ;
584 print Q(<<"EOF") if $INTERFACE ;
585 # dXSFUNCTION($ret_type);
588 $cond = ($min_args ? qq(items < $min_args) : 0);
589 } elsif ($min_args == $num_args) {
590 $cond = qq(items != $min_args);
592 $cond = qq(items < $min_args || items > $num_args);
595 print Q(<<"EOF") if $except;
601 { print Q(<<"EOF") if $cond }
603 # Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "$report_args");
606 { print Q(<<"EOF") if $cond }
608 # Perl_croak(aTHX_ "Usage: %s(%s)", "$pname", "$report_args");
611 # cv doesn't seem to be used, in most cases unless we go in
612 # the if of this else
614 # PERL_UNUSED_VAR(cv); /* -W */
617 #gcc -Wall: if an xsub has PPCODE is used
618 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
619 #hence `ax' (setup by dXSARGS) is unused
620 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
621 #but such a move could break third-party extensions
622 print Q(<<"EOF") if $PPCODE;
623 # PERL_UNUSED_VAR(ax); /* -Wall */
626 print Q(<<"EOF") if $PPCODE;
630 # Now do a block of some sort.
633 $cond = ''; # last CASE: condidional
634 push(@line, "$END:");
635 push(@line_no, $line_no[-1]);
639 &CASE_handler if check_keyword("CASE");
644 # do initialization of input variables
652 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
654 print Q(<<"EOF") if $ScopeThisXSUB;
659 if (!$thisdone && defined($class)) {
660 if (defined($static) or $func_name eq 'new') {
662 $var_types{"CLASS"} = "char *";
663 &generate_init("char *", 1, "CLASS");
667 $var_types{"THIS"} = "$class *";
668 &generate_init("$class *", 1, "THIS");
673 if (/^\s*NOT_IMPLEMENTED_YET/) {
674 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
677 if ($ret_type ne "void") {
678 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
680 $args_match{"RETVAL"} = 0;
681 $var_types{"RETVAL"} = $ret_type;
683 if $WantOptimize and $targetable{$type_kind{$ret_type}};
686 if (@fake_INPUT or @fake_INPUT_pre) {
687 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
689 $processing_arg_with_types = 1;
694 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
696 if (check_keyword("PPCODE")) {
698 death ("PPCODE must be last thing") if @line;
699 print "\tLEAVE;\n" if $ScopeThisXSUB;
700 print "\tPUTBACK;\n\treturn;\n";
701 } elsif (check_keyword("CODE")) {
703 } elsif (defined($class) and $func_name eq "DESTROY") {
705 print "delete THIS;\n";
708 if ($ret_type ne "void") {
712 if (defined($static)) {
713 if ($func_name eq 'new') {
714 $func_name = "$class";
718 } elsif (defined($class)) {
719 if ($func_name eq 'new') {
720 $func_name .= " $class";
725 $func_name =~ s/^\Q$args{'s'}//
726 if exists $args{'s'};
727 $func_name = 'XSFUNCTION' if $interface;
728 print "$func_name($func_args);\n";
732 # do output variables
733 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
734 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
735 # $wantRETVAL set if 'RETVAL =' autogenerated
736 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
738 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
740 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
741 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
743 # all OUTPUT done, so now push the return value on the stack
744 if ($gotRETVAL && $RETVAL_code) {
745 print "\t$RETVAL_code\n";
746 } elsif ($gotRETVAL || $wantRETVAL) {
747 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
749 my $type = $ret_type;
751 # 0: type, 1: with_size, 2: how, 3: how_size
752 if ($t and not $t->[1] and $t->[0] eq 'p') {
753 # PUSHp corresponds to setpvn. Treate setpv directly
754 my $what = eval qq("$t->[2]");
757 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
761 my $what = eval qq("$t->[2]");
765 $size = '' unless defined $size;
766 $size = eval qq("$size");
768 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
772 # RETVAL almost never needs SvSETMAGIC()
773 &generate_output($ret_type, 0, 'RETVAL', 0);
777 $xsreturn = 1 if $ret_type ne "void";
780 print "\tXSprePUSH;" if $c and not $prepush_done;
781 print "\tEXTEND(SP,$c);\n" if $c;
783 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
786 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
788 print Q(<<"EOF") if $ScopeThisXSUB;
791 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
795 # print function trailer
799 print Q(<<"EOF") if $except;
802 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
805 if (check_keyword("CASE")) {
806 blurt ("Error: No `CASE:' at top of function")
808 $_ = "CASE: $_"; # Restore CASE: label
811 last if $_ eq "$END:";
812 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
815 print Q(<<"EOF") if $except;
817 # Perl_croak(aTHX_ errbuf);
821 print Q(<<"EOF") unless $PPCODE;
822 # XSRETURN($xsreturn);
825 print Q(<<"EOF") unless $PPCODE;
835 my $newXS = "newXS" ;
838 # Build the prototype string for the xsub
839 if ($ProtoThisXSUB) {
840 $newXS = "newXSproto";
842 if ($ProtoThisXSUB eq 2) {
843 # User has specified empty prototype
845 elsif ($ProtoThisXSUB eq 1) {
847 if ($min_args < $num_args) {
849 $proto_arg[$min_args] .= ";" ;
851 push @proto_arg, "$s\@"
854 $proto = join ("", grep defined, @proto_arg);
857 # User has specified a prototype
858 $proto = $ProtoThisXSUB;
860 $proto = qq{, "$proto"};
864 $XsubAliases{$pname} = 0
865 unless defined $XsubAliases{$pname} ;
866 while ( ($name, $value) = each %XsubAliases) {
867 push(@InitFileCode, Q(<<"EOF"));
868 # cv = newXS(\"$name\", XS_$Full_func_name, file);
869 # XSANY.any_i32 = $value ;
871 push(@InitFileCode, Q(<<"EOF")) if $proto;
872 # sv_setpv((SV*)cv$proto) ;
876 elsif (@Attributes) {
877 push(@InitFileCode, Q(<<"EOF"));
878 # cv = newXS(\"$pname\", XS_$Full_func_name, file);
879 # apply_attrs_string("$Package", cv, "@Attributes", 0);
883 while ( ($name, $value) = each %Interfaces) {
884 $name = "$Package\::$name" unless $name =~ /::/;
885 push(@InitFileCode, Q(<<"EOF"));
886 # cv = newXS(\"$name\", XS_$Full_func_name, file);
887 # $interface_macro_set(cv,$value) ;
889 push(@InitFileCode, Q(<<"EOF")) if $proto;
890 # sv_setpv((SV*)cv$proto) ;
896 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
900 if ($Overload) # make it findable with fetchmethod
903 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
904 #XS(XS_${Packid}_nil)
911 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
912 /* Making a sub named "${Package}::()" allows the package */
913 /* to be findable via fetchmethod(), and causes */
914 /* overload::Overloaded("${Package}") to return true. */
915 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
916 MAKE_FETCHMETHOD_WORK
919 # print initialization routine
928 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
929 #XS(boot_$Module_cname)
941 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
943 print Q(<<"EOF") if $Full_func_name;
944 # const char* file = __FILE__;
950 # PERL_UNUSED_VAR(cv); /* -W */
951 # PERL_UNUSED_VAR(items); /* -W */
954 print Q(<<"EOF") if $WantVersionChk ;
955 # XS_VERSION_BOOTCHECK ;
959 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
965 print Q(<<"EOF") if ($Overload);
966 # /* register the overloading (type 'A') magic */
967 # PL_amagic_generation++;
968 # /* The magic for overload gets a GV* via gv_fetchmeth as */
969 # /* mentioned above, and looks in the SV* slot of it for */
970 # /* the "fallback" status. */
972 # get_sv( "${Package}::()", TRUE ),
979 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
985 print "\n /* Initialisation Section */\n\n" ;
988 print "\n /* End of Initialisation Section */\n\n" ;
994 call_list(PL_scopestack_ix, PL_unitcheckav);
1004 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1009 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1015 sub errors { $errors }
1017 sub standard_typemap_locations {
1018 # Add all the default typemap locations to the search path
1019 my @tm = qw(typemap);
1021 my $updir = File::Spec->updir;
1022 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1023 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1025 unshift @tm, File::Spec->catfile($dir, 'typemap');
1026 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1028 foreach my $dir (@INC) {
1029 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1030 unshift @tm, $file if -e $file;
1037 $_[0] =~ s/^\s+|\s+$//go ;
1044 # rationalise any '*' by joining them into bunches and removing whitespace
1048 # change multiple whitespace into a single space
1051 # trim leading & trailing whitespace
1052 TrimWhitespace($_) ;
1057 # Input: ($_, @line) == unparsed input.
1058 # Output: ($_, @line) == (rest of line, following lines).
1059 # Return: the matched keyword if found, otherwise 0
1061 $_ = shift(@line) while !/\S/ && @line;
1062 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1066 # the "do" is required for right semantics
1067 do { $_ = shift(@line) } while !/\S/ && @line;
1069 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1070 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1071 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1074 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1080 while (!/\S/ && @line) {
1084 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1091 sub process_keyword($)
1096 &{"${kwd}_handler"}()
1097 while $kwd = check_keyword($pattern) ;
1101 blurt ("Error: `CASE:' after unconditional `CASE:'")
1102 if $condnum && $cond eq '';
1104 TrimWhitespace($cond);
1105 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1110 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1111 last if /^\s*NOT_IMPLEMENTED_YET/;
1112 next unless /\S/; # skip blank lines
1114 TrimWhitespace($_) ;
1117 # remove trailing semicolon if no initialisation
1118 s/\s*;$//g unless /[=;+].*\S/ ;
1120 # Process the length(foo) declarations
1121 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1122 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1123 $lengthof{$2} = $name;
1124 # $islengthof{$name} = $1;
1125 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1128 # check for optional initialisation code
1130 $var_init = $1 if s/\s*([=;+].*)$//s ;
1131 $var_init =~ s/"/\\"/g;
1134 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1135 or blurt("Error: invalid argument declaration '$line'"), next;
1137 # Check for duplicate definitions
1138 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1139 if $arg_list{$var_name}++
1140 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1142 $thisdone |= $var_name eq "THIS";
1143 $retvaldone |= $var_name eq "RETVAL";
1144 $var_types{$var_name} = $var_type;
1145 # XXXX This check is a safeguard against the unfinished conversion of
1146 # generate_init(). When generate_init() is fixed,
1147 # one can use 2-args map_type() unconditionally.
1148 if ($var_type =~ / \( \s* \* \s* \) /x) {
1149 # Function pointers are not yet supported with &output_init!
1150 print "\t" . &map_type($var_type, $var_name);
1153 print "\t" . &map_type($var_type);
1156 $var_num = $args_match{$var_name};
1158 $proto_arg[$var_num] = ProtoString($var_type)
1160 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1161 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1162 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1163 and $var_init !~ /\S/) {
1164 if ($name_printed) {
1167 print "\t$var_name;\n";
1169 } elsif ($var_init =~ /\S/) {
1170 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1171 } elsif ($var_num) {
1172 # generate initialization code
1173 &generate_init($var_type, $var_num, $var_name, $name_printed);
1180 sub OUTPUT_handler {
1181 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1183 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1184 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1187 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1188 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1189 if $outargs{$outarg} ++ ;
1190 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1191 # deal with RETVAL last
1192 $RETVAL_code = $outcode ;
1196 blurt ("Error: OUTPUT $outarg not an argument"), next
1197 unless defined($args_match{$outarg});
1198 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1199 unless defined $var_types{$outarg} ;
1200 $var_num = $args_match{$outarg};
1202 print "\t$outcode\n";
1203 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1205 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1207 delete $in_out{$outarg} # No need to auto-OUTPUT
1208 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1212 sub C_ARGS_handler() {
1213 my $in = merge_section();
1215 TrimWhitespace($in);
1219 sub INTERFACE_MACRO_handler() {
1220 my $in = merge_section();
1222 TrimWhitespace($in);
1223 if ($in =~ /\s/) { # two
1224 ($interface_macro, $interface_macro_set) = split ' ', $in;
1226 $interface_macro = $in;
1227 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1229 $interface = 1; # local
1230 $Interfaces = 1; # global
1233 sub INTERFACE_handler() {
1234 my $in = merge_section();
1236 TrimWhitespace($in);
1238 foreach (split /[\s,]+/, $in) {
1240 $name =~ s/^$Prefix//;
1241 $Interfaces{$name} = $_;
1244 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1246 $interface = 1; # local
1247 $Interfaces = 1; # global
1250 sub CLEANUP_handler() { print_section() }
1251 sub PREINIT_handler() { print_section() }
1252 sub POSTCALL_handler() { print_section() }
1253 sub INIT_handler() { print_section() }
1258 my ($orig) = $line ;
1262 # Parse alias definitions
1264 # alias = value alias = value ...
1266 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1268 $orig_alias = $alias ;
1271 # check for optional package definition in the alias
1272 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1274 # check for duplicate alias name & duplicate value
1275 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1276 if defined $XsubAliases{$alias} ;
1278 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1279 if $XsubAliasValues{$value} ;
1282 $XsubAliases{$alias} = $value ;
1283 $XsubAliasValues{$value} = $orig_alias ;
1286 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1290 sub ATTRS_handler ()
1292 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1294 TrimWhitespace($_) ;
1295 push @Attributes, $_;
1299 sub ALIAS_handler ()
1301 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1303 TrimWhitespace($_) ;
1304 GetAliases($_) if $_ ;
1308 sub OVERLOAD_handler()
1310 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1312 TrimWhitespace($_) ;
1313 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1314 $Overload = 1 unless $Overload;
1315 my $overload = "$Package\::(".$1 ;
1317 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1322 sub FALLBACK_handler()
1324 # the rest of the current line should contain either TRUE,
1327 TrimWhitespace($_) ;
1329 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1330 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1331 UNDEF => "&PL_sv_undef",
1334 # check for valid FALLBACK value
1335 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1337 $Fallback = $map{uc $_} ;
1341 sub REQUIRE_handler ()
1343 # the rest of the current line should contain a version number
1346 TrimWhitespace($Ver) ;
1348 death ("Error: REQUIRE expects a version number")
1351 # check that the version number is of the form n.n
1352 death ("Error: REQUIRE: expected a number, got '$Ver'")
1353 unless $Ver =~ /^\d+(\.\d*)?/ ;
1355 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1356 unless $VERSION >= $Ver ;
1359 sub VERSIONCHECK_handler ()
1361 # the rest of the current line should contain either ENABLE or
1364 TrimWhitespace($_) ;
1366 # check for ENABLE/DISABLE
1367 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1368 unless /^(ENABLE|DISABLE)/i ;
1370 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1371 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1375 sub PROTOTYPE_handler ()
1379 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1380 if $proto_in_this_xsub ++ ;
1382 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1385 TrimWhitespace($_) ;
1386 if ($_ eq 'DISABLE') {
1388 } elsif ($_ eq 'ENABLE') {
1391 # remove any whitespace
1393 death("Error: Invalid prototype '$_'")
1394 unless ValidProtoString($_) ;
1395 $ProtoThisXSUB = C_string($_) ;
1399 # If no prototype specified, then assume empty prototype ""
1400 $ProtoThisXSUB = 2 unless $specified ;
1406 sub SCOPE_handler ()
1408 death("Error: Only 1 SCOPE declaration allowed per xsub")
1409 if $scope_in_this_xsub ++ ;
1411 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1413 TrimWhitespace($_) ;
1414 if ($_ =~ /^DISABLE/i) {
1416 } elsif ($_ =~ /^ENABLE/i) {
1423 sub PROTOTYPES_handler ()
1425 # the rest of the current line should contain either ENABLE or
1428 TrimWhitespace($_) ;
1430 # check for ENABLE/DISABLE
1431 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1432 unless /^(ENABLE|DISABLE)/i ;
1434 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1435 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1440 sub INCLUDE_handler ()
1442 # the rest of the current line should contain a valid filename
1444 TrimWhitespace($_) ;
1446 death("INCLUDE: filename missing")
1449 death("INCLUDE: output pipe is illegal")
1452 # simple minded recursion detector
1453 death("INCLUDE loop detected")
1454 if $IncludedFiles{$_} ;
1456 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1458 # Save the current file context.
1461 LastLine => $lastline,
1462 LastLineNo => $lastline_no,
1464 LineNo => \@line_no,
1465 Filename => $filename,
1466 Filepathname => $filepathname,
1470 $FH = Symbol::gensym();
1473 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1477 #/* INCLUDE: Including '$_' from '$filename' */
1481 $filepathname = $filename = $_ ;
1483 # Prime the pump by reading the first
1486 # skip leading blank lines
1488 last unless /^\s*$/ ;
1498 return 0 unless $XSStack[-1]{type} eq 'file' ;
1500 my $data = pop @XSStack ;
1501 my $ThisFile = $filename ;
1502 my $isPipe = ($filename =~ /\|\s*$/) ;
1504 -- $IncludedFiles{$filename}
1509 $FH = $data->{Handle} ;
1510 # $filename is the leafname, which for some reason isused for diagnostic
1511 # messages, whereas $filepathname is the full pathname, and is used for
1513 $filename = $data->{Filename} ;
1514 $filepathname = $data->{Filepathname} ;
1515 $lastline = $data->{LastLine} ;
1516 $lastline_no = $data->{LastLineNo} ;
1517 @line = @{ $data->{Line} } ;
1518 @line_no = @{ $data->{LineNo} } ;
1520 if ($isPipe and $? ) {
1522 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1528 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1535 sub ValidProtoString ($)
1539 if ( $string =~ /^$proto_re+$/ ) {
1550 $string =~ s[\\][\\\\]g ;
1558 $proto_letter{$type} or "\$" ;
1562 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1564 my ($cpp, $cpplevel);
1566 if ($cpp =~ /^\#\s*if/) {
1568 } elsif (!$cpplevel) {
1569 Warn("Warning: #else/elif/endif without #if in this function");
1570 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1571 if $XSStack[-1]{type} eq 'if';
1573 } elsif ($cpp =~ /^\#\s*endif/) {
1577 Warn("Warning: #if without #endif in this function") if $cpplevel;
1585 $text =~ s/\[\[/{/g;
1586 $text =~ s/\]\]/}/g;
1590 # Read next xsub into @line from ($lastline, <$FH>).
1593 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1594 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1597 return PopFile() if !defined $lastline;
1600 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1602 $Package = defined($2) ? $2 : ''; # keep -w happy
1603 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1604 $Prefix = quotemeta $Prefix ;
1605 ($Module_cname = $Module) =~ s/\W/_/g;
1606 ($Packid = $Package) =~ tr/:/_/;
1607 $Packprefix = $Package;
1608 $Packprefix .= "::" if $Packprefix ne "";
1613 # Skip embedded PODs
1614 while ($lastline =~ /^=/) {
1615 while ($lastline = <$FH>) {
1616 last if ($lastline =~ /^=cut\s*$/);
1618 death ("Error: Unterminated pod") unless $lastline;
1621 $lastline =~ s/^\s+$//;
1623 if ($lastline !~ /^\s*#/ ||
1625 # ANSI: if ifdef ifndef elif else endif define undef
1627 # gcc: warning include_next
1629 # others: ident (gcc notes that some cpps have this one)
1630 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1631 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1632 push(@line, $lastline);
1633 push(@line_no, $lastline_no) ;
1636 # Read next line and continuation lines
1637 last unless defined($lastline = <$FH>);
1640 $lastline .= $tmp_line
1641 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1644 $lastline =~ s/^\s+$//;
1646 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1651 local($type, $num, $var, $init, $name_printed) = @_;
1652 local($arg) = "ST(" . ($num - 1) . ")";
1654 if ( $init =~ /^=/ ) {
1655 if ($name_printed) {
1656 eval qq/print " $init\\n"/;
1658 eval qq/print "\\t$var $init\\n"/;
1662 if ( $init =~ s/^\+// && $num ) {
1663 &generate_init($type, $num, $var, $name_printed);
1664 } elsif ($name_printed) {
1668 eval qq/print "\\t$var;\\n"/;
1672 $deferred .= eval qq/"\\n\\t$init\\n"/;
1679 # work out the line number
1680 my $line_no = $line_no[@line_no - @line -1] ;
1682 print STDERR "@_ in $filename, line $line_no\n" ;
1698 local($type, $num, $var) = @_;
1699 local($arg) = "ST(" . ($num - 1) . ")";
1700 local($argoff) = $num - 1;
1704 $type = TidyType($type) ;
1705 blurt("Error: '$type' not in typemap"), return
1706 unless defined($type_kind{$type});
1708 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1709 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1710 $tk = $type_kind{$type};
1711 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1712 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1713 print "\t$var" unless $name_printed;
1714 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1715 die "default value not supported with length(NAME) supplied"
1716 if defined $defaults{$var};
1719 $type =~ tr/:/_/ unless $hiertype;
1720 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1721 unless defined $input_expr{$tk} ;
1722 $expr = $input_expr{$tk};
1723 if ($expr =~ /DO_ARRAY_ELEM/) {
1724 blurt("Error: '$subtype' not in typemap"), return
1725 unless defined($type_kind{$subtype});
1726 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1727 unless defined $input_expr{$type_kind{$subtype}} ;
1728 $subexpr = $input_expr{$type_kind{$subtype}};
1729 $subexpr =~ s/\$type/\$subtype/g;
1730 $subexpr =~ s/ntype/subtype/g;
1731 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1732 $subexpr =~ s/\n\t/\n\t\t/g;
1733 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1734 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1735 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1737 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1740 if (defined($defaults{$var})) {
1741 $expr =~ s/(\t+)/$1 /g;
1743 if ($name_printed) {
1746 eval qq/print "\\t$var;\\n"/;
1749 if ($defaults{$var} eq 'NO_INIT') {
1750 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1752 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1755 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1756 if ($name_printed) {
1759 eval qq/print "\\t$var;\\n"/;
1762 $deferred .= eval qq/"\\n$expr;\\n"/;
1765 die "panic: do not know how to handle this branch for function pointers"
1767 eval qq/print "$expr;\\n"/;
1772 sub generate_output {
1773 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1774 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1775 local($argoff) = $num - 1;
1778 $type = TidyType($type) ;
1779 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1780 print "\t$arg = sv_newmortal();\n";
1781 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1782 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1784 blurt("Error: '$type' not in typemap"), return
1785 unless defined($type_kind{$type});
1786 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1787 unless defined $output_expr{$type_kind{$type}} ;
1788 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1789 $ntype =~ s/\(\)//g;
1790 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1791 $expr = $output_expr{$type_kind{$type}};
1792 if ($expr =~ /DO_ARRAY_ELEM/) {
1793 blurt("Error: '$subtype' not in typemap"), return
1794 unless defined($type_kind{$subtype});
1795 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1796 unless defined $output_expr{$type_kind{$subtype}} ;
1797 $subexpr = $output_expr{$type_kind{$subtype}};
1798 $subexpr =~ s/ntype/subtype/g;
1799 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1800 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1801 $subexpr =~ s/\n\t/\n\t\t/g;
1802 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1803 eval "print qq\a$expr\a";
1805 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1806 } elsif ($var eq 'RETVAL') {
1807 if ($expr =~ /^\t\$arg = new/) {
1808 # We expect that $arg has refcnt 1, so we need to
1810 eval "print qq\a$expr\a";
1812 print "\tsv_2mortal(ST($num));\n";
1813 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1814 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1815 # We expect that $arg has refcnt >=1, so we need
1817 eval "print qq\a$expr\a";
1819 print "\tsv_2mortal(ST(0));\n";
1820 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1822 # Just hope that the entry would safely write it
1823 # over an already mortalized value. By
1824 # coincidence, something like $arg = &sv_undef
1826 print "\tST(0) = sv_newmortal();\n";
1827 eval "print qq\a$expr\a";
1829 # new mortals don't have set magic
1831 } elsif ($do_push) {
1832 print "\tPUSHs(sv_newmortal());\n";
1834 eval "print qq\a$expr\a";
1836 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1837 } elsif ($arg =~ /^ST\(\d+\)$/) {
1838 eval "print qq\a$expr\a";
1840 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1846 my($type, $varname) = @_;
1848 # C++ has :: in types too so skip this
1849 $type =~ tr/:/_/ unless $hiertype;
1850 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1852 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1853 (substr $type, pos $type, 0) = " $varname ";
1855 $type .= "\t$varname";
1862 #########################################################
1864 ExtUtils::ParseXS::CountLines;
1866 use vars qw($SECTION_END_MARKER);
1869 my ($class, $cfile, $fh) = @_;
1870 $cfile =~ s/\\/\\\\/g;
1871 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1873 return bless {buffer => '',
1882 $self->{buffer} .= $_;
1883 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1885 ++ $self->{line_no};
1886 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1887 print {$self->{fh}} $line;
1895 $self->PRINT(sprintf($fmt, @_));
1899 # Not necessary if we're careful to end with a "\n"
1901 print {$self->{fh}} $self->{buffer};
1905 # This sub does nothing, but is neccessary for references to be released.
1909 return $SECTION_END_MARKER;
1918 ExtUtils::ParseXS - converts Perl XS code into C code
1922 use ExtUtils::ParseXS qw(process_file);
1924 process_file( filename => 'foo.xs' );
1926 process_file( filename => 'foo.xs',
1929 typemap => 'path/to/typemap',
1940 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1941 necessary to let C functions manipulate Perl values and creates the glue
1942 necessary to let Perl access those functions. The compiler uses typemaps to
1943 determine how to map C function parameters and variables to Perl values.
1945 The compiler will search for typemap files called I<typemap>. It will use
1946 the following search path to find default typemaps, with the rightmost
1947 typemap taking precedence.
1949 ../../../typemap:../../typemap:../typemap:typemap
1953 None by default. C<process_file()> may be exported upon request.
1962 This function processes an XS file and sends output to a C file.
1963 Named parameters control how the processing is done. The following
1964 parameters are accepted:
1970 Adds C<extern "C"> to the C code. Default is false.
1974 Retains C<::> in type names so that C++ hierachical types can be
1975 mapped. Default is false.
1979 Adds exception handling stubs to the C code. Default is false.
1983 Indicates that a user-supplied typemap should take precedence over the
1984 default typemaps. A single typemap may be specified as a string, or
1985 multiple typemaps can be specified in an array reference, with the
1986 last typemap having the highest precedence.
1990 Generates prototype code for all xsubs. Default is false.
1992 =item B<versioncheck>
1994 Makes sure at run time that the object file (derived from the C<.xs>
1995 file) and the C<.pm> files have the same version number. Default is
1998 =item B<linenumbers>
2000 Adds C<#line> directives to the C output so error messages will look
2001 like they came from the original XS file. Default is true.
2005 Enables certain optimizations. The only optimization that is currently
2006 affected is the use of I<target>s by the output C code (see L<perlguts>).
2007 Not optimizing may significantly slow down the generated code, but this is the way
2008 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2012 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2013 declarations. Default is true.
2017 Enable recognition of ANSI-like descriptions of function signature.
2022 I have no clue what this does. Strips function prefixes?
2028 This function returns the number of [a certain kind of] errors
2029 encountered during processing of the XS file.
2035 Based on xsubpp code, written by Larry Wall.
2037 Maintained by Ken Williams, <ken@mathforum.org>
2041 Copyright 2002-2003 Ken Williams. All rights reserved.
2043 This library is free software; you can redistribute it and/or
2044 modify it under the same terms as Perl itself.
2046 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2047 Porters, which was released under the same license terms.
2051 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.