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) {
206 BEGIN { $^H |= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs
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})
574 print Q(<<"EOF") if $ALIAS ;
577 print Q(<<"EOF") if $INTERFACE ;
578 # dXSFUNCTION($ret_type);
581 $cond = ($min_args ? qq(items < $min_args) : 0);
582 } elsif ($min_args == $num_args) {
583 $cond = qq(items != $min_args);
585 $cond = qq(items < $min_args || items > $num_args);
588 print Q(<<"EOF") if $except;
594 { print Q(<<"EOF") if $cond }
596 # Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "$report_args");
599 { print Q(<<"EOF") if $cond }
601 # Perl_croak(aTHX_ "Usage: %s(%s)", "$pname", "$report_args");
604 # cv doesn't seem to be used, in most cases unless we go in
605 # the if of this else
607 # PERL_UNUSED_VAR(cv); /* -W */
610 #gcc -Wall: if an xsub has PPCODE is used
611 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
612 #hence `ax' (setup by dXSARGS) is unused
613 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
614 #but such a move could break third-party extensions
615 print Q(<<"EOF") if $PPCODE;
616 # PERL_UNUSED_VAR(ax); /* -Wall */
619 print Q(<<"EOF") if $PPCODE;
623 # Now do a block of some sort.
626 $cond = ''; # last CASE: condidional
627 push(@line, "$END:");
628 push(@line_no, $line_no[-1]);
632 &CASE_handler if check_keyword("CASE");
637 # do initialization of input variables
645 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
647 print Q(<<"EOF") if $ScopeThisXSUB;
652 if (!$thisdone && defined($class)) {
653 if (defined($static) or $func_name eq 'new') {
655 $var_types{"CLASS"} = "char *";
656 &generate_init("char *", 1, "CLASS");
660 $var_types{"THIS"} = "$class *";
661 &generate_init("$class *", 1, "THIS");
666 if (/^\s*NOT_IMPLEMENTED_YET/) {
667 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
670 if ($ret_type ne "void") {
671 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
673 $args_match{"RETVAL"} = 0;
674 $var_types{"RETVAL"} = $ret_type;
676 if $WantOptimize and $targetable{$type_kind{$ret_type}};
679 if (@fake_INPUT or @fake_INPUT_pre) {
680 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
682 $processing_arg_with_types = 1;
687 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
689 if (check_keyword("PPCODE")) {
691 death ("PPCODE must be last thing") if @line;
692 print "\tLEAVE;\n" if $ScopeThisXSUB;
693 print "\tPUTBACK;\n\treturn;\n";
694 } elsif (check_keyword("CODE")) {
696 } elsif (defined($class) and $func_name eq "DESTROY") {
698 print "delete THIS;\n";
701 if ($ret_type ne "void") {
705 if (defined($static)) {
706 if ($func_name eq 'new') {
707 $func_name = "$class";
711 } elsif (defined($class)) {
712 if ($func_name eq 'new') {
713 $func_name .= " $class";
718 $func_name =~ s/^\Q$args{'s'}//
719 if exists $args{'s'};
720 $func_name = 'XSFUNCTION' if $interface;
721 print "$func_name($func_args);\n";
725 # do output variables
726 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
727 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
728 # $wantRETVAL set if 'RETVAL =' autogenerated
729 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
731 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
733 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
734 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
736 # all OUTPUT done, so now push the return value on the stack
737 if ($gotRETVAL && $RETVAL_code) {
738 print "\t$RETVAL_code\n";
739 } elsif ($gotRETVAL || $wantRETVAL) {
740 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
742 my $type = $ret_type;
744 # 0: type, 1: with_size, 2: how, 3: how_size
745 if ($t and not $t->[1] and $t->[0] eq 'p') {
746 # PUSHp corresponds to setpvn. Treate setpv directly
747 my $what = eval qq("$t->[2]");
750 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
754 my $what = eval qq("$t->[2]");
758 $size = '' unless defined $size;
759 $size = eval qq("$size");
761 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
765 # RETVAL almost never needs SvSETMAGIC()
766 &generate_output($ret_type, 0, 'RETVAL', 0);
770 $xsreturn = 1 if $ret_type ne "void";
773 print "\tXSprePUSH;" if $c and not $prepush_done;
774 print "\tEXTEND(SP,$c);\n" if $c;
776 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
779 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
781 print Q(<<"EOF") if $ScopeThisXSUB;
784 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
788 # print function trailer
792 print Q(<<"EOF") if $except;
795 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
798 if (check_keyword("CASE")) {
799 blurt ("Error: No `CASE:' at top of function")
801 $_ = "CASE: $_"; # Restore CASE: label
804 last if $_ eq "$END:";
805 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
808 print Q(<<"EOF") if $except;
810 # Perl_croak(aTHX_ errbuf);
814 print Q(<<"EOF") unless $PPCODE;
815 # XSRETURN($xsreturn);
818 print Q(<<"EOF") unless $PPCODE;
828 my $newXS = "newXS" ;
831 # Build the prototype string for the xsub
832 if ($ProtoThisXSUB) {
833 $newXS = "newXSproto";
835 if ($ProtoThisXSUB eq 2) {
836 # User has specified empty prototype
838 elsif ($ProtoThisXSUB eq 1) {
840 if ($min_args < $num_args) {
842 $proto_arg[$min_args] .= ";" ;
844 push @proto_arg, "$s\@"
847 $proto = join ("", grep defined, @proto_arg);
850 # User has specified a prototype
851 $proto = $ProtoThisXSUB;
853 $proto = qq{, "$proto"};
857 $XsubAliases{$pname} = 0
858 unless defined $XsubAliases{$pname} ;
859 while ( ($name, $value) = each %XsubAliases) {
860 push(@InitFileCode, Q(<<"EOF"));
861 # cv = newXS(\"$name\", XS_$Full_func_name, file);
862 # XSANY.any_i32 = $value ;
864 push(@InitFileCode, Q(<<"EOF")) if $proto;
865 # sv_setpv((SV*)cv$proto) ;
869 elsif (@Attributes) {
870 push(@InitFileCode, Q(<<"EOF"));
871 # cv = newXS(\"$pname\", XS_$Full_func_name, file);
872 # apply_attrs_string("$Package", cv, "@Attributes", 0);
876 while ( ($name, $value) = each %Interfaces) {
877 $name = "$Package\::$name" unless $name =~ /::/;
878 push(@InitFileCode, Q(<<"EOF"));
879 # cv = newXS(\"$name\", XS_$Full_func_name, file);
880 # $interface_macro_set(cv,$value) ;
882 push(@InitFileCode, Q(<<"EOF")) if $proto;
883 # sv_setpv((SV*)cv$proto) ;
889 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
893 if ($Overload) # make it findable with fetchmethod
896 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
897 #XS(XS_${Packid}_nil)
904 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
905 /* Making a sub named "${Package}::()" allows the package */
906 /* to be findable via fetchmethod(), and causes */
907 /* overload::Overloaded("${Package}") to return true. */
908 newXS("${Package}::()", XS_${Packid}_nil, file$proto);
909 MAKE_FETCHMETHOD_WORK
912 # print initialization routine
921 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
922 #XS(boot_$Module_cname)
934 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
936 print Q(<<"EOF") if $Full_func_name;
937 # char* file = __FILE__;
943 # PERL_UNUSED_VAR(cv); /* -W */
944 # PERL_UNUSED_VAR(items); /* -W */
947 print Q(<<"EOF") if $WantVersionChk ;
948 # XS_VERSION_BOOTCHECK ;
952 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
958 print Q(<<"EOF") if ($Overload);
959 # /* register the overloading (type 'A') magic */
960 # PL_amagic_generation++;
961 # /* The magic for overload gets a GV* via gv_fetchmeth as */
962 # /* mentioned above, and looks in the SV* slot of it for */
963 # /* the "fallback" status. */
965 # get_sv( "${Package}::()", TRUE ),
972 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
978 print "\n /* Initialisation Section */\n\n" ;
981 print "\n /* End of Initialisation Section */\n\n" ;
987 call_list(PL_scopestack_ix, PL_unitcheckav);
997 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1002 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1008 sub errors { $errors }
1010 sub standard_typemap_locations {
1011 # Add all the default typemap locations to the search path
1012 my @tm = qw(typemap);
1014 my $updir = File::Spec->updir;
1015 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1016 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1018 unshift @tm, File::Spec->catfile($dir, 'typemap');
1019 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1021 foreach my $dir (@INC) {
1022 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1023 unshift @tm, $file if -e $file;
1030 $_[0] =~ s/^\s+|\s+$//go ;
1037 # rationalise any '*' by joining them into bunches and removing whitespace
1041 # change multiple whitespace into a single space
1044 # trim leading & trailing whitespace
1045 TrimWhitespace($_) ;
1050 # Input: ($_, @line) == unparsed input.
1051 # Output: ($_, @line) == (rest of line, following lines).
1052 # Return: the matched keyword if found, otherwise 0
1054 $_ = shift(@line) while !/\S/ && @line;
1055 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1059 # the "do" is required for right semantics
1060 do { $_ = shift(@line) } while !/\S/ && @line;
1062 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1063 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1064 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1067 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1073 while (!/\S/ && @line) {
1077 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1084 sub process_keyword($)
1089 &{"${kwd}_handler"}()
1090 while $kwd = check_keyword($pattern) ;
1094 blurt ("Error: `CASE:' after unconditional `CASE:'")
1095 if $condnum && $cond eq '';
1097 TrimWhitespace($cond);
1098 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1103 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1104 last if /^\s*NOT_IMPLEMENTED_YET/;
1105 next unless /\S/; # skip blank lines
1107 TrimWhitespace($_) ;
1110 # remove trailing semicolon if no initialisation
1111 s/\s*;$//g unless /[=;+].*\S/ ;
1113 # Process the length(foo) declarations
1114 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1115 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1116 $lengthof{$2} = $name;
1117 # $islengthof{$name} = $1;
1118 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
1121 # check for optional initialisation code
1123 $var_init = $1 if s/\s*([=;+].*)$//s ;
1124 $var_init =~ s/"/\\"/g;
1127 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1128 or blurt("Error: invalid argument declaration '$line'"), next;
1130 # Check for duplicate definitions
1131 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1132 if $arg_list{$var_name}++
1133 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1135 $thisdone |= $var_name eq "THIS";
1136 $retvaldone |= $var_name eq "RETVAL";
1137 $var_types{$var_name} = $var_type;
1138 # XXXX This check is a safeguard against the unfinished conversion of
1139 # generate_init(). When generate_init() is fixed,
1140 # one can use 2-args map_type() unconditionally.
1141 if ($var_type =~ / \( \s* \* \s* \) /x) {
1142 # Function pointers are not yet supported with &output_init!
1143 print "\t" . &map_type($var_type, $var_name);
1146 print "\t" . &map_type($var_type);
1149 $var_num = $args_match{$var_name};
1151 $proto_arg[$var_num] = ProtoString($var_type)
1153 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1154 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1155 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1156 and $var_init !~ /\S/) {
1157 if ($name_printed) {
1160 print "\t$var_name;\n";
1162 } elsif ($var_init =~ /\S/) {
1163 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1164 } elsif ($var_num) {
1165 # generate initialization code
1166 &generate_init($var_type, $var_num, $var_name, $name_printed);
1173 sub OUTPUT_handler {
1174 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1176 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1177 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1180 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1181 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1182 if $outargs{$outarg} ++ ;
1183 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1184 # deal with RETVAL last
1185 $RETVAL_code = $outcode ;
1189 blurt ("Error: OUTPUT $outarg not an argument"), next
1190 unless defined($args_match{$outarg});
1191 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1192 unless defined $var_types{$outarg} ;
1193 $var_num = $args_match{$outarg};
1195 print "\t$outcode\n";
1196 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1198 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1200 delete $in_out{$outarg} # No need to auto-OUTPUT
1201 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1205 sub C_ARGS_handler() {
1206 my $in = merge_section();
1208 TrimWhitespace($in);
1212 sub INTERFACE_MACRO_handler() {
1213 my $in = merge_section();
1215 TrimWhitespace($in);
1216 if ($in =~ /\s/) { # two
1217 ($interface_macro, $interface_macro_set) = split ' ', $in;
1219 $interface_macro = $in;
1220 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1222 $interface = 1; # local
1223 $Interfaces = 1; # global
1226 sub INTERFACE_handler() {
1227 my $in = merge_section();
1229 TrimWhitespace($in);
1231 foreach (split /[\s,]+/, $in) {
1233 $name =~ s/^$Prefix//;
1234 $Interfaces{$name} = $_;
1237 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1239 $interface = 1; # local
1240 $Interfaces = 1; # global
1243 sub CLEANUP_handler() { print_section() }
1244 sub PREINIT_handler() { print_section() }
1245 sub POSTCALL_handler() { print_section() }
1246 sub INIT_handler() { print_section() }
1251 my ($orig) = $line ;
1255 # Parse alias definitions
1257 # alias = value alias = value ...
1259 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1261 $orig_alias = $alias ;
1264 # check for optional package definition in the alias
1265 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1267 # check for duplicate alias name & duplicate value
1268 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1269 if defined $XsubAliases{$alias} ;
1271 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1272 if $XsubAliasValues{$value} ;
1275 $XsubAliases{$alias} = $value ;
1276 $XsubAliasValues{$value} = $orig_alias ;
1279 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1283 sub ATTRS_handler ()
1285 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1287 TrimWhitespace($_) ;
1288 push @Attributes, $_;
1292 sub ALIAS_handler ()
1294 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1296 TrimWhitespace($_) ;
1297 GetAliases($_) if $_ ;
1301 sub OVERLOAD_handler()
1303 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1305 TrimWhitespace($_) ;
1306 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1307 $Overload = 1 unless $Overload;
1308 my $overload = "$Package\::(".$1 ;
1310 " newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
1315 sub FALLBACK_handler()
1317 # the rest of the current line should contain either TRUE,
1320 TrimWhitespace($_) ;
1322 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1323 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1324 UNDEF => "&PL_sv_undef",
1327 # check for valid FALLBACK value
1328 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1330 $Fallback = $map{uc $_} ;
1334 sub REQUIRE_handler ()
1336 # the rest of the current line should contain a version number
1339 TrimWhitespace($Ver) ;
1341 death ("Error: REQUIRE expects a version number")
1344 # check that the version number is of the form n.n
1345 death ("Error: REQUIRE: expected a number, got '$Ver'")
1346 unless $Ver =~ /^\d+(\.\d*)?/ ;
1348 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1349 unless $VERSION >= $Ver ;
1352 sub VERSIONCHECK_handler ()
1354 # the rest of the current line should contain either ENABLE or
1357 TrimWhitespace($_) ;
1359 # check for ENABLE/DISABLE
1360 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1361 unless /^(ENABLE|DISABLE)/i ;
1363 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1364 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1368 sub PROTOTYPE_handler ()
1372 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1373 if $proto_in_this_xsub ++ ;
1375 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1378 TrimWhitespace($_) ;
1379 if ($_ eq 'DISABLE') {
1381 } elsif ($_ eq 'ENABLE') {
1384 # remove any whitespace
1386 death("Error: Invalid prototype '$_'")
1387 unless ValidProtoString($_) ;
1388 $ProtoThisXSUB = C_string($_) ;
1392 # If no prototype specified, then assume empty prototype ""
1393 $ProtoThisXSUB = 2 unless $specified ;
1399 sub SCOPE_handler ()
1401 death("Error: Only 1 SCOPE declaration allowed per xsub")
1402 if $scope_in_this_xsub ++ ;
1404 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1406 TrimWhitespace($_) ;
1407 if ($_ =~ /^DISABLE/i) {
1409 } elsif ($_ =~ /^ENABLE/i) {
1416 sub PROTOTYPES_handler ()
1418 # the rest of the current line should contain either ENABLE or
1421 TrimWhitespace($_) ;
1423 # check for ENABLE/DISABLE
1424 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1425 unless /^(ENABLE|DISABLE)/i ;
1427 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1428 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1433 sub INCLUDE_handler ()
1435 # the rest of the current line should contain a valid filename
1437 TrimWhitespace($_) ;
1439 death("INCLUDE: filename missing")
1442 death("INCLUDE: output pipe is illegal")
1445 # simple minded recursion detector
1446 death("INCLUDE loop detected")
1447 if $IncludedFiles{$_} ;
1449 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1451 # Save the current file context.
1454 LastLine => $lastline,
1455 LastLineNo => $lastline_no,
1457 LineNo => \@line_no,
1458 Filename => $filename,
1459 Filepathname => $filepathname,
1463 $FH = Symbol::gensym();
1466 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1470 #/* INCLUDE: Including '$_' from '$filename' */
1474 $filepathname = $filename = $_ ;
1476 # Prime the pump by reading the first
1479 # skip leading blank lines
1481 last unless /^\s*$/ ;
1491 return 0 unless $XSStack[-1]{type} eq 'file' ;
1493 my $data = pop @XSStack ;
1494 my $ThisFile = $filename ;
1495 my $isPipe = ($filename =~ /\|\s*$/) ;
1497 -- $IncludedFiles{$filename}
1502 $FH = $data->{Handle} ;
1503 # $filename is the leafname, which for some reason isused for diagnostic
1504 # messages, whereas $filepathname is the full pathname, and is used for
1506 $filename = $data->{Filename} ;
1507 $filepathname = $data->{Filepathname} ;
1508 $lastline = $data->{LastLine} ;
1509 $lastline_no = $data->{LastLineNo} ;
1510 @line = @{ $data->{Line} } ;
1511 @line_no = @{ $data->{LineNo} } ;
1513 if ($isPipe and $? ) {
1515 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1521 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1528 sub ValidProtoString ($)
1532 if ( $string =~ /^$proto_re+$/ ) {
1543 $string =~ s[\\][\\\\]g ;
1551 $proto_letter{$type} or "\$" ;
1555 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1557 my ($cpp, $cpplevel);
1559 if ($cpp =~ /^\#\s*if/) {
1561 } elsif (!$cpplevel) {
1562 Warn("Warning: #else/elif/endif without #if in this function");
1563 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1564 if $XSStack[-1]{type} eq 'if';
1566 } elsif ($cpp =~ /^\#\s*endif/) {
1570 Warn("Warning: #if without #endif in this function") if $cpplevel;
1578 $text =~ s/\[\[/{/g;
1579 $text =~ s/\]\]/}/g;
1583 # Read next xsub into @line from ($lastline, <$FH>).
1586 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1587 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1590 return PopFile() if !defined $lastline;
1593 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1595 $Package = defined($2) ? $2 : ''; # keep -w happy
1596 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1597 $Prefix = quotemeta $Prefix ;
1598 ($Module_cname = $Module) =~ s/\W/_/g;
1599 ($Packid = $Package) =~ tr/:/_/;
1600 $Packprefix = $Package;
1601 $Packprefix .= "::" if $Packprefix ne "";
1606 # Skip embedded PODs
1607 while ($lastline =~ /^=/) {
1608 while ($lastline = <$FH>) {
1609 last if ($lastline =~ /^=cut\s*$/);
1611 death ("Error: Unterminated pod") unless $lastline;
1614 $lastline =~ s/^\s+$//;
1616 if ($lastline !~ /^\s*#/ ||
1618 # ANSI: if ifdef ifndef elif else endif define undef
1620 # gcc: warning include_next
1622 # others: ident (gcc notes that some cpps have this one)
1623 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1624 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1625 push(@line, $lastline);
1626 push(@line_no, $lastline_no) ;
1629 # Read next line and continuation lines
1630 last unless defined($lastline = <$FH>);
1633 $lastline .= $tmp_line
1634 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1637 $lastline =~ s/^\s+$//;
1639 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1644 local($type, $num, $var, $init, $name_printed) = @_;
1645 local($arg) = "ST(" . ($num - 1) . ")";
1647 if ( $init =~ /^=/ ) {
1648 if ($name_printed) {
1649 eval qq/print " $init\\n"/;
1651 eval qq/print "\\t$var $init\\n"/;
1655 if ( $init =~ s/^\+// && $num ) {
1656 &generate_init($type, $num, $var, $name_printed);
1657 } elsif ($name_printed) {
1661 eval qq/print "\\t$var;\\n"/;
1665 $deferred .= eval qq/"\\n\\t$init\\n"/;
1672 # work out the line number
1673 my $line_no = $line_no[@line_no - @line -1] ;
1675 print STDERR "@_ in $filename, line $line_no\n" ;
1691 local($type, $num, $var) = @_;
1692 local($arg) = "ST(" . ($num - 1) . ")";
1693 local($argoff) = $num - 1;
1697 $type = TidyType($type) ;
1698 blurt("Error: '$type' not in typemap"), return
1699 unless defined($type_kind{$type});
1701 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1702 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1703 $tk = $type_kind{$type};
1704 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1705 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1706 print "\t$var" unless $name_printed;
1707 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1708 die "default value not supported with length(NAME) supplied"
1709 if defined $defaults{$var};
1712 $type =~ tr/:/_/ unless $hiertype;
1713 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1714 unless defined $input_expr{$tk} ;
1715 $expr = $input_expr{$tk};
1716 if ($expr =~ /DO_ARRAY_ELEM/) {
1717 blurt("Error: '$subtype' not in typemap"), return
1718 unless defined($type_kind{$subtype});
1719 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1720 unless defined $input_expr{$type_kind{$subtype}} ;
1721 $subexpr = $input_expr{$type_kind{$subtype}};
1722 $subexpr =~ s/\$type/\$subtype/g;
1723 $subexpr =~ s/ntype/subtype/g;
1724 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1725 $subexpr =~ s/\n\t/\n\t\t/g;
1726 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1727 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1728 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1730 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1733 if (defined($defaults{$var})) {
1734 $expr =~ s/(\t+)/$1 /g;
1736 if ($name_printed) {
1739 eval qq/print "\\t$var;\\n"/;
1742 if ($defaults{$var} eq 'NO_INIT') {
1743 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1745 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1748 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1749 if ($name_printed) {
1752 eval qq/print "\\t$var;\\n"/;
1755 $deferred .= eval qq/"\\n$expr;\\n"/;
1758 die "panic: do not know how to handle this branch for function pointers"
1760 eval qq/print "$expr;\\n"/;
1765 sub generate_output {
1766 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1767 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1768 local($argoff) = $num - 1;
1771 $type = TidyType($type) ;
1772 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1773 print "\t$arg = sv_newmortal();\n";
1774 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1775 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1777 blurt("Error: '$type' not in typemap"), return
1778 unless defined($type_kind{$type});
1779 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1780 unless defined $output_expr{$type_kind{$type}} ;
1781 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1782 $ntype =~ s/\(\)//g;
1783 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1784 $expr = $output_expr{$type_kind{$type}};
1785 if ($expr =~ /DO_ARRAY_ELEM/) {
1786 blurt("Error: '$subtype' not in typemap"), return
1787 unless defined($type_kind{$subtype});
1788 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1789 unless defined $output_expr{$type_kind{$subtype}} ;
1790 $subexpr = $output_expr{$type_kind{$subtype}};
1791 $subexpr =~ s/ntype/subtype/g;
1792 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1793 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1794 $subexpr =~ s/\n\t/\n\t\t/g;
1795 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1796 eval "print qq\a$expr\a";
1798 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1799 } elsif ($var eq 'RETVAL') {
1800 if ($expr =~ /^\t\$arg = new/) {
1801 # We expect that $arg has refcnt 1, so we need to
1803 eval "print qq\a$expr\a";
1805 print "\tsv_2mortal(ST($num));\n";
1806 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1807 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1808 # We expect that $arg has refcnt >=1, so we need
1810 eval "print qq\a$expr\a";
1812 print "\tsv_2mortal(ST(0));\n";
1813 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1815 # Just hope that the entry would safely write it
1816 # over an already mortalized value. By
1817 # coincidence, something like $arg = &sv_undef
1819 print "\tST(0) = sv_newmortal();\n";
1820 eval "print qq\a$expr\a";
1822 # new mortals don't have set magic
1824 } elsif ($do_push) {
1825 print "\tPUSHs(sv_newmortal());\n";
1827 eval "print qq\a$expr\a";
1829 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1830 } elsif ($arg =~ /^ST\(\d+\)$/) {
1831 eval "print qq\a$expr\a";
1833 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1839 my($type, $varname) = @_;
1841 # C++ has :: in types too so skip this
1842 $type =~ tr/:/_/ unless $hiertype;
1843 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1845 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1846 (substr $type, pos $type, 0) = " $varname ";
1848 $type .= "\t$varname";
1855 #########################################################
1857 ExtUtils::ParseXS::CountLines;
1859 use vars qw($SECTION_END_MARKER);
1862 my ($class, $cfile, $fh) = @_;
1863 $cfile =~ s/\\/\\\\/g;
1864 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1866 return bless {buffer => '',
1875 $self->{buffer} .= $_;
1876 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1878 ++ $self->{line_no};
1879 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1880 print {$self->{fh}} $line;
1888 $self->PRINT(sprintf($fmt, @_));
1892 # Not necessary if we're careful to end with a "\n"
1894 print {$self->{fh}} $self->{buffer};
1898 # This sub does nothing, but is neccessary for references to be released.
1902 return $SECTION_END_MARKER;
1911 ExtUtils::ParseXS - converts Perl XS code into C code
1915 use ExtUtils::ParseXS qw(process_file);
1917 process_file( filename => 'foo.xs' );
1919 process_file( filename => 'foo.xs',
1922 typemap => 'path/to/typemap',
1933 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1934 necessary to let C functions manipulate Perl values and creates the glue
1935 necessary to let Perl access those functions. The compiler uses typemaps to
1936 determine how to map C function parameters and variables to Perl values.
1938 The compiler will search for typemap files called I<typemap>. It will use
1939 the following search path to find default typemaps, with the rightmost
1940 typemap taking precedence.
1942 ../../../typemap:../../typemap:../typemap:typemap
1946 None by default. C<process_file()> may be exported upon request.
1955 This function processes an XS file and sends output to a C file.
1956 Named parameters control how the processing is done. The following
1957 parameters are accepted:
1963 Adds C<extern "C"> to the C code. Default is false.
1967 Retains C<::> in type names so that C++ hierachical types can be
1968 mapped. Default is false.
1972 Adds exception handling stubs to the C code. Default is false.
1976 Indicates that a user-supplied typemap should take precedence over the
1977 default typemaps. A single typemap may be specified as a string, or
1978 multiple typemaps can be specified in an array reference, with the
1979 last typemap having the highest precedence.
1983 Generates prototype code for all xsubs. Default is false.
1985 =item B<versioncheck>
1987 Makes sure at run time that the object file (derived from the C<.xs>
1988 file) and the C<.pm> files have the same version number. Default is
1991 =item B<linenumbers>
1993 Adds C<#line> directives to the C output so error messages will look
1994 like they came from the original XS file. Default is true.
1998 Enables certain optimizations. The only optimization that is currently
1999 affected is the use of I<target>s by the output C code (see L<perlguts>).
2000 Not optimizing may significantly slow down the generated code, but this is the way
2001 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2005 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2006 declarations. Default is true.
2010 Enable recognition of ANSI-like descriptions of function signature.
2015 I have no clue what this does. Strips function prefixes?
2021 This function returns the number of [a certain kind of] errors
2022 encountered during processing of the XS file.
2028 Based on xsubpp code, written by Larry Wall.
2030 Maintained by Ken Williams, <ken@mathforum.org>
2034 Copyright 2002-2003 Ken Williams. All rights reserved.
2036 This library is free software; you can redistribute it and/or
2037 modify it under the same terms as Perl itself.
2039 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2040 Porters, which was released under the same license terms.
2044 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.