1 package ExtUtils::ParseXS;
3 use 5.006; # We use /??{}/ in regexes
12 @EXPORT_OK = qw(process_file);
14 # use strict; # One of these days...
16 my(@XSStack); # Stack of conditionals and INCLUDEs
17 my($XSS_work_idx, $cpp_next_tmp);
19 use vars qw($VERSION);
22 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
23 $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
24 $WantOptimize $process_inout $process_argtypes @tm
25 $dir $filename $filepathname %IncludedFiles
26 %type_kind %proto_letter
27 %targetable $BLOCK_re $lastline $lastline_no
28 $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
29 $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
30 $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
31 $ProtoThisXSUB $ScopeThisXSUB $xsreturn
32 @line_no $ret_type $func_header $orig_args
33 ); # Add these just to get compilation to happen.
38 # Allow for $package->process_file(%hash) in the future
39 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
41 $ProtoUsed = exists $args{prototypes};
45 # 'C++' => 0, # Doesn't seem to *do* anything...
63 my ($Is_VMS, $SymSet);
66 # Establish set of global symbols with max length 28, since xsubpp
67 # will later add the 'XS_' prefix.
68 require ExtUtils::XSSymSet;
69 $SymSet = new ExtUtils::XSSymSet 28;
71 @XSStack = ({type => 'none'});
72 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
75 $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
78 $Fallback = 'PL_sv_undef';
80 # Most of the 1500 lines below uses these globals. We'll have to
81 # clean this up sometime, probably. For now, we just pull them out
84 $cplusplus = $args{'C++'};
85 $hiertype = $args{hiertype};
86 $WantPrototypes = $args{prototypes};
87 $WantVersionChk = $args{versioncheck};
88 $except = $args{except} ? ' TRY' : '';
89 $WantLineNumbers = $args{linenumbers};
90 $WantOptimize = $args{optimize};
91 $process_inout = $args{inout};
92 $process_argtypes = $args{argtypes};
93 @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
95 for ($args{filename}) {
96 die "Missing required parameter 'filename'" unless $_;
98 ($dir, $filename) = (dirname($_), basename($_));
99 $filepathname =~ s/\\/\\\\/g;
100 $IncludedFiles{$_}++;
103 # Open the input file
104 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
106 # Open the output file if given as a string. If they provide some
107 # other kind of reference, trust them that we can print to it.
108 if (not ref $args{output}) {
109 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
110 $args{outfile} = $args{output};
114 # Really, we shouldn't have to chdir() or select() in the first
115 # place. For now, just save & restore.
116 my $orig_cwd = cwd();
117 my $orig_fh = select();
121 my $csuffix = $args{csuffix};
123 if ($WantLineNumbers) {
125 if ( $args{outfile} ) {
126 $cfile = $args{outfile};
128 $cfile = $args{filename};
129 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
131 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
132 select PSEUDO_STDOUT;
134 select $args{output};
137 foreach my $typemap (@tm) {
138 die "Can't find $typemap in $pwd\n" unless -r $typemap;
141 push @tm, standard_typemap_locations();
143 foreach my $typemap (@tm) {
144 next unless -f $typemap ;
145 # skip directories, binary files etc.
146 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
148 open(TYPEMAP, $typemap)
149 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
150 my $mode = 'Typemap';
152 my $current = \$junk;
155 my $line_no = $. + 1;
157 $mode = 'Input'; $current = \$junk; next;
160 $mode = 'Output'; $current = \$junk; next;
162 if (/^TYPEMAP\s*$/) {
163 $mode = 'Typemap'; $current = \$junk; next;
165 if ($mode eq 'Typemap') {
169 # skip blank lines and comment lines
170 next if /^$/ or /^#/ ;
171 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
172 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
173 $type = TidyType($type) ;
174 $type_kind{$type} = $kind ;
175 # prototype defaults to '$'
176 $proto = "\$" unless $proto ;
177 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
178 unless ValidProtoString($proto) ;
179 $proto_letter{$type} = C_string($proto) ;
182 } elsif ($mode eq 'Input') {
184 $input_expr{$_} = '';
185 $current = \$input_expr{$_};
188 $output_expr{$_} = '';
189 $current = \$output_expr{$_};
195 foreach my $key (keys %input_expr) {
196 $input_expr{$key} =~ s/;*\s+\z//;
200 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
201 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
202 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
204 foreach my $key (keys %output_expr) {
207 my ($t, $with_size, $arg, $sarg) =
208 ($output_expr{$key} =~
209 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
210 \s* \( \s* $cast \$arg \s* ,
211 \s* ( (??{ $bal }) ) # Set from
212 ( (??{ $size }) )? # Possible sizeof set-from
215 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
218 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
220 # Match an XS keyword
221 $BLOCK_re= '\s*(' . join('|', qw(
222 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
223 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
224 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
228 our ($C_group_rex, $C_arg);
229 # Group in C (no support for comments or literals)
230 $C_group_rex = qr/ [({\[]
231 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
233 # Chunk in C without comma at toplevel (no comments):
234 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
235 | (??{ $C_group_rex })
236 | " (?: (?> [^\\"]+ )
238 )* " # String literal
239 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
242 # Identify the version of xsubpp used
245 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
246 * contents of $filename. Do not edit this file, edit $filename instead.
248 * ANY CHANGES MADE HERE WILL BE LOST!
255 print("#line 1 \"$filepathname\"\n")
261 my $podstartline = $.;
264 # We can't just write out a /* */ comment, as our embedded
265 # POD might itself be in a comment. We can't put a /**/
266 # comment inside #if 0, as the C standard says that the source
267 # file is decomposed into preprocessing characters in the stage
268 # before preprocessing commands are executed.
269 # I don't want to leave the text as barewords, because the spec
270 # isn't clear whether macros are expanded before or after
271 # preprocessing commands are executed, and someone pathological
272 # may just have defined one of the 3 words as a macro that does
273 # something strange. Multiline strings are illegal in C, so
274 # the "" we write must be a string literal. And they aren't
275 # concatenated until 2 steps later, so we are safe.
277 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
278 printf("#line %d \"$filepathname\"\n", $. + 1)
284 # At this point $. is at end of file so die won't state the start
285 # of the problem, and as we haven't yet read any lines &death won't
286 # show the correct line in the message either.
287 die ("Error: Unterminated pod in $filename, line $podstartline\n")
290 last if ($Package, $Prefix) =
291 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
295 unless (defined $_) {
296 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
297 exit 0; # Not a fatal error for the caller process
301 #ifndef PERL_UNUSED_VAR
302 # define PERL_UNUSED_VAR(var) if (0) var = var
307 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
313 while (fetch_para()) {
314 # Print initial preprocessor statements and blank lines
315 while (@line && $line[0] !~ /^[^\#]/) {
316 my $line = shift(@line);
318 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
320 if ($statement eq 'if') {
321 $XSS_work_idx = @XSStack;
322 push(@XSStack, {type => 'if'});
324 death ("Error: `$statement' with no matching `if'")
325 if $XSStack[-1]{type} ne 'if';
326 if ($XSStack[-1]{varname}) {
327 push(@InitFileCode, "#endif\n");
328 push(@BootCode, "#endif");
331 my(@fns) = keys %{$XSStack[-1]{functions}};
332 if ($statement ne 'endif') {
333 # Hide the functions defined in other #if branches, and reset.
334 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
335 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
337 my($tmp) = pop(@XSStack);
338 0 while (--$XSS_work_idx
339 && $XSStack[$XSS_work_idx]{type} ne 'if');
340 # Keep all new defined functions
341 push(@fns, keys %{$tmp->{other_functions}});
342 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
347 next PARAGRAPH unless @line;
349 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
350 # We are inside an #if, but have not yet #defined its xsubpp variable.
351 print "#define $cpp_next_tmp 1\n\n";
352 push(@InitFileCode, "#if $cpp_next_tmp\n");
353 push(@BootCode, "#if $cpp_next_tmp");
354 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
357 death ("Code is not inside a function"
358 ." (maybe last function was ended by a blank line "
359 ." followed by a statement on column one?)")
360 if $line[0] =~ /^\s/;
362 my ($class, $externC, $static, $elipsis, $wantRETVAL, $RETVAL_no_return);
363 my (@fake_INPUT_pre); # For length(s) generated variables
366 # initialize info arrays
372 undef($processing_arg_with_types) ;
373 undef(%argtype_seen) ;
377 undef($proto_in_this_xsub) ;
378 undef($scope_in_this_xsub) ;
380 undef($prepush_done);
381 $interface_macro = 'XSINTERFACE_FUNC' ;
382 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
383 $ProtoThisXSUB = $WantPrototypes ;
388 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
389 &{"${kwd}_handler"}() ;
390 next PARAGRAPH unless @line ;
394 if (check_keyword("BOOT")) {
396 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
397 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
398 push (@BootCode, @line, "") ;
403 # extract return type, function name and arguments
404 ($ret_type) = TidyType($_);
405 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
407 # Allow one-line ANSI-like declaration
410 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
412 # a function definition needs at least 2 lines
413 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
416 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
417 $static = 1 if $ret_type =~ s/^static\s+//;
419 $func_header = shift(@line);
420 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
421 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
423 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
424 $class = "$4 $class" if $4;
425 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
426 ($clean_func_name = $func_name) =~ s/^$Prefix//;
427 $Full_func_name = "${Packid}_$clean_func_name";
429 $Full_func_name = $SymSet->addsym($Full_func_name);
432 # Check for duplicate function definition
433 for my $tmp (@XSStack) {
434 next unless defined $tmp->{functions}{$Full_func_name};
435 Warn("Warning: duplicate function definition '$clean_func_name' detected");
438 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
439 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
442 $orig_args =~ s/\\\s*/ /g; # process line continuations
445 my %only_C_inlist; # Not in the signature of Perl function
446 if ($process_argtypes and $orig_args =~ /\S/) {
447 my $args = "$orig_args ,";
448 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
449 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
453 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
454 my ($pre, $name) = ($arg =~ /(.*?) \s*
455 \b ( \w+ | length\( \s*\w+\s* \) )
457 next unless defined($pre) && length($pre);
460 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
462 $out_type = $type if $type ne 'IN';
463 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
464 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
467 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
468 $name = "XSauto_length_of_$1";
470 die "Default value on length() argument: `$_'"
473 if (length $pre or $islength) { # Has a type
475 push @fake_INPUT_pre, $arg;
477 push @fake_INPUT, $arg;
479 # warn "pushing '$arg'\n";
480 $argtype_seen{$name}++;
481 $_ = "$name$default"; # Assigns to @args
483 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
484 push @outlist, $name if $out_type =~ /OUTLIST$/;
485 $in_out{$name} = $out_type if $out_type;
488 @args = split(/\s*,\s*/, $orig_args);
489 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
492 @args = split(/\s*,\s*/, $orig_args);
494 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
496 next if $out_type eq 'IN';
497 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
498 push @outlist, $name if $out_type =~ /OUTLIST$/;
499 $in_out{$_} = $out_type;
503 if (defined($class)) {
504 my $arg0 = ((defined($static) or $func_name eq 'new')
506 unshift(@args, $arg0);
507 ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
512 my $report_args = '';
513 foreach my $i (0 .. $#args) {
514 if ($args[$i] =~ s/\.\.\.//) {
516 if ($args[$i] eq '' && $i == $#args) {
517 $report_args .= ", ...";
522 if ($only_C_inlist{$args[$i]}) {
523 push @args_num, undef;
525 push @args_num, ++$num_args;
526 $report_args .= ", $args[$i]";
528 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
531 $defaults{$args[$i]} = $2;
532 $defaults{$args[$i]} =~ s/"/\\"/g;
534 $proto_arg[$i+1] = '$' ;
536 $min_args = $num_args - $extra_args;
537 $report_args =~ s/"/\\"/g;
538 $report_args =~ s/^,\s+//;
539 my @func_args = @args;
540 shift @func_args if defined($class);
543 s/^/&/ if $in_out{$_};
545 $func_args = join(", ", @func_args);
546 @args_match{@args} = @args_num;
548 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
549 $CODE = grep(/^\s*CODE\s*:/, @line);
550 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
551 # to set explicit return values.
552 $EXPLICIT_RETURN = ($CODE &&
553 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
554 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
555 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
557 $xsreturn = 1 if $EXPLICIT_RETURN;
559 $externC = $externC ? qq[extern "C"] : "";
561 # print function header
564 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
565 #XS(XS_${Full_func_name})
569 print Q(<<"EOF") if $ALIAS ;
572 print Q(<<"EOF") if $INTERFACE ;
573 # dXSFUNCTION($ret_type);
576 $cond = ($min_args ? qq(items < $min_args) : 0);
577 } elsif ($min_args == $num_args) {
578 $cond = qq(items != $min_args);
580 $cond = qq(items < $min_args || items > $num_args);
583 print Q(<<"EOF") if $except;
589 { print Q(<<"EOF") if $cond }
591 # Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv)));
594 { print Q(<<"EOF") if $cond }
596 # Perl_croak(aTHX_ "Usage: $pname($report_args)");
599 # cv doesn't seem to be used, in most cases unless we go in
600 # the if of this else
602 # PERL_UNUSED_VAR(cv); /* -W */
605 #gcc -Wall: if an xsub has PPCODE is used
606 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
607 #hence `ax' (setup by dXSARGS) is unused
608 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
609 #but such a move could break third-party extensions
610 print Q(<<"EOF") if $PPCODE;
611 # PERL_UNUSED_VAR(ax); /* -Wall */
614 print Q(<<"EOF") if $PPCODE;
618 # Now do a block of some sort.
621 $cond = ''; # last CASE: condidional
622 push(@line, "$END:");
623 push(@line_no, $line_no[-1]);
627 &CASE_handler if check_keyword("CASE");
632 # do initialization of input variables
640 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
642 print Q(<<"EOF") if $ScopeThisXSUB;
647 if (!$thisdone && defined($class)) {
648 if (defined($static) or $func_name eq 'new') {
650 $var_types{"CLASS"} = "char *";
651 &generate_init("char *", 1, "CLASS");
655 $var_types{"THIS"} = "$class *";
656 &generate_init("$class *", 1, "THIS");
661 if (/^\s*NOT_IMPLEMENTED_YET/) {
662 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
665 if ($ret_type ne "void") {
666 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
668 $args_match{"RETVAL"} = 0;
669 $var_types{"RETVAL"} = $ret_type;
671 if $WantOptimize and $targetable{$type_kind{$ret_type}};
674 if (@fake_INPUT or @fake_INPUT_pre) {
675 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
677 $processing_arg_with_types = 1;
682 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
684 if (check_keyword("PPCODE")) {
686 death ("PPCODE must be last thing") if @line;
687 print "\tLEAVE;\n" if $ScopeThisXSUB;
688 print "\tPUTBACK;\n\treturn;\n";
689 } elsif (check_keyword("CODE")) {
691 } elsif (defined($class) and $func_name eq "DESTROY") {
693 print "delete THIS;\n";
696 if ($ret_type ne "void") {
700 if (defined($static)) {
701 if ($func_name eq 'new') {
702 $func_name = "$class";
706 } elsif (defined($class)) {
707 if ($func_name eq 'new') {
708 $func_name .= " $class";
713 $func_name =~ s/^\Q$args{'s'}//
714 if exists $args{'s'};
715 $func_name = 'XSFUNCTION' if $interface;
716 print "$func_name($func_args);\n";
720 # do output variables
721 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
722 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
723 # $wantRETVAL set if 'RETVAL =' autogenerated
724 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
726 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
728 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
729 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
731 # all OUTPUT done, so now push the return value on the stack
732 if ($gotRETVAL && $RETVAL_code) {
733 print "\t$RETVAL_code\n";
734 } elsif ($gotRETVAL || $wantRETVAL) {
735 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
737 my $type = $ret_type;
739 # 0: type, 1: with_size, 2: how, 3: how_size
740 if ($t and not $t->[1] and $t->[0] eq 'p') {
741 # PUSHp corresponds to setpvn. Treate setpv directly
742 my $what = eval qq("$t->[2]");
745 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
749 my $what = eval qq("$t->[2]");
753 $size = '' unless defined $size;
754 $size = eval qq("$size");
756 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
760 # RETVAL almost never needs SvSETMAGIC()
761 &generate_output($ret_type, 0, 'RETVAL', 0);
765 $xsreturn = 1 if $ret_type ne "void";
768 print "\tXSprePUSH;" if $c and not $prepush_done;
769 print "\tEXTEND(SP,$c);\n" if $c;
771 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
774 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
776 print Q(<<"EOF") if $ScopeThisXSUB;
779 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
783 # print function trailer
787 print Q(<<"EOF") if $except;
790 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
793 if (check_keyword("CASE")) {
794 blurt ("Error: No `CASE:' at top of function")
796 $_ = "CASE: $_"; # Restore CASE: label
799 last if $_ eq "$END:";
800 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
803 print Q(<<"EOF") if $except;
805 # Perl_croak(aTHX_ errbuf);
809 print Q(<<"EOF") unless $PPCODE;
810 # XSRETURN($xsreturn);
813 print Q(<<"EOF") unless $PPCODE;
823 my $newXS = "newXS" ;
826 # Build the prototype string for the xsub
827 if ($ProtoThisXSUB) {
828 $newXS = "newXSproto";
830 if ($ProtoThisXSUB eq 2) {
831 # User has specified empty prototype
833 elsif ($ProtoThisXSUB eq 1) {
835 if ($min_args < $num_args) {
837 $proto_arg[$min_args] .= ";" ;
839 push @proto_arg, "$s\@"
842 $proto = join ("", grep defined, @proto_arg);
845 # User has specified a prototype
846 $proto = $ProtoThisXSUB;
848 $proto = qq{, "$proto"};
852 $XsubAliases{$pname} = 0
853 unless defined $XsubAliases{$pname} ;
854 while ( ($name, $value) = each %XsubAliases) {
855 push(@InitFileCode, Q(<<"EOF"));
856 # cv = newXS(\"$name\", XS_$Full_func_name, file);
857 # XSANY.any_i32 = $value ;
859 push(@InitFileCode, Q(<<"EOF")) if $proto;
860 # sv_setpv((SV*)cv$proto) ;
864 elsif (@Attributes) {
865 push(@InitFileCode, Q(<<"EOF"));
866 # cv = newXS(\"$pname\", XS_$Full_func_name, file);
867 # apply_attrs_string("$Package", cv, "@Attributes", 0);
871 while ( ($name, $value) = each %Interfaces) {
872 $name = "$Package\::$name" unless $name =~ /::/;
873 push(@InitFileCode, Q(<<"EOF"));
874 # cv = newXS(\"$name\", XS_$Full_func_name, file);
875 # $interface_macro_set(cv,$value) ;
877 push(@InitFileCode, Q(<<"EOF")) if $proto;
878 # sv_setpv((SV*)cv$proto) ;
884 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
888 if ($Overload) # make it findable with fetchmethod
891 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
892 #XS(XS_${Packid}_nil)
898 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
899 /* Making a sub named "${Package}::()" allows the package */
900 /* to be findable via fetchmethod(), and causes */
901 /* overload::Overloaded("${Package}") to return true. */
902 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
903 MAKE_FETCHMETHOD_WORK
906 # print initialization routine
915 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
916 #XS(boot_$Module_cname)
924 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
926 print Q(<<"EOF") if $Full_func_name;
927 # char* file = __FILE__;
933 # PERL_UNUSED_VAR(cv); /* -W */
934 # PERL_UNUSED_VAR(items); /* -W */
937 print Q(<<"EOF") if $WantVersionChk ;
938 # XS_VERSION_BOOTCHECK ;
942 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
948 print Q(<<"EOF") if ($Overload);
949 # /* register the overloading (type 'A') magic */
950 # PL_amagic_generation++;
951 # /* The magic for overload gets a GV* via gv_fetchmeth as */
952 # /* mentioned above, and looks in the SV* slot of it for */
953 # /* the "fallback" status. */
955 # get_sv( "${Package}::()", TRUE ),
962 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
968 print "\n /* Initialisation Section */\n\n" ;
971 print "\n /* End of Initialisation Section */\n\n" ;
980 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
985 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
990 sub errors { $errors }
992 sub standard_typemap_locations {
993 # Add all the default typemap locations to the search path
994 my @tm = qw(typemap);
996 my $updir = File::Spec->updir;
997 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
998 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1000 unshift @tm, File::Spec->catfile($dir, 'typemap');
1001 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1003 foreach my $dir (@INC) {
1004 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1005 unshift @tm, $file if -e $file;
1012 $_[0] =~ s/^\s+|\s+$//go ;
1019 # rationalise any '*' by joining them into bunches and removing whitespace
1023 # change multiple whitespace into a single space
1026 # trim leading & trailing whitespace
1027 TrimWhitespace($_) ;
1032 # Input: ($_, @line) == unparsed input.
1033 # Output: ($_, @line) == (rest of line, following lines).
1034 # Return: the matched keyword if found, otherwise 0
1036 $_ = shift(@line) while !/\S/ && @line;
1037 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1041 # the "do" is required for right semantics
1042 do { $_ = shift(@line) } while !/\S/ && @line;
1044 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1045 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1046 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1049 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1055 while (!/\S/ && @line) {
1059 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1066 sub process_keyword($)
1071 &{"${kwd}_handler"}()
1072 while $kwd = check_keyword($pattern) ;
1076 blurt ("Error: `CASE:' after unconditional `CASE:'")
1077 if $condnum && $cond eq '';
1079 TrimWhitespace($cond);
1080 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1085 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1086 last if /^\s*NOT_IMPLEMENTED_YET/;
1087 next unless /\S/; # skip blank lines
1089 TrimWhitespace($_) ;
1092 # remove trailing semicolon if no initialisation
1093 s/\s*;$//g unless /[=;+].*\S/ ;
1095 # Process the length(foo) declarations
1096 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1097 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1098 $lengthof{$2} = $name;
1099 # $islengthof{$name} = $1;
1100 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1103 # check for optional initialisation code
1105 $var_init = $1 if s/\s*([=;+].*)$//s ;
1106 $var_init =~ s/"/\\"/g;
1109 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1110 or blurt("Error: invalid argument declaration '$line'"), next;
1112 # Check for duplicate definitions
1113 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1114 if $arg_list{$var_name}++
1115 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1117 $thisdone |= $var_name eq "THIS";
1118 $retvaldone |= $var_name eq "RETVAL";
1119 $var_types{$var_name} = $var_type;
1120 # XXXX This check is a safeguard against the unfinished conversion of
1121 # generate_init(). When generate_init() is fixed,
1122 # one can use 2-args map_type() unconditionally.
1123 if ($var_type =~ / \( \s* \* \s* \) /x) {
1124 # Function pointers are not yet supported with &output_init!
1125 print "\t" . &map_type($var_type, $var_name);
1128 print "\t" . &map_type($var_type);
1131 $var_num = $args_match{$var_name};
1133 $proto_arg[$var_num] = ProtoString($var_type)
1135 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1136 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1137 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1138 and $var_init !~ /\S/) {
1139 if ($name_printed) {
1142 print "\t$var_name;\n";
1144 } elsif ($var_init =~ /\S/) {
1145 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1146 } elsif ($var_num) {
1147 # generate initialization code
1148 &generate_init($var_type, $var_num, $var_name, $name_printed);
1155 sub OUTPUT_handler {
1156 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1158 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1159 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1162 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1163 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1164 if $outargs{$outarg} ++ ;
1165 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1166 # deal with RETVAL last
1167 $RETVAL_code = $outcode ;
1171 blurt ("Error: OUTPUT $outarg not an argument"), next
1172 unless defined($args_match{$outarg});
1173 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1174 unless defined $var_types{$outarg} ;
1175 $var_num = $args_match{$outarg};
1177 print "\t$outcode\n";
1178 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1180 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1182 delete $in_out{$outarg} # No need to auto-OUTPUT
1183 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1187 sub C_ARGS_handler() {
1188 my $in = merge_section();
1190 TrimWhitespace($in);
1194 sub INTERFACE_MACRO_handler() {
1195 my $in = merge_section();
1197 TrimWhitespace($in);
1198 if ($in =~ /\s/) { # two
1199 ($interface_macro, $interface_macro_set) = split ' ', $in;
1201 $interface_macro = $in;
1202 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1204 $interface = 1; # local
1205 $Interfaces = 1; # global
1208 sub INTERFACE_handler() {
1209 my $in = merge_section();
1211 TrimWhitespace($in);
1213 foreach (split /[\s,]+/, $in) {
1214 $Interfaces{$_} = $_;
1217 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1219 $interface = 1; # local
1220 $Interfaces = 1; # global
1223 sub CLEANUP_handler() { print_section() }
1224 sub PREINIT_handler() { print_section() }
1225 sub POSTCALL_handler() { print_section() }
1226 sub INIT_handler() { print_section() }
1231 my ($orig) = $line ;
1235 # Parse alias definitions
1237 # alias = value alias = value ...
1239 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1241 $orig_alias = $alias ;
1244 # check for optional package definition in the alias
1245 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1247 # check for duplicate alias name & duplicate value
1248 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1249 if defined $XsubAliases{$alias} ;
1251 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1252 if $XsubAliasValues{$value} ;
1255 $XsubAliases{$alias} = $value ;
1256 $XsubAliasValues{$value} = $orig_alias ;
1259 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1263 sub ATTRS_handler ()
1265 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1267 TrimWhitespace($_) ;
1268 push @Attributes, $_;
1272 sub ALIAS_handler ()
1274 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1276 TrimWhitespace($_) ;
1277 GetAliases($_) if $_ ;
1281 sub OVERLOAD_handler()
1283 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1285 TrimWhitespace($_) ;
1286 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1287 $Overload = 1 unless $Overload;
1288 my $overload = "$Package\::(".$1 ;
1290 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1295 sub FALLBACK_handler()
1297 # the rest of the current line should contain either TRUE,
1300 TrimWhitespace($_) ;
1302 TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
1303 FALSE => "PL_sv_no", 0 => "PL_sv_no",
1304 UNDEF => "PL_sv_undef",
1307 # check for valid FALLBACK value
1308 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1310 $Fallback = $map{uc $_} ;
1314 sub REQUIRE_handler ()
1316 # the rest of the current line should contain a version number
1319 TrimWhitespace($Ver) ;
1321 death ("Error: REQUIRE expects a version number")
1324 # check that the version number is of the form n.n
1325 death ("Error: REQUIRE: expected a number, got '$Ver'")
1326 unless $Ver =~ /^\d+(\.\d*)?/ ;
1328 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1329 unless $VERSION >= $Ver ;
1332 sub VERSIONCHECK_handler ()
1334 # the rest of the current line should contain either ENABLE or
1337 TrimWhitespace($_) ;
1339 # check for ENABLE/DISABLE
1340 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1341 unless /^(ENABLE|DISABLE)/i ;
1343 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1344 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1348 sub PROTOTYPE_handler ()
1352 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1353 if $proto_in_this_xsub ++ ;
1355 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1358 TrimWhitespace($_) ;
1359 if ($_ eq 'DISABLE') {
1361 } elsif ($_ eq 'ENABLE') {
1364 # remove any whitespace
1366 death("Error: Invalid prototype '$_'")
1367 unless ValidProtoString($_) ;
1368 $ProtoThisXSUB = C_string($_) ;
1372 # If no prototype specified, then assume empty prototype ""
1373 $ProtoThisXSUB = 2 unless $specified ;
1379 sub SCOPE_handler ()
1381 death("Error: Only 1 SCOPE declaration allowed per xsub")
1382 if $scope_in_this_xsub ++ ;
1384 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1386 TrimWhitespace($_) ;
1387 if ($_ =~ /^DISABLE/i) {
1389 } elsif ($_ =~ /^ENABLE/i) {
1396 sub PROTOTYPES_handler ()
1398 # the rest of the current line should contain either ENABLE or
1401 TrimWhitespace($_) ;
1403 # check for ENABLE/DISABLE
1404 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1405 unless /^(ENABLE|DISABLE)/i ;
1407 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1408 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1413 sub INCLUDE_handler ()
1415 # the rest of the current line should contain a valid filename
1417 TrimWhitespace($_) ;
1419 death("INCLUDE: filename missing")
1422 death("INCLUDE: output pipe is illegal")
1425 # simple minded recursion detector
1426 death("INCLUDE loop detected")
1427 if $IncludedFiles{$_} ;
1429 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1431 # Save the current file context.
1434 LastLine => $lastline,
1435 LastLineNo => $lastline_no,
1437 LineNo => \@line_no,
1438 Filename => $filename,
1445 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1449 #/* INCLUDE: Including '$_' from '$filename' */
1455 # Prime the pump by reading the first
1458 # skip leading blank lines
1460 last unless /^\s*$/ ;
1470 return 0 unless $XSStack[-1]{type} eq 'file' ;
1472 my $data = pop @XSStack ;
1473 my $ThisFile = $filename ;
1474 my $isPipe = ($filename =~ /\|\s*$/) ;
1476 -- $IncludedFiles{$filename}
1481 $FH = $data->{Handle} ;
1482 $filename = $data->{Filename} ;
1483 $lastline = $data->{LastLine} ;
1484 $lastline_no = $data->{LastLineNo} ;
1485 @line = @{ $data->{Line} } ;
1486 @line_no = @{ $data->{LineNo} } ;
1488 if ($isPipe and $? ) {
1490 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1496 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1503 sub ValidProtoString ($)
1507 if ( $string =~ /^$proto_re+$/ ) {
1518 $string =~ s[\\][\\\\]g ;
1526 $proto_letter{$type} or "\$" ;
1530 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1532 my ($cpp, $cpplevel);
1534 if ($cpp =~ /^\#\s*if/) {
1536 } elsif (!$cpplevel) {
1537 Warn("Warning: #else/elif/endif without #if in this function");
1538 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1539 if $XSStack[-1]{type} eq 'if';
1541 } elsif ($cpp =~ /^\#\s*endif/) {
1545 Warn("Warning: #if without #endif in this function") if $cpplevel;
1553 $text =~ s/\[\[/{/g;
1554 $text =~ s/\]\]/}/g;
1558 # Read next xsub into @line from ($lastline, <$FH>).
1561 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1562 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1565 return PopFile() if !defined $lastline;
1568 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1570 $Package = defined($2) ? $2 : ''; # keep -w happy
1571 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1572 $Prefix = quotemeta $Prefix ;
1573 ($Module_cname = $Module) =~ s/\W/_/g;
1574 ($Packid = $Package) =~ tr/:/_/;
1575 $Packprefix = $Package;
1576 $Packprefix .= "::" if $Packprefix ne "";
1581 # Skip embedded PODs
1582 while ($lastline =~ /^=/) {
1583 while ($lastline = <$FH>) {
1584 last if ($lastline =~ /^=cut\s*$/);
1586 death ("Error: Unterminated pod") unless $lastline;
1589 $lastline =~ s/^\s+$//;
1591 if ($lastline !~ /^\s*#/ ||
1593 # ANSI: if ifdef ifndef elif else endif define undef
1595 # gcc: warning include_next
1597 # others: ident (gcc notes that some cpps have this one)
1598 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1599 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1600 push(@line, $lastline);
1601 push(@line_no, $lastline_no) ;
1604 # Read next line and continuation lines
1605 last unless defined($lastline = <$FH>);
1608 $lastline .= $tmp_line
1609 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1612 $lastline =~ s/^\s+$//;
1614 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1619 local($type, $num, $var, $init, $name_printed) = @_;
1620 local($arg) = "ST(" . ($num - 1) . ")";
1622 if ( $init =~ /^=/ ) {
1623 if ($name_printed) {
1624 eval qq/print " $init\\n"/;
1626 eval qq/print "\\t$var $init\\n"/;
1630 if ( $init =~ s/^\+// && $num ) {
1631 &generate_init($type, $num, $var, $name_printed);
1632 } elsif ($name_printed) {
1636 eval qq/print "\\t$var;\\n"/;
1640 $deferred .= eval qq/"\\n\\t$init\\n"/;
1647 # work out the line number
1648 my $line_no = $line_no[@line_no - @line -1] ;
1650 print STDERR "@_ in $filename, line $line_no\n" ;
1666 local($type, $num, $var) = @_;
1667 local($arg) = "ST(" . ($num - 1) . ")";
1668 local($argoff) = $num - 1;
1672 $type = TidyType($type) ;
1673 blurt("Error: '$type' not in typemap"), return
1674 unless defined($type_kind{$type});
1676 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1677 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1678 $tk = $type_kind{$type};
1679 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1680 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1681 print "\t$var" unless $name_printed;
1682 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1683 die "default value not supported with length(NAME) supplied"
1684 if defined $defaults{$var};
1687 $type =~ tr/:/_/ unless $hiertype;
1688 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1689 unless defined $input_expr{$tk} ;
1690 $expr = $input_expr{$tk};
1691 if ($expr =~ /DO_ARRAY_ELEM/) {
1692 blurt("Error: '$subtype' not in typemap"), return
1693 unless defined($type_kind{$subtype});
1694 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1695 unless defined $input_expr{$type_kind{$subtype}} ;
1696 $subexpr = $input_expr{$type_kind{$subtype}};
1697 $subexpr =~ s/\$type/\$subtype/g;
1698 $subexpr =~ s/ntype/subtype/g;
1699 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1700 $subexpr =~ s/\n\t/\n\t\t/g;
1701 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1702 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1703 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1705 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1708 if (defined($defaults{$var})) {
1709 $expr =~ s/(\t+)/$1 /g;
1711 if ($name_printed) {
1714 eval qq/print "\\t$var;\\n"/;
1717 if ($defaults{$var} eq 'NO_INIT') {
1718 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1720 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1723 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1724 if ($name_printed) {
1727 eval qq/print "\\t$var;\\n"/;
1730 $deferred .= eval qq/"\\n$expr;\\n"/;
1733 die "panic: do not know how to handle this branch for function pointers"
1735 eval qq/print "$expr;\\n"/;
1740 sub generate_output {
1741 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1742 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1743 local($argoff) = $num - 1;
1746 $type = TidyType($type) ;
1747 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1748 print "\t$arg = sv_newmortal();\n";
1749 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1750 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1752 blurt("Error: '$type' not in typemap"), return
1753 unless defined($type_kind{$type});
1754 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1755 unless defined $output_expr{$type_kind{$type}} ;
1756 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1757 $ntype =~ s/\(\)//g;
1758 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1759 $expr = $output_expr{$type_kind{$type}};
1760 if ($expr =~ /DO_ARRAY_ELEM/) {
1761 blurt("Error: '$subtype' not in typemap"), return
1762 unless defined($type_kind{$subtype});
1763 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1764 unless defined $output_expr{$type_kind{$subtype}} ;
1765 $subexpr = $output_expr{$type_kind{$subtype}};
1766 $subexpr =~ s/ntype/subtype/g;
1767 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1768 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1769 $subexpr =~ s/\n\t/\n\t\t/g;
1770 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1771 eval "print qq\a$expr\a";
1773 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1774 } elsif ($var eq 'RETVAL') {
1775 if ($expr =~ /^\t\$arg = new/) {
1776 # We expect that $arg has refcnt 1, so we need to
1778 eval "print qq\a$expr\a";
1780 print "\tsv_2mortal(ST($num));\n";
1781 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1782 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1783 # We expect that $arg has refcnt >=1, so we need
1785 eval "print qq\a$expr\a";
1787 print "\tsv_2mortal(ST(0));\n";
1788 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1790 # Just hope that the entry would safely write it
1791 # over an already mortalized value. By
1792 # coincidence, something like $arg = &sv_undef
1794 print "\tST(0) = sv_newmortal();\n";
1795 eval "print qq\a$expr\a";
1797 # new mortals don't have set magic
1799 } elsif ($do_push) {
1800 print "\tPUSHs(sv_newmortal());\n";
1802 eval "print qq\a$expr\a";
1804 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1805 } elsif ($arg =~ /^ST\(\d+\)$/) {
1806 eval "print qq\a$expr\a";
1808 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1814 my($type, $varname) = @_;
1816 # C++ has :: in types too so skip this
1817 $type =~ tr/:/_/ unless $hiertype;
1818 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1820 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1821 (substr $type, pos $type, 0) = " $varname ";
1823 $type .= "\t$varname";
1830 #########################################################
1832 ExtUtils::ParseXS::CountLines;
1834 use vars qw($SECTION_END_MARKER);
1837 my ($class, $cfile, $fh) = @_;
1838 $cfile =~ s/\\/\\\\/g;
1839 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1841 return bless {buffer => '',
1850 $self->{buffer} .= $_;
1851 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1853 ++ $self->{line_no};
1854 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1855 print {$self->{fh}} $line;
1863 $self->PRINT(sprintf($fmt, @_));
1867 # Not necessary if we're careful to end with a "\n"
1869 print {$self->{fh}} $self->{buffer};
1873 # This sub does nothing, but is necessary for references to be released.
1877 return $SECTION_END_MARKER;
1886 ExtUtils::ParseXS - converts Perl XS code into C code
1890 use ExtUtils::ParseXS qw(process_file);
1892 process_file( filename => 'foo.xs' );
1894 process_file( filename => 'foo.xs',
1897 typemap => 'path/to/typemap',
1908 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1909 necessary to let C functions manipulate Perl values and creates the glue
1910 necessary to let Perl access those functions. The compiler uses typemaps to
1911 determine how to map C function parameters and variables to Perl values.
1913 The compiler will search for typemap files called I<typemap>. It will use
1914 the following search path to find default typemaps, with the rightmost
1915 typemap taking precedence.
1917 ../../../typemap:../../typemap:../typemap:typemap
1921 None by default. C<process_file()> may be exported upon request.
1930 This function processes an XS file and sends output to a C file.
1931 Named parameters control how the processing is done. The following
1932 parameters are accepted:
1938 Adds C<extern "C"> to the C code. Default is false.
1942 Retains C<::> in type names so that C++ hierarchical types can be
1943 mapped. Default is false.
1947 Adds exception handling stubs to the C code. Default is false.
1951 Indicates that a user-supplied typemap should take precedence over the
1952 default typemaps. A single typemap may be specified as a string, or
1953 multiple typemaps can be specified in an array reference, with the
1954 last typemap having the highest precedence.
1958 Generates prototype code for all xsubs. Default is false.
1960 =item B<versioncheck>
1962 Makes sure at run time that the object file (derived from the C<.xs>
1963 file) and the C<.pm> files have the same version number. Default is
1966 =item B<linenumbers>
1968 Adds C<#line> directives to the C output so error messages will look
1969 like they came from the original XS file. Default is true.
1973 Enables certain optimizations. The only optimization that is currently
1974 affected is the use of I<target>s by the output C code (see L<perlguts>).
1975 Not optimizing may significantly slow down the generated code, but this is the way
1976 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
1980 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
1981 declarations. Default is true.
1985 Enable recognition of ANSI-like descriptions of function signature.
1990 I have no clue what this does. Strips function prefixes?
1996 This function returns the number of [a certain kind of] errors
1997 encountered during processing of the XS file.
2003 Based on xsubpp code, written by Larry Wall.
2005 Maintained by Ken Williams, <ken@mathforum.org>
2009 Copyright 2002-2003 Ken Williams. All rights reserved.
2011 This library is free software; you can redistribute it and/or
2012 modify it under the same terms as Perl itself.
2014 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2015 Porters, which was released under the same license terms.
2019 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.