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)
910 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
911 /* Making a sub named "${Package}::()" allows the package */
912 /* to be findable via fetchmethod(), and causes */
913 /* overload::Overloaded("${Package}") to return true. */
914 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
915 MAKE_FETCHMETHOD_WORK
918 # print initialization routine
927 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
928 #XS(boot_$Module_cname)
940 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
942 print Q(<<"EOF") if $Full_func_name;
943 # char* file = __FILE__;
949 # PERL_UNUSED_VAR(cv); /* -W */
950 # PERL_UNUSED_VAR(items); /* -W */
953 print Q(<<"EOF") if $WantVersionChk ;
954 # XS_VERSION_BOOTCHECK ;
958 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
964 print Q(<<"EOF") if ($Overload);
965 # /* register the overloading (type 'A') magic */
966 # PL_amagic_generation++;
967 # /* The magic for overload gets a GV* via gv_fetchmeth as */
968 # /* mentioned above, and looks in the SV* slot of it for */
969 # /* the "fallback" status. */
971 # get_sv( "${Package}::()", TRUE ),
978 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
984 print "\n /* Initialisation Section */\n\n" ;
987 print "\n /* End of Initialisation Section */\n\n" ;
993 call_list(PL_scopestack_ix, PL_unitcheckav);
1003 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1008 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1014 sub errors { $errors }
1016 sub standard_typemap_locations {
1017 # Add all the default typemap locations to the search path
1018 my @tm = qw(typemap);
1020 my $updir = File::Spec->updir;
1021 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1022 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1024 unshift @tm, File::Spec->catfile($dir, 'typemap');
1025 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1027 foreach my $dir (@INC) {
1028 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1029 unshift @tm, $file if -e $file;
1036 $_[0] =~ s/^\s+|\s+$//go ;
1043 # rationalise any '*' by joining them into bunches and removing whitespace
1047 # change multiple whitespace into a single space
1050 # trim leading & trailing whitespace
1051 TrimWhitespace($_) ;
1056 # Input: ($_, @line) == unparsed input.
1057 # Output: ($_, @line) == (rest of line, following lines).
1058 # Return: the matched keyword if found, otherwise 0
1060 $_ = shift(@line) while !/\S/ && @line;
1061 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1065 # the "do" is required for right semantics
1066 do { $_ = shift(@line) } while !/\S/ && @line;
1068 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1069 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1070 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1073 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1079 while (!/\S/ && @line) {
1083 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1090 sub process_keyword($)
1095 &{"${kwd}_handler"}()
1096 while $kwd = check_keyword($pattern) ;
1100 blurt ("Error: `CASE:' after unconditional `CASE:'")
1101 if $condnum && $cond eq '';
1103 TrimWhitespace($cond);
1104 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1109 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1110 last if /^\s*NOT_IMPLEMENTED_YET/;
1111 next unless /\S/; # skip blank lines
1113 TrimWhitespace($_) ;
1116 # remove trailing semicolon if no initialisation
1117 s/\s*;$//g unless /[=;+].*\S/ ;
1119 # Process the length(foo) declarations
1120 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1121 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1122 $lengthof{$2} = $name;
1123 # $islengthof{$name} = $1;
1124 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1127 # check for optional initialisation code
1129 $var_init = $1 if s/\s*([=;+].*)$//s ;
1130 $var_init =~ s/"/\\"/g;
1133 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1134 or blurt("Error: invalid argument declaration '$line'"), next;
1136 # Check for duplicate definitions
1137 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1138 if $arg_list{$var_name}++
1139 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1141 $thisdone |= $var_name eq "THIS";
1142 $retvaldone |= $var_name eq "RETVAL";
1143 $var_types{$var_name} = $var_type;
1144 # XXXX This check is a safeguard against the unfinished conversion of
1145 # generate_init(). When generate_init() is fixed,
1146 # one can use 2-args map_type() unconditionally.
1147 if ($var_type =~ / \( \s* \* \s* \) /x) {
1148 # Function pointers are not yet supported with &output_init!
1149 print "\t" . &map_type($var_type, $var_name);
1152 print "\t" . &map_type($var_type);
1155 $var_num = $args_match{$var_name};
1157 $proto_arg[$var_num] = ProtoString($var_type)
1159 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1160 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1161 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1162 and $var_init !~ /\S/) {
1163 if ($name_printed) {
1166 print "\t$var_name;\n";
1168 } elsif ($var_init =~ /\S/) {
1169 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1170 } elsif ($var_num) {
1171 # generate initialization code
1172 &generate_init($var_type, $var_num, $var_name, $name_printed);
1179 sub OUTPUT_handler {
1180 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1182 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1183 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1186 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1187 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1188 if $outargs{$outarg} ++ ;
1189 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1190 # deal with RETVAL last
1191 $RETVAL_code = $outcode ;
1195 blurt ("Error: OUTPUT $outarg not an argument"), next
1196 unless defined($args_match{$outarg});
1197 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1198 unless defined $var_types{$outarg} ;
1199 $var_num = $args_match{$outarg};
1201 print "\t$outcode\n";
1202 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1204 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1206 delete $in_out{$outarg} # No need to auto-OUTPUT
1207 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1211 sub C_ARGS_handler() {
1212 my $in = merge_section();
1214 TrimWhitespace($in);
1218 sub INTERFACE_MACRO_handler() {
1219 my $in = merge_section();
1221 TrimWhitespace($in);
1222 if ($in =~ /\s/) { # two
1223 ($interface_macro, $interface_macro_set) = split ' ', $in;
1225 $interface_macro = $in;
1226 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1228 $interface = 1; # local
1229 $Interfaces = 1; # global
1232 sub INTERFACE_handler() {
1233 my $in = merge_section();
1235 TrimWhitespace($in);
1237 foreach (split /[\s,]+/, $in) {
1239 $name =~ s/^$Prefix//;
1240 $Interfaces{$name} = $_;
1243 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1245 $interface = 1; # local
1246 $Interfaces = 1; # global
1249 sub CLEANUP_handler() { print_section() }
1250 sub PREINIT_handler() { print_section() }
1251 sub POSTCALL_handler() { print_section() }
1252 sub INIT_handler() { print_section() }
1257 my ($orig) = $line ;
1261 # Parse alias definitions
1263 # alias = value alias = value ...
1265 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1267 $orig_alias = $alias ;
1270 # check for optional package definition in the alias
1271 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1273 # check for duplicate alias name & duplicate value
1274 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1275 if defined $XsubAliases{$alias} ;
1277 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1278 if $XsubAliasValues{$value} ;
1281 $XsubAliases{$alias} = $value ;
1282 $XsubAliasValues{$value} = $orig_alias ;
1285 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1289 sub ATTRS_handler ()
1291 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1293 TrimWhitespace($_) ;
1294 push @Attributes, $_;
1298 sub ALIAS_handler ()
1300 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1302 TrimWhitespace($_) ;
1303 GetAliases($_) if $_ ;
1307 sub OVERLOAD_handler()
1309 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1311 TrimWhitespace($_) ;
1312 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1313 $Overload = 1 unless $Overload;
1314 my $overload = "$Package\::(".$1 ;
1316 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1321 sub FALLBACK_handler()
1323 # the rest of the current line should contain either TRUE,
1326 TrimWhitespace($_) ;
1328 TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
1329 FALSE => "PL_sv_no", 0 => "PL_sv_no",
1330 UNDEF => "PL_sv_undef",
1333 # check for valid FALLBACK value
1334 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1336 $Fallback = $map{uc $_} ;
1340 sub REQUIRE_handler ()
1342 # the rest of the current line should contain a version number
1345 TrimWhitespace($Ver) ;
1347 death ("Error: REQUIRE expects a version number")
1350 # check that the version number is of the form n.n
1351 death ("Error: REQUIRE: expected a number, got '$Ver'")
1352 unless $Ver =~ /^\d+(\.\d*)?/ ;
1354 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1355 unless $VERSION >= $Ver ;
1358 sub VERSIONCHECK_handler ()
1360 # the rest of the current line should contain either ENABLE or
1363 TrimWhitespace($_) ;
1365 # check for ENABLE/DISABLE
1366 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1367 unless /^(ENABLE|DISABLE)/i ;
1369 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1370 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1374 sub PROTOTYPE_handler ()
1378 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1379 if $proto_in_this_xsub ++ ;
1381 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1384 TrimWhitespace($_) ;
1385 if ($_ eq 'DISABLE') {
1387 } elsif ($_ eq 'ENABLE') {
1390 # remove any whitespace
1392 death("Error: Invalid prototype '$_'")
1393 unless ValidProtoString($_) ;
1394 $ProtoThisXSUB = C_string($_) ;
1398 # If no prototype specified, then assume empty prototype ""
1399 $ProtoThisXSUB = 2 unless $specified ;
1405 sub SCOPE_handler ()
1407 death("Error: Only 1 SCOPE declaration allowed per xsub")
1408 if $scope_in_this_xsub ++ ;
1410 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1412 TrimWhitespace($_) ;
1413 if ($_ =~ /^DISABLE/i) {
1415 } elsif ($_ =~ /^ENABLE/i) {
1422 sub PROTOTYPES_handler ()
1424 # the rest of the current line should contain either ENABLE or
1427 TrimWhitespace($_) ;
1429 # check for ENABLE/DISABLE
1430 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1431 unless /^(ENABLE|DISABLE)/i ;
1433 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1434 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1439 sub INCLUDE_handler ()
1441 # the rest of the current line should contain a valid filename
1443 TrimWhitespace($_) ;
1445 death("INCLUDE: filename missing")
1448 death("INCLUDE: output pipe is illegal")
1451 # simple minded recursion detector
1452 death("INCLUDE loop detected")
1453 if $IncludedFiles{$_} ;
1455 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1457 # Save the current file context.
1460 LastLine => $lastline,
1461 LastLineNo => $lastline_no,
1463 LineNo => \@line_no,
1464 Filename => $filename,
1465 Filepathname => $filepathname,
1469 $FH = Symbol::gensym();
1472 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1476 #/* INCLUDE: Including '$_' from '$filename' */
1480 $filepathname = $filename = $_ ;
1482 # Prime the pump by reading the first
1485 # skip leading blank lines
1487 last unless /^\s*$/ ;
1497 return 0 unless $XSStack[-1]{type} eq 'file' ;
1499 my $data = pop @XSStack ;
1500 my $ThisFile = $filename ;
1501 my $isPipe = ($filename =~ /\|\s*$/) ;
1503 -- $IncludedFiles{$filename}
1508 $FH = $data->{Handle} ;
1509 # $filename is the leafname, which for some reason isused for diagnostic
1510 # messages, whereas $filepathname is the full pathname, and is used for
1512 $filename = $data->{Filename} ;
1513 $filepathname = $data->{Filepathname} ;
1514 $lastline = $data->{LastLine} ;
1515 $lastline_no = $data->{LastLineNo} ;
1516 @line = @{ $data->{Line} } ;
1517 @line_no = @{ $data->{LineNo} } ;
1519 if ($isPipe and $? ) {
1521 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1527 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1534 sub ValidProtoString ($)
1538 if ( $string =~ /^$proto_re+$/ ) {
1549 $string =~ s[\\][\\\\]g ;
1557 $proto_letter{$type} or "\$" ;
1561 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1563 my ($cpp, $cpplevel);
1565 if ($cpp =~ /^\#\s*if/) {
1567 } elsif (!$cpplevel) {
1568 Warn("Warning: #else/elif/endif without #if in this function");
1569 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1570 if $XSStack[-1]{type} eq 'if';
1572 } elsif ($cpp =~ /^\#\s*endif/) {
1576 Warn("Warning: #if without #endif in this function") if $cpplevel;
1584 $text =~ s/\[\[/{/g;
1585 $text =~ s/\]\]/}/g;
1589 # Read next xsub into @line from ($lastline, <$FH>).
1592 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1593 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1596 return PopFile() if !defined $lastline;
1599 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1601 $Package = defined($2) ? $2 : ''; # keep -w happy
1602 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1603 $Prefix = quotemeta $Prefix ;
1604 ($Module_cname = $Module) =~ s/\W/_/g;
1605 ($Packid = $Package) =~ tr/:/_/;
1606 $Packprefix = $Package;
1607 $Packprefix .= "::" if $Packprefix ne "";
1612 # Skip embedded PODs
1613 while ($lastline =~ /^=/) {
1614 while ($lastline = <$FH>) {
1615 last if ($lastline =~ /^=cut\s*$/);
1617 death ("Error: Unterminated pod") unless $lastline;
1620 $lastline =~ s/^\s+$//;
1622 if ($lastline !~ /^\s*#/ ||
1624 # ANSI: if ifdef ifndef elif else endif define undef
1626 # gcc: warning include_next
1628 # others: ident (gcc notes that some cpps have this one)
1629 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1630 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1631 push(@line, $lastline);
1632 push(@line_no, $lastline_no) ;
1635 # Read next line and continuation lines
1636 last unless defined($lastline = <$FH>);
1639 $lastline .= $tmp_line
1640 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1643 $lastline =~ s/^\s+$//;
1645 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1650 local($type, $num, $var, $init, $name_printed) = @_;
1651 local($arg) = "ST(" . ($num - 1) . ")";
1653 if ( $init =~ /^=/ ) {
1654 if ($name_printed) {
1655 eval qq/print " $init\\n"/;
1657 eval qq/print "\\t$var $init\\n"/;
1661 if ( $init =~ s/^\+// && $num ) {
1662 &generate_init($type, $num, $var, $name_printed);
1663 } elsif ($name_printed) {
1667 eval qq/print "\\t$var;\\n"/;
1671 $deferred .= eval qq/"\\n\\t$init\\n"/;
1678 # work out the line number
1679 my $line_no = $line_no[@line_no - @line -1] ;
1681 print STDERR "@_ in $filename, line $line_no\n" ;
1697 local($type, $num, $var) = @_;
1698 local($arg) = "ST(" . ($num - 1) . ")";
1699 local($argoff) = $num - 1;
1703 $type = TidyType($type) ;
1704 blurt("Error: '$type' not in typemap"), return
1705 unless defined($type_kind{$type});
1707 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1708 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1709 $tk = $type_kind{$type};
1710 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1711 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1712 print "\t$var" unless $name_printed;
1713 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1714 die "default value not supported with length(NAME) supplied"
1715 if defined $defaults{$var};
1718 $type =~ tr/:/_/ unless $hiertype;
1719 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1720 unless defined $input_expr{$tk} ;
1721 $expr = $input_expr{$tk};
1722 if ($expr =~ /DO_ARRAY_ELEM/) {
1723 blurt("Error: '$subtype' not in typemap"), return
1724 unless defined($type_kind{$subtype});
1725 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1726 unless defined $input_expr{$type_kind{$subtype}} ;
1727 $subexpr = $input_expr{$type_kind{$subtype}};
1728 $subexpr =~ s/\$type/\$subtype/g;
1729 $subexpr =~ s/ntype/subtype/g;
1730 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1731 $subexpr =~ s/\n\t/\n\t\t/g;
1732 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1733 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1734 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1736 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1739 if (defined($defaults{$var})) {
1740 $expr =~ s/(\t+)/$1 /g;
1742 if ($name_printed) {
1745 eval qq/print "\\t$var;\\n"/;
1748 if ($defaults{$var} eq 'NO_INIT') {
1749 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1751 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1754 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1755 if ($name_printed) {
1758 eval qq/print "\\t$var;\\n"/;
1761 $deferred .= eval qq/"\\n$expr;\\n"/;
1764 die "panic: do not know how to handle this branch for function pointers"
1766 eval qq/print "$expr;\\n"/;
1771 sub generate_output {
1772 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1773 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1774 local($argoff) = $num - 1;
1777 $type = TidyType($type) ;
1778 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1779 print "\t$arg = sv_newmortal();\n";
1780 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1781 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1783 blurt("Error: '$type' not in typemap"), return
1784 unless defined($type_kind{$type});
1785 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1786 unless defined $output_expr{$type_kind{$type}} ;
1787 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1788 $ntype =~ s/\(\)//g;
1789 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1790 $expr = $output_expr{$type_kind{$type}};
1791 if ($expr =~ /DO_ARRAY_ELEM/) {
1792 blurt("Error: '$subtype' not in typemap"), return
1793 unless defined($type_kind{$subtype});
1794 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1795 unless defined $output_expr{$type_kind{$subtype}} ;
1796 $subexpr = $output_expr{$type_kind{$subtype}};
1797 $subexpr =~ s/ntype/subtype/g;
1798 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1799 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1800 $subexpr =~ s/\n\t/\n\t\t/g;
1801 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1802 eval "print qq\a$expr\a";
1804 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1805 } elsif ($var eq 'RETVAL') {
1806 if ($expr =~ /^\t\$arg = new/) {
1807 # We expect that $arg has refcnt 1, so we need to
1809 eval "print qq\a$expr\a";
1811 print "\tsv_2mortal(ST($num));\n";
1812 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1813 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1814 # We expect that $arg has refcnt >=1, so we need
1816 eval "print qq\a$expr\a";
1818 print "\tsv_2mortal(ST(0));\n";
1819 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1821 # Just hope that the entry would safely write it
1822 # over an already mortalized value. By
1823 # coincidence, something like $arg = &sv_undef
1825 print "\tST(0) = sv_newmortal();\n";
1826 eval "print qq\a$expr\a";
1828 # new mortals don't have set magic
1830 } elsif ($do_push) {
1831 print "\tPUSHs(sv_newmortal());\n";
1833 eval "print qq\a$expr\a";
1835 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1836 } elsif ($arg =~ /^ST\(\d+\)$/) {
1837 eval "print qq\a$expr\a";
1839 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1845 my($type, $varname) = @_;
1847 # C++ has :: in types too so skip this
1848 $type =~ tr/:/_/ unless $hiertype;
1849 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1851 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1852 (substr $type, pos $type, 0) = " $varname ";
1854 $type .= "\t$varname";
1861 #########################################################
1863 ExtUtils::ParseXS::CountLines;
1865 use vars qw($SECTION_END_MARKER);
1868 my ($class, $cfile, $fh) = @_;
1869 $cfile =~ s/\\/\\\\/g;
1870 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1872 return bless {buffer => '',
1881 $self->{buffer} .= $_;
1882 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1884 ++ $self->{line_no};
1885 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1886 print {$self->{fh}} $line;
1894 $self->PRINT(sprintf($fmt, @_));
1898 # Not necessary if we're careful to end with a "\n"
1900 print {$self->{fh}} $self->{buffer};
1904 # This sub does nothing, but is neccessary for references to be released.
1908 return $SECTION_END_MARKER;
1917 ExtUtils::ParseXS - converts Perl XS code into C code
1921 use ExtUtils::ParseXS qw(process_file);
1923 process_file( filename => 'foo.xs' );
1925 process_file( filename => 'foo.xs',
1928 typemap => 'path/to/typemap',
1939 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1940 necessary to let C functions manipulate Perl values and creates the glue
1941 necessary to let Perl access those functions. The compiler uses typemaps to
1942 determine how to map C function parameters and variables to Perl values.
1944 The compiler will search for typemap files called I<typemap>. It will use
1945 the following search path to find default typemaps, with the rightmost
1946 typemap taking precedence.
1948 ../../../typemap:../../typemap:../typemap:typemap
1952 None by default. C<process_file()> may be exported upon request.
1961 This function processes an XS file and sends output to a C file.
1962 Named parameters control how the processing is done. The following
1963 parameters are accepted:
1969 Adds C<extern "C"> to the C code. Default is false.
1973 Retains C<::> in type names so that C++ hierachical types can be
1974 mapped. Default is false.
1978 Adds exception handling stubs to the C code. Default is false.
1982 Indicates that a user-supplied typemap should take precedence over the
1983 default typemaps. A single typemap may be specified as a string, or
1984 multiple typemaps can be specified in an array reference, with the
1985 last typemap having the highest precedence.
1989 Generates prototype code for all xsubs. Default is false.
1991 =item B<versioncheck>
1993 Makes sure at run time that the object file (derived from the C<.xs>
1994 file) and the C<.pm> files have the same version number. Default is
1997 =item B<linenumbers>
1999 Adds C<#line> directives to the C output so error messages will look
2000 like they came from the original XS file. Default is true.
2004 Enables certain optimizations. The only optimization that is currently
2005 affected is the use of I<target>s by the output C code (see L<perlguts>).
2006 Not optimizing may significantly slow down the generated code, but this is the way
2007 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2011 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2012 declarations. Default is true.
2016 Enable recognition of ANSI-like descriptions of function signature.
2021 I have no clue what this does. Strips function prefixes?
2027 This function returns the number of [a certain kind of] errors
2028 encountered during processing of the XS file.
2034 Based on xsubpp code, written by Larry Wall.
2036 Maintained by Ken Williams, <ken@mathforum.org>
2040 Copyright 2002-2003 Ken Williams. All rights reserved.
2042 This library is free software; you can redistribute it and/or
2043 modify it under the same terms as Perl itself.
2045 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2046 Porters, which was released under the same license terms.
2050 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.