1 package ExtUtils::ParseXS;
3 use 5.006; # We use /??{}/ in regexes
13 @EXPORT_OK = qw(process_file);
15 # use strict; # One of these days...
17 my(@XSStack); # Stack of conditionals and INCLUDEs
18 my($XSS_work_idx, $cpp_next_tmp);
20 use vars qw($VERSION);
23 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
24 $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
25 $WantOptimize $process_inout $process_argtypes @tm
26 $dir $filename $filepathname %IncludedFiles
27 %type_kind %proto_letter
28 %targetable $BLOCK_re $lastline $lastline_no
29 $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
30 $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
31 $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
32 $ProtoThisXSUB $ScopeThisXSUB $xsreturn
33 @line_no $ret_type $func_header $orig_args
34 ); # Add these just to get compilation to happen.
39 # Allow for $package->process_file(%hash) in the future
40 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
42 $ProtoUsed = exists $args{prototypes};
46 # 'C++' => 0, # Doesn't seem to *do* anything...
64 my ($Is_VMS, $SymSet);
67 # Establish set of global symbols with max length 28, since xsubpp
68 # will later add the 'XS_' prefix.
69 require ExtUtils::XSSymSet;
70 $SymSet = new ExtUtils::XSSymSet 28;
72 @XSStack = ({type => 'none'});
73 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
75 $FH = Symbol::gensym();
76 $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
79 $Fallback = 'PL_sv_undef';
81 # Most of the 1500 lines below uses these globals. We'll have to
82 # clean this up sometime, probably. For now, we just pull them out
85 $cplusplus = $args{'C++'};
86 $hiertype = $args{hiertype};
87 $WantPrototypes = $args{prototypes};
88 $WantVersionChk = $args{versioncheck};
89 $except = $args{except} ? ' TRY' : '';
90 $WantLineNumbers = $args{linenumbers};
91 $WantOptimize = $args{optimize};
92 $process_inout = $args{inout};
93 $process_argtypes = $args{argtypes};
94 @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
96 for ($args{filename}) {
97 die "Missing required parameter 'filename'" unless $_;
99 ($dir, $filename) = (dirname($_), basename($_));
100 $filepathname =~ s/\\/\\\\/g;
101 $IncludedFiles{$_}++;
104 # Open the input file
105 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
107 # Open the output file if given as a string. If they provide some
108 # other kind of reference, trust them that we can print to it.
109 if (not ref $args{output}) {
110 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
111 $args{outfile} = $args{output};
115 # Really, we shouldn't have to chdir() or select() in the first
116 # place. For now, just save & restore.
117 my $orig_cwd = cwd();
118 my $orig_fh = select();
122 my $csuffix = $args{csuffix};
124 if ($WantLineNumbers) {
126 if ( $args{outfile} ) {
127 $cfile = $args{outfile};
129 $cfile = $args{filename};
130 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
132 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
133 select PSEUDO_STDOUT;
135 select $args{output};
138 foreach my $typemap (@tm) {
139 die "Can't find $typemap in $pwd\n" unless -r $typemap;
142 push @tm, standard_typemap_locations();
144 foreach my $typemap (@tm) {
145 next unless -f $typemap ;
146 # skip directories, binary files etc.
147 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
149 open(TYPEMAP, $typemap)
150 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
151 my $mode = 'Typemap';
153 my $current = \$junk;
156 my $line_no = $. + 1;
158 $mode = 'Input'; $current = \$junk; next;
161 $mode = 'Output'; $current = \$junk; next;
163 if (/^TYPEMAP\s*$/) {
164 $mode = 'Typemap'; $current = \$junk; next;
166 if ($mode eq 'Typemap') {
170 # skip blank lines and comment lines
171 next if /^$/ or /^#/ ;
172 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
173 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
174 $type = TidyType($type) ;
175 $type_kind{$type} = $kind ;
176 # prototype defaults to '$'
177 $proto = "\$" unless $proto ;
178 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
179 unless ValidProtoString($proto) ;
180 $proto_letter{$type} = C_string($proto) ;
183 } elsif ($mode eq 'Input') {
185 $input_expr{$_} = '';
186 $current = \$input_expr{$_};
189 $output_expr{$_} = '';
190 $current = \$output_expr{$_};
196 foreach my $key (keys %input_expr) {
197 $input_expr{$key} =~ s/;*\s+\z//;
201 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
202 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
203 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
205 foreach my $key (keys %output_expr) {
208 my ($t, $with_size, $arg, $sarg) =
209 ($output_expr{$key} =~
210 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
211 \s* \( \s* $cast \$arg \s* ,
212 \s* ( (??{ $bal }) ) # Set from
213 ( (??{ $size }) )? # Possible sizeof set-from
216 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
219 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
221 # Match an XS keyword
222 $BLOCK_re= '\s*(' . join('|', qw(
223 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
224 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
225 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
229 our ($C_group_rex, $C_arg);
230 # Group in C (no support for comments or literals)
231 $C_group_rex = qr/ [({\[]
232 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
234 # Chunk in C without comma at toplevel (no comments):
235 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
236 | (??{ $C_group_rex })
237 | " (?: (?> [^\\"]+ )
239 )* " # String literal
240 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
243 # Identify the version of xsubpp used
246 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
247 * contents of $filename. Do not edit this file, edit $filename instead.
249 * ANY CHANGES MADE HERE WILL BE LOST!
256 print("#line 1 \"$filepathname\"\n")
262 my $podstartline = $.;
265 # We can't just write out a /* */ comment, as our embedded
266 # POD might itself be in a comment. We can't put a /**/
267 # comment inside #if 0, as the C standard says that the source
268 # file is decomposed into preprocessing characters in the stage
269 # before preprocessing commands are executed.
270 # I don't want to leave the text as barewords, because the spec
271 # isn't clear whether macros are expanded before or after
272 # preprocessing commands are executed, and someone pathological
273 # may just have defined one of the 3 words as a macro that does
274 # something strange. Multiline strings are illegal in C, so
275 # the "" we write must be a string literal. And they aren't
276 # concatenated until 2 steps later, so we are safe.
278 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
279 printf("#line %d \"$filepathname\"\n", $. + 1)
285 # At this point $. is at end of file so die won't state the start
286 # of the problem, and as we haven't yet read any lines &death won't
287 # show the correct line in the message either.
288 die ("Error: Unterminated pod in $filename, line $podstartline\n")
291 last if ($Package, $Prefix) =
292 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
296 unless (defined $_) {
297 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
298 exit 0; # Not a fatal error for the caller process
302 #ifndef PERL_UNUSED_VAR
303 # define PERL_UNUSED_VAR(var) if (0) var = var
308 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
314 while (fetch_para()) {
315 # Print initial preprocessor statements and blank lines
316 while (@line && $line[0] !~ /^[^\#]/) {
317 my $line = shift(@line);
319 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
321 if ($statement eq 'if') {
322 $XSS_work_idx = @XSStack;
323 push(@XSStack, {type => 'if'});
325 death ("Error: `$statement' with no matching `if'")
326 if $XSStack[-1]{type} ne 'if';
327 if ($XSStack[-1]{varname}) {
328 push(@InitFileCode, "#endif\n");
329 push(@BootCode, "#endif");
332 my(@fns) = keys %{$XSStack[-1]{functions}};
333 if ($statement ne 'endif') {
334 # Hide the functions defined in other #if branches, and reset.
335 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
336 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
338 my($tmp) = pop(@XSStack);
339 0 while (--$XSS_work_idx
340 && $XSStack[$XSS_work_idx]{type} ne 'if');
341 # Keep all new defined functions
342 push(@fns, keys %{$tmp->{other_functions}});
343 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
348 next PARAGRAPH unless @line;
350 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
351 # We are inside an #if, but have not yet #defined its xsubpp variable.
352 print "#define $cpp_next_tmp 1\n\n";
353 push(@InitFileCode, "#if $cpp_next_tmp\n");
354 push(@BootCode, "#if $cpp_next_tmp");
355 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
358 death ("Code is not inside a function"
359 ." (maybe last function was ended by a blank line "
360 ." followed by a statement on column one?)")
361 if $line[0] =~ /^\s/;
363 my ($class, $externC, $static, $elipsis, $wantRETVAL, $RETVAL_no_return);
364 my (@fake_INPUT_pre); # For length(s) generated variables
367 # initialize info arrays
373 undef($processing_arg_with_types) ;
374 undef(%argtype_seen) ;
378 undef($proto_in_this_xsub) ;
379 undef($scope_in_this_xsub) ;
381 undef($prepush_done);
382 $interface_macro = 'XSINTERFACE_FUNC' ;
383 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
384 $ProtoThisXSUB = $WantPrototypes ;
389 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
390 &{"${kwd}_handler"}() ;
391 next PARAGRAPH unless @line ;
395 if (check_keyword("BOOT")) {
397 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
398 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
399 push (@BootCode, @line, "") ;
404 # extract return type, function name and arguments
405 ($ret_type) = TidyType($_);
406 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
408 # Allow one-line ANSI-like declaration
411 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
413 # a function definition needs at least 2 lines
414 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
417 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
418 $static = 1 if $ret_type =~ s/^static\s+//;
420 $func_header = shift(@line);
421 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
422 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
424 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
425 $class = "$4 $class" if $4;
426 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
427 ($clean_func_name = $func_name) =~ s/^$Prefix//;
428 $Full_func_name = "${Packid}_$clean_func_name";
430 $Full_func_name = $SymSet->addsym($Full_func_name);
433 # Check for duplicate function definition
434 for my $tmp (@XSStack) {
435 next unless defined $tmp->{functions}{$Full_func_name};
436 Warn("Warning: duplicate function definition '$clean_func_name' detected");
439 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
440 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
443 $orig_args =~ s/\\\s*/ /g; # process line continuations
446 my %only_C_inlist; # Not in the signature of Perl function
447 if ($process_argtypes and $orig_args =~ /\S/) {
448 my $args = "$orig_args ,";
449 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
450 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
454 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
455 my ($pre, $name) = ($arg =~ /(.*?) \s*
456 \b ( \w+ | length\( \s*\w+\s* \) )
458 next unless defined($pre) && length($pre);
461 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
463 $out_type = $type if $type ne 'IN';
464 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
465 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
468 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
469 $name = "XSauto_length_of_$1";
471 die "Default value on length() argument: `$_'"
474 if (length $pre or $islength) { # Has a type
476 push @fake_INPUT_pre, $arg;
478 push @fake_INPUT, $arg;
480 # warn "pushing '$arg'\n";
481 $argtype_seen{$name}++;
482 $_ = "$name$default"; # Assigns to @args
484 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
485 push @outlist, $name if $out_type =~ /OUTLIST$/;
486 $in_out{$name} = $out_type if $out_type;
489 @args = split(/\s*,\s*/, $orig_args);
490 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
493 @args = split(/\s*,\s*/, $orig_args);
495 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
497 next if $out_type eq 'IN';
498 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
499 push @outlist, $name if $out_type =~ /OUTLIST$/;
500 $in_out{$_} = $out_type;
504 if (defined($class)) {
505 my $arg0 = ((defined($static) or $func_name eq 'new')
507 unshift(@args, $arg0);
508 ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
513 my $report_args = '';
514 foreach my $i (0 .. $#args) {
515 if ($args[$i] =~ s/\.\.\.//) {
517 if ($args[$i] eq '' && $i == $#args) {
518 $report_args .= ", ...";
523 if ($only_C_inlist{$args[$i]}) {
524 push @args_num, undef;
526 push @args_num, ++$num_args;
527 $report_args .= ", $args[$i]";
529 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
532 $defaults{$args[$i]} = $2;
533 $defaults{$args[$i]} =~ s/"/\\"/g;
535 $proto_arg[$i+1] = '$' ;
537 $min_args = $num_args - $extra_args;
538 $report_args =~ s/"/\\"/g;
539 $report_args =~ s/^,\s+//;
540 my @func_args = @args;
541 shift @func_args if defined($class);
544 s/^/&/ if $in_out{$_};
546 $func_args = join(", ", @func_args);
547 @args_match{@args} = @args_num;
549 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
550 $CODE = grep(/^\s*CODE\s*:/, @line);
551 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
552 # to set explicit return values.
553 $EXPLICIT_RETURN = ($CODE &&
554 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
555 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
556 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
558 $xsreturn = 1 if $EXPLICIT_RETURN;
560 $externC = $externC ? qq[extern "C"] : "";
562 # print function header
565 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
566 #XS(XS_${Full_func_name})
570 print Q(<<"EOF") if $ALIAS ;
573 print Q(<<"EOF") if $INTERFACE ;
574 # dXSFUNCTION($ret_type);
577 $cond = ($min_args ? qq(items < $min_args) : 0);
578 } elsif ($min_args == $num_args) {
579 $cond = qq(items != $min_args);
581 $cond = qq(items < $min_args || items > $num_args);
584 print Q(<<"EOF") if $except;
590 { print Q(<<"EOF") if $cond }
592 # Perl_croak(aTHX_ "Usage: %s($report_args)", GvNAME(CvGV(cv)));
595 { print Q(<<"EOF") if $cond }
597 # Perl_croak(aTHX_ "Usage: $pname($report_args)");
600 # cv doesn't seem to be used, in most cases unless we go in
601 # the if of this else
603 # PERL_UNUSED_VAR(cv); /* -W */
606 #gcc -Wall: if an xsub has PPCODE is used
607 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
608 #hence `ax' (setup by dXSARGS) is unused
609 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
610 #but such a move could break third-party extensions
611 print Q(<<"EOF") if $PPCODE;
612 # PERL_UNUSED_VAR(ax); /* -Wall */
615 print Q(<<"EOF") if $PPCODE;
619 # Now do a block of some sort.
622 $cond = ''; # last CASE: condidional
623 push(@line, "$END:");
624 push(@line_no, $line_no[-1]);
628 &CASE_handler if check_keyword("CASE");
633 # do initialization of input variables
641 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
643 print Q(<<"EOF") if $ScopeThisXSUB;
648 if (!$thisdone && defined($class)) {
649 if (defined($static) or $func_name eq 'new') {
651 $var_types{"CLASS"} = "char *";
652 &generate_init("char *", 1, "CLASS");
656 $var_types{"THIS"} = "$class *";
657 &generate_init("$class *", 1, "THIS");
662 if (/^\s*NOT_IMPLEMENTED_YET/) {
663 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
666 if ($ret_type ne "void") {
667 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
669 $args_match{"RETVAL"} = 0;
670 $var_types{"RETVAL"} = $ret_type;
672 if $WantOptimize and $targetable{$type_kind{$ret_type}};
675 if (@fake_INPUT or @fake_INPUT_pre) {
676 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
678 $processing_arg_with_types = 1;
683 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
685 if (check_keyword("PPCODE")) {
687 death ("PPCODE must be last thing") if @line;
688 print "\tLEAVE;\n" if $ScopeThisXSUB;
689 print "\tPUTBACK;\n\treturn;\n";
690 } elsif (check_keyword("CODE")) {
692 } elsif (defined($class) and $func_name eq "DESTROY") {
694 print "delete THIS;\n";
697 if ($ret_type ne "void") {
701 if (defined($static)) {
702 if ($func_name eq 'new') {
703 $func_name = "$class";
707 } elsif (defined($class)) {
708 if ($func_name eq 'new') {
709 $func_name .= " $class";
714 $func_name =~ s/^\Q$args{'s'}//
715 if exists $args{'s'};
716 $func_name = 'XSFUNCTION' if $interface;
717 print "$func_name($func_args);\n";
721 # do output variables
722 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
723 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
724 # $wantRETVAL set if 'RETVAL =' autogenerated
725 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
727 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
729 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
730 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
732 # all OUTPUT done, so now push the return value on the stack
733 if ($gotRETVAL && $RETVAL_code) {
734 print "\t$RETVAL_code\n";
735 } elsif ($gotRETVAL || $wantRETVAL) {
736 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
738 my $type = $ret_type;
740 # 0: type, 1: with_size, 2: how, 3: how_size
741 if ($t and not $t->[1] and $t->[0] eq 'p') {
742 # PUSHp corresponds to setpvn. Treate setpv directly
743 my $what = eval qq("$t->[2]");
746 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
750 my $what = eval qq("$t->[2]");
754 $size = '' unless defined $size;
755 $size = eval qq("$size");
757 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
761 # RETVAL almost never needs SvSETMAGIC()
762 &generate_output($ret_type, 0, 'RETVAL', 0);
766 $xsreturn = 1 if $ret_type ne "void";
769 print "\tXSprePUSH;" if $c and not $prepush_done;
770 print "\tEXTEND(SP,$c);\n" if $c;
772 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
775 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
777 print Q(<<"EOF") if $ScopeThisXSUB;
780 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
784 # print function trailer
788 print Q(<<"EOF") if $except;
791 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
794 if (check_keyword("CASE")) {
795 blurt ("Error: No `CASE:' at top of function")
797 $_ = "CASE: $_"; # Restore CASE: label
800 last if $_ eq "$END:";
801 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
804 print Q(<<"EOF") if $except;
806 # Perl_croak(aTHX_ errbuf);
810 print Q(<<"EOF") unless $PPCODE;
811 # XSRETURN($xsreturn);
814 print Q(<<"EOF") unless $PPCODE;
824 my $newXS = "newXS" ;
827 # Build the prototype string for the xsub
828 if ($ProtoThisXSUB) {
829 $newXS = "newXSproto";
831 if ($ProtoThisXSUB eq 2) {
832 # User has specified empty prototype
834 elsif ($ProtoThisXSUB eq 1) {
836 if ($min_args < $num_args) {
838 $proto_arg[$min_args] .= ";" ;
840 push @proto_arg, "$s\@"
843 $proto = join ("", grep defined, @proto_arg);
846 # User has specified a prototype
847 $proto = $ProtoThisXSUB;
849 $proto = qq{, "$proto"};
853 $XsubAliases{$pname} = 0
854 unless defined $XsubAliases{$pname} ;
855 while ( ($name, $value) = each %XsubAliases) {
856 push(@InitFileCode, Q(<<"EOF"));
857 # cv = newXS(\"$name\", XS_$Full_func_name, file);
858 # XSANY.any_i32 = $value ;
860 push(@InitFileCode, Q(<<"EOF")) if $proto;
861 # sv_setpv((SV*)cv$proto) ;
865 elsif (@Attributes) {
866 push(@InitFileCode, Q(<<"EOF"));
867 # cv = newXS(\"$pname\", XS_$Full_func_name, file);
868 # apply_attrs_string("$Package", cv, "@Attributes", 0);
872 while ( ($name, $value) = each %Interfaces) {
873 $name = "$Package\::$name" unless $name =~ /::/;
874 push(@InitFileCode, Q(<<"EOF"));
875 # cv = newXS(\"$name\", XS_$Full_func_name, file);
876 # $interface_macro_set(cv,$value) ;
878 push(@InitFileCode, Q(<<"EOF")) if $proto;
879 # sv_setpv((SV*)cv$proto) ;
885 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
889 if ($Overload) # make it findable with fetchmethod
892 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
893 #XS(XS_${Packid}_nil)
899 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
900 /* Making a sub named "${Package}::()" allows the package */
901 /* to be findable via fetchmethod(), and causes */
902 /* overload::Overloaded("${Package}") to return true. */
903 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
904 MAKE_FETCHMETHOD_WORK
907 # print initialization routine
916 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
917 #XS(boot_$Module_cname)
925 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
927 print Q(<<"EOF") if $Full_func_name;
928 # char* file = __FILE__;
934 # PERL_UNUSED_VAR(cv); /* -W */
935 # PERL_UNUSED_VAR(items); /* -W */
938 print Q(<<"EOF") if $WantVersionChk ;
939 # XS_VERSION_BOOTCHECK ;
943 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
949 print Q(<<"EOF") if ($Overload);
950 # /* register the overloading (type 'A') magic */
951 # PL_amagic_generation++;
952 # /* The magic for overload gets a GV* via gv_fetchmeth as */
953 # /* mentioned above, and looks in the SV* slot of it for */
954 # /* the "fallback" status. */
956 # get_sv( "${Package}::()", TRUE ),
963 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
969 print "\n /* Initialisation Section */\n\n" ;
972 print "\n /* End of Initialisation Section */\n\n" ;
981 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
986 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
992 sub errors { $errors }
994 sub standard_typemap_locations {
995 # Add all the default typemap locations to the search path
996 my @tm = qw(typemap);
998 my $updir = File::Spec->updir;
999 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1000 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1002 unshift @tm, File::Spec->catfile($dir, 'typemap');
1003 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1005 foreach my $dir (@INC) {
1006 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1007 unshift @tm, $file if -e $file;
1014 $_[0] =~ s/^\s+|\s+$//go ;
1021 # rationalise any '*' by joining them into bunches and removing whitespace
1025 # change multiple whitespace into a single space
1028 # trim leading & trailing whitespace
1029 TrimWhitespace($_) ;
1034 # Input: ($_, @line) == unparsed input.
1035 # Output: ($_, @line) == (rest of line, following lines).
1036 # Return: the matched keyword if found, otherwise 0
1038 $_ = shift(@line) while !/\S/ && @line;
1039 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1043 # the "do" is required for right semantics
1044 do { $_ = shift(@line) } while !/\S/ && @line;
1046 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1047 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1048 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1051 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1057 while (!/\S/ && @line) {
1061 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1068 sub process_keyword($)
1073 &{"${kwd}_handler"}()
1074 while $kwd = check_keyword($pattern) ;
1078 blurt ("Error: `CASE:' after unconditional `CASE:'")
1079 if $condnum && $cond eq '';
1081 TrimWhitespace($cond);
1082 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1087 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1088 last if /^\s*NOT_IMPLEMENTED_YET/;
1089 next unless /\S/; # skip blank lines
1091 TrimWhitespace($_) ;
1094 # remove trailing semicolon if no initialisation
1095 s/\s*;$//g unless /[=;+].*\S/ ;
1097 # Process the length(foo) declarations
1098 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1099 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1100 $lengthof{$2} = $name;
1101 # $islengthof{$name} = $1;
1102 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1105 # check for optional initialisation code
1107 $var_init = $1 if s/\s*([=;+].*)$//s ;
1108 $var_init =~ s/"/\\"/g;
1111 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1112 or blurt("Error: invalid argument declaration '$line'"), next;
1114 # Check for duplicate definitions
1115 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1116 if $arg_list{$var_name}++
1117 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1119 $thisdone |= $var_name eq "THIS";
1120 $retvaldone |= $var_name eq "RETVAL";
1121 $var_types{$var_name} = $var_type;
1122 # XXXX This check is a safeguard against the unfinished conversion of
1123 # generate_init(). When generate_init() is fixed,
1124 # one can use 2-args map_type() unconditionally.
1125 if ($var_type =~ / \( \s* \* \s* \) /x) {
1126 # Function pointers are not yet supported with &output_init!
1127 print "\t" . &map_type($var_type, $var_name);
1130 print "\t" . &map_type($var_type);
1133 $var_num = $args_match{$var_name};
1135 $proto_arg[$var_num] = ProtoString($var_type)
1137 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1138 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1139 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1140 and $var_init !~ /\S/) {
1141 if ($name_printed) {
1144 print "\t$var_name;\n";
1146 } elsif ($var_init =~ /\S/) {
1147 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1148 } elsif ($var_num) {
1149 # generate initialization code
1150 &generate_init($var_type, $var_num, $var_name, $name_printed);
1157 sub OUTPUT_handler {
1158 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1160 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1161 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1164 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1165 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1166 if $outargs{$outarg} ++ ;
1167 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1168 # deal with RETVAL last
1169 $RETVAL_code = $outcode ;
1173 blurt ("Error: OUTPUT $outarg not an argument"), next
1174 unless defined($args_match{$outarg});
1175 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1176 unless defined $var_types{$outarg} ;
1177 $var_num = $args_match{$outarg};
1179 print "\t$outcode\n";
1180 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1182 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1184 delete $in_out{$outarg} # No need to auto-OUTPUT
1185 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1189 sub C_ARGS_handler() {
1190 my $in = merge_section();
1192 TrimWhitespace($in);
1196 sub INTERFACE_MACRO_handler() {
1197 my $in = merge_section();
1199 TrimWhitespace($in);
1200 if ($in =~ /\s/) { # two
1201 ($interface_macro, $interface_macro_set) = split ' ', $in;
1203 $interface_macro = $in;
1204 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1206 $interface = 1; # local
1207 $Interfaces = 1; # global
1210 sub INTERFACE_handler() {
1211 my $in = merge_section();
1213 TrimWhitespace($in);
1215 foreach (split /[\s,]+/, $in) {
1216 $Interfaces{$_} = $_;
1219 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1221 $interface = 1; # local
1222 $Interfaces = 1; # global
1225 sub CLEANUP_handler() { print_section() }
1226 sub PREINIT_handler() { print_section() }
1227 sub POSTCALL_handler() { print_section() }
1228 sub INIT_handler() { print_section() }
1233 my ($orig) = $line ;
1237 # Parse alias definitions
1239 # alias = value alias = value ...
1241 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1243 $orig_alias = $alias ;
1246 # check for optional package definition in the alias
1247 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1249 # check for duplicate alias name & duplicate value
1250 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1251 if defined $XsubAliases{$alias} ;
1253 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1254 if $XsubAliasValues{$value} ;
1257 $XsubAliases{$alias} = $value ;
1258 $XsubAliasValues{$value} = $orig_alias ;
1261 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1265 sub ATTRS_handler ()
1267 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1269 TrimWhitespace($_) ;
1270 push @Attributes, $_;
1274 sub ALIAS_handler ()
1276 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1278 TrimWhitespace($_) ;
1279 GetAliases($_) if $_ ;
1283 sub OVERLOAD_handler()
1285 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1287 TrimWhitespace($_) ;
1288 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1289 $Overload = 1 unless $Overload;
1290 my $overload = "$Package\::(".$1 ;
1292 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1297 sub FALLBACK_handler()
1299 # the rest of the current line should contain either TRUE,
1302 TrimWhitespace($_) ;
1304 TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
1305 FALSE => "PL_sv_no", 0 => "PL_sv_no",
1306 UNDEF => "PL_sv_undef",
1309 # check for valid FALLBACK value
1310 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1312 $Fallback = $map{uc $_} ;
1316 sub REQUIRE_handler ()
1318 # the rest of the current line should contain a version number
1321 TrimWhitespace($Ver) ;
1323 death ("Error: REQUIRE expects a version number")
1326 # check that the version number is of the form n.n
1327 death ("Error: REQUIRE: expected a number, got '$Ver'")
1328 unless $Ver =~ /^\d+(\.\d*)?/ ;
1330 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1331 unless $VERSION >= $Ver ;
1334 sub VERSIONCHECK_handler ()
1336 # the rest of the current line should contain either ENABLE or
1339 TrimWhitespace($_) ;
1341 # check for ENABLE/DISABLE
1342 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1343 unless /^(ENABLE|DISABLE)/i ;
1345 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1346 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1350 sub PROTOTYPE_handler ()
1354 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1355 if $proto_in_this_xsub ++ ;
1357 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1360 TrimWhitespace($_) ;
1361 if ($_ eq 'DISABLE') {
1363 } elsif ($_ eq 'ENABLE') {
1366 # remove any whitespace
1368 death("Error: Invalid prototype '$_'")
1369 unless ValidProtoString($_) ;
1370 $ProtoThisXSUB = C_string($_) ;
1374 # If no prototype specified, then assume empty prototype ""
1375 $ProtoThisXSUB = 2 unless $specified ;
1381 sub SCOPE_handler ()
1383 death("Error: Only 1 SCOPE declaration allowed per xsub")
1384 if $scope_in_this_xsub ++ ;
1386 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1388 TrimWhitespace($_) ;
1389 if ($_ =~ /^DISABLE/i) {
1391 } elsif ($_ =~ /^ENABLE/i) {
1398 sub PROTOTYPES_handler ()
1400 # the rest of the current line should contain either ENABLE or
1403 TrimWhitespace($_) ;
1405 # check for ENABLE/DISABLE
1406 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1407 unless /^(ENABLE|DISABLE)/i ;
1409 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1410 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1415 sub INCLUDE_handler ()
1417 # the rest of the current line should contain a valid filename
1419 TrimWhitespace($_) ;
1421 death("INCLUDE: filename missing")
1424 death("INCLUDE: output pipe is illegal")
1427 # simple minded recursion detector
1428 death("INCLUDE loop detected")
1429 if $IncludedFiles{$_} ;
1431 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1433 # Save the current file context.
1436 LastLine => $lastline,
1437 LastLineNo => $lastline_no,
1439 LineNo => \@line_no,
1440 Filename => $filename,
1444 $FH = Symbol::gensym();
1447 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1451 #/* INCLUDE: Including '$_' from '$filename' */
1457 # Prime the pump by reading the first
1460 # skip leading blank lines
1462 last unless /^\s*$/ ;
1472 return 0 unless $XSStack[-1]{type} eq 'file' ;
1474 my $data = pop @XSStack ;
1475 my $ThisFile = $filename ;
1476 my $isPipe = ($filename =~ /\|\s*$/) ;
1478 -- $IncludedFiles{$filename}
1483 $FH = $data->{Handle} ;
1484 $filename = $data->{Filename} ;
1485 $lastline = $data->{LastLine} ;
1486 $lastline_no = $data->{LastLineNo} ;
1487 @line = @{ $data->{Line} } ;
1488 @line_no = @{ $data->{LineNo} } ;
1490 if ($isPipe and $? ) {
1492 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1498 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1505 sub ValidProtoString ($)
1509 if ( $string =~ /^$proto_re+$/ ) {
1520 $string =~ s[\\][\\\\]g ;
1528 $proto_letter{$type} or "\$" ;
1532 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1534 my ($cpp, $cpplevel);
1536 if ($cpp =~ /^\#\s*if/) {
1538 } elsif (!$cpplevel) {
1539 Warn("Warning: #else/elif/endif without #if in this function");
1540 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1541 if $XSStack[-1]{type} eq 'if';
1543 } elsif ($cpp =~ /^\#\s*endif/) {
1547 Warn("Warning: #if without #endif in this function") if $cpplevel;
1555 $text =~ s/\[\[/{/g;
1556 $text =~ s/\]\]/}/g;
1560 # Read next xsub into @line from ($lastline, <$FH>).
1563 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1564 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1567 return PopFile() if !defined $lastline;
1570 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1572 $Package = defined($2) ? $2 : ''; # keep -w happy
1573 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1574 $Prefix = quotemeta $Prefix ;
1575 ($Module_cname = $Module) =~ s/\W/_/g;
1576 ($Packid = $Package) =~ tr/:/_/;
1577 $Packprefix = $Package;
1578 $Packprefix .= "::" if $Packprefix ne "";
1583 # Skip embedded PODs
1584 while ($lastline =~ /^=/) {
1585 while ($lastline = <$FH>) {
1586 last if ($lastline =~ /^=cut\s*$/);
1588 death ("Error: Unterminated pod") unless $lastline;
1591 $lastline =~ s/^\s+$//;
1593 if ($lastline !~ /^\s*#/ ||
1595 # ANSI: if ifdef ifndef elif else endif define undef
1597 # gcc: warning include_next
1599 # others: ident (gcc notes that some cpps have this one)
1600 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1601 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1602 push(@line, $lastline);
1603 push(@line_no, $lastline_no) ;
1606 # Read next line and continuation lines
1607 last unless defined($lastline = <$FH>);
1610 $lastline .= $tmp_line
1611 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1614 $lastline =~ s/^\s+$//;
1616 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1621 local($type, $num, $var, $init, $name_printed) = @_;
1622 local($arg) = "ST(" . ($num - 1) . ")";
1624 if ( $init =~ /^=/ ) {
1625 if ($name_printed) {
1626 eval qq/print " $init\\n"/;
1628 eval qq/print "\\t$var $init\\n"/;
1632 if ( $init =~ s/^\+// && $num ) {
1633 &generate_init($type, $num, $var, $name_printed);
1634 } elsif ($name_printed) {
1638 eval qq/print "\\t$var;\\n"/;
1642 $deferred .= eval qq/"\\n\\t$init\\n"/;
1649 # work out the line number
1650 my $line_no = $line_no[@line_no - @line -1] ;
1652 print STDERR "@_ in $filename, line $line_no\n" ;
1668 local($type, $num, $var) = @_;
1669 local($arg) = "ST(" . ($num - 1) . ")";
1670 local($argoff) = $num - 1;
1674 $type = TidyType($type) ;
1675 blurt("Error: '$type' not in typemap"), return
1676 unless defined($type_kind{$type});
1678 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1679 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1680 $tk = $type_kind{$type};
1681 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1682 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1683 print "\t$var" unless $name_printed;
1684 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1685 die "default value not supported with length(NAME) supplied"
1686 if defined $defaults{$var};
1689 $type =~ tr/:/_/ unless $hiertype;
1690 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1691 unless defined $input_expr{$tk} ;
1692 $expr = $input_expr{$tk};
1693 if ($expr =~ /DO_ARRAY_ELEM/) {
1694 blurt("Error: '$subtype' not in typemap"), return
1695 unless defined($type_kind{$subtype});
1696 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1697 unless defined $input_expr{$type_kind{$subtype}} ;
1698 $subexpr = $input_expr{$type_kind{$subtype}};
1699 $subexpr =~ s/\$type/\$subtype/g;
1700 $subexpr =~ s/ntype/subtype/g;
1701 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1702 $subexpr =~ s/\n\t/\n\t\t/g;
1703 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1704 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1705 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1707 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1710 if (defined($defaults{$var})) {
1711 $expr =~ s/(\t+)/$1 /g;
1713 if ($name_printed) {
1716 eval qq/print "\\t$var;\\n"/;
1719 if ($defaults{$var} eq 'NO_INIT') {
1720 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1722 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1725 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1726 if ($name_printed) {
1729 eval qq/print "\\t$var;\\n"/;
1732 $deferred .= eval qq/"\\n$expr;\\n"/;
1735 die "panic: do not know how to handle this branch for function pointers"
1737 eval qq/print "$expr;\\n"/;
1742 sub generate_output {
1743 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1744 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1745 local($argoff) = $num - 1;
1748 $type = TidyType($type) ;
1749 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1750 print "\t$arg = sv_newmortal();\n";
1751 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1752 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1754 blurt("Error: '$type' not in typemap"), return
1755 unless defined($type_kind{$type});
1756 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1757 unless defined $output_expr{$type_kind{$type}} ;
1758 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1759 $ntype =~ s/\(\)//g;
1760 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1761 $expr = $output_expr{$type_kind{$type}};
1762 if ($expr =~ /DO_ARRAY_ELEM/) {
1763 blurt("Error: '$subtype' not in typemap"), return
1764 unless defined($type_kind{$subtype});
1765 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1766 unless defined $output_expr{$type_kind{$subtype}} ;
1767 $subexpr = $output_expr{$type_kind{$subtype}};
1768 $subexpr =~ s/ntype/subtype/g;
1769 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1770 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1771 $subexpr =~ s/\n\t/\n\t\t/g;
1772 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1773 eval "print qq\a$expr\a";
1775 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1776 } elsif ($var eq 'RETVAL') {
1777 if ($expr =~ /^\t\$arg = new/) {
1778 # We expect that $arg has refcnt 1, so we need to
1780 eval "print qq\a$expr\a";
1782 print "\tsv_2mortal(ST($num));\n";
1783 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1784 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1785 # We expect that $arg has refcnt >=1, so we need
1787 eval "print qq\a$expr\a";
1789 print "\tsv_2mortal(ST(0));\n";
1790 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1792 # Just hope that the entry would safely write it
1793 # over an already mortalized value. By
1794 # coincidence, something like $arg = &sv_undef
1796 print "\tST(0) = sv_newmortal();\n";
1797 eval "print qq\a$expr\a";
1799 # new mortals don't have set magic
1801 } elsif ($do_push) {
1802 print "\tPUSHs(sv_newmortal());\n";
1804 eval "print qq\a$expr\a";
1806 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1807 } elsif ($arg =~ /^ST\(\d+\)$/) {
1808 eval "print qq\a$expr\a";
1810 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1816 my($type, $varname) = @_;
1818 # C++ has :: in types too so skip this
1819 $type =~ tr/:/_/ unless $hiertype;
1820 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1822 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1823 (substr $type, pos $type, 0) = " $varname ";
1825 $type .= "\t$varname";
1832 #########################################################
1834 ExtUtils::ParseXS::CountLines;
1836 use vars qw($SECTION_END_MARKER);
1839 my ($class, $cfile, $fh) = @_;
1840 $cfile =~ s/\\/\\\\/g;
1841 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1843 return bless {buffer => '',
1852 $self->{buffer} .= $_;
1853 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1855 ++ $self->{line_no};
1856 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1857 print {$self->{fh}} $line;
1865 $self->PRINT(sprintf($fmt, @_));
1869 # Not necessary if we're careful to end with a "\n"
1871 print {$self->{fh}} $self->{buffer};
1875 # This sub does nothing, but is neccessary for references to be released.
1879 return $SECTION_END_MARKER;
1888 ExtUtils::ParseXS - converts Perl XS code into C code
1892 use ExtUtils::ParseXS qw(process_file);
1894 process_file( filename => 'foo.xs' );
1896 process_file( filename => 'foo.xs',
1899 typemap => 'path/to/typemap',
1910 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1911 necessary to let C functions manipulate Perl values and creates the glue
1912 necessary to let Perl access those functions. The compiler uses typemaps to
1913 determine how to map C function parameters and variables to Perl values.
1915 The compiler will search for typemap files called I<typemap>. It will use
1916 the following search path to find default typemaps, with the rightmost
1917 typemap taking precedence.
1919 ../../../typemap:../../typemap:../typemap:typemap
1923 None by default. C<process_file()> may be exported upon request.
1932 This function processes an XS file and sends output to a C file.
1933 Named parameters control how the processing is done. The following
1934 parameters are accepted:
1940 Adds C<extern "C"> to the C code. Default is false.
1944 Retains C<::> in type names so that C++ hierachical types can be
1945 mapped. Default is false.
1949 Adds exception handling stubs to the C code. Default is false.
1953 Indicates that a user-supplied typemap should take precedence over the
1954 default typemaps. A single typemap may be specified as a string, or
1955 multiple typemaps can be specified in an array reference, with the
1956 last typemap having the highest precedence.
1960 Generates prototype code for all xsubs. Default is false.
1962 =item B<versioncheck>
1964 Makes sure at run time that the object file (derived from the C<.xs>
1965 file) and the C<.pm> files have the same version number. Default is
1968 =item B<linenumbers>
1970 Adds C<#line> directives to the C output so error messages will look
1971 like they came from the original XS file. Default is true.
1975 Enables certain optimizations. The only optimization that is currently
1976 affected is the use of I<target>s by the output C code (see L<perlguts>).
1977 Not optimizing may significantly slow down the generated code, but this is the way
1978 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
1982 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
1983 declarations. Default is true.
1987 Enable recognition of ANSI-like descriptions of function signature.
1992 I have no clue what this does. Strips function prefixes?
1998 This function returns the number of [a certain kind of] errors
1999 encountered during processing of the XS file.
2005 Based on xsubpp code, written by Larry Wall.
2007 Maintained by Ken Williams, <ken@mathforum.org>
2011 Copyright 2002-2003 Ken Williams. All rights reserved.
2013 This library is free software; you can redistribute it and/or
2014 modify it under the same terms as Perl itself.
2016 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2017 Porters, which was released under the same license terms.
2021 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.