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);
21 $VERSION = '2.2210_01';
22 $VERSION = eval $VERSION if $VERSION =~ /_/;
24 use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
25 $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
26 $WantOptimize $process_inout $process_argtypes @tm
27 $dir $filename $filepathname %IncludedFiles
28 %type_kind %proto_letter
29 %targetable $BLOCK_re $lastline $lastline_no
30 $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
31 $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
32 $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
33 $ProtoThisXSUB $ScopeThisXSUB $xsreturn
34 @line_no $ret_type $func_header $orig_args
35 ); # Add these just to get compilation to happen.
40 # Allow for $package->process_file(%hash) in the future
41 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
43 $ProtoUsed = exists $args{prototypes};
47 # 'C++' => 0, # Doesn't seem to *do* anything...
65 my ($Is_VMS, $SymSet);
68 # Establish set of global symbols with max length 28, since xsubpp
69 # will later add the 'XS_' prefix.
70 require ExtUtils::XSSymSet;
71 $SymSet = new ExtUtils::XSSymSet 28;
73 @XSStack = ({type => 'none'});
74 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
76 $FH = Symbol::gensym();
77 $proto_re = "[" . quotemeta('\$%&*@;[]_') . "]" ;
80 $Fallback = '&PL_sv_undef';
82 # Most of the 1500 lines below uses these globals. We'll have to
83 # clean this up sometime, probably. For now, we just pull them out
86 $cplusplus = $args{'C++'};
87 $hiertype = $args{hiertype};
88 $WantPrototypes = $args{prototypes};
89 $WantVersionChk = $args{versioncheck};
90 $except = $args{except} ? ' TRY' : '';
91 $WantLineNumbers = $args{linenumbers};
92 $WantOptimize = $args{optimize};
93 $process_inout = $args{inout};
94 $process_argtypes = $args{argtypes};
95 @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
97 for ($args{filename}) {
98 die "Missing required parameter 'filename'" unless $_;
100 ($dir, $filename) = (dirname($_), basename($_));
101 $filepathname =~ s/\\/\\\\/g;
102 $IncludedFiles{$_}++;
105 # Open the input file
106 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
108 # Open the output file if given as a string. If they provide some
109 # other kind of reference, trust them that we can print to it.
110 if (not ref $args{output}) {
111 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
112 $args{outfile} = $args{output};
116 # Really, we shouldn't have to chdir() or select() in the first
117 # place. For now, just save & restore.
118 my $orig_cwd = cwd();
119 my $orig_fh = select();
123 my $csuffix = $args{csuffix};
125 if ($WantLineNumbers) {
127 if ( $args{outfile} ) {
128 $cfile = $args{outfile};
130 $cfile = $args{filename};
131 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
133 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
134 select PSEUDO_STDOUT;
136 select $args{output};
139 foreach my $typemap (@tm) {
140 die "Can't find $typemap in $pwd\n" unless -r $typemap;
143 push @tm, standard_typemap_locations();
145 foreach my $typemap (@tm) {
146 next unless -f $typemap ;
147 # skip directories, binary files etc.
148 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
150 open(TYPEMAP, $typemap)
151 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
152 my $mode = 'Typemap';
154 my $current = \$junk;
157 my $line_no = $. + 1;
159 $mode = 'Input'; $current = \$junk; next;
162 $mode = 'Output'; $current = \$junk; next;
164 if (/^TYPEMAP\s*$/) {
165 $mode = 'Typemap'; $current = \$junk; next;
167 if ($mode eq 'Typemap') {
171 # skip blank lines and comment lines
172 next if /^$/ or /^#/ ;
173 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
174 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
175 $type = TidyType($type) ;
176 $type_kind{$type} = $kind ;
177 # prototype defaults to '$'
178 $proto = "\$" unless $proto ;
179 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
180 unless ValidProtoString($proto) ;
181 $proto_letter{$type} = C_string($proto) ;
184 } elsif ($mode eq 'Input') {
186 $input_expr{$_} = '';
187 $current = \$input_expr{$_};
190 $output_expr{$_} = '';
191 $current = \$output_expr{$_};
197 foreach my $value (values %input_expr) {
198 $value =~ s/;*\s+\z//;
199 # Move C pre-processor instructions to column 1 to be strictly ANSI
200 # conformant. Some pre-processors are fussy about this.
201 $value =~ s/^\s+#/#/mg;
203 foreach my $value (values %output_expr) {
205 $value =~ s/^\s+#/#/mg;
209 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
210 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
211 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
213 foreach my $key (keys %output_expr) {
214 # We can still bootstrap compile 're', because in code re.pm is
215 # available to miniperl, and does not attempt to load the XS code.
218 my ($t, $with_size, $arg, $sarg) =
219 ($output_expr{$key} =~
220 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
221 \s* \( \s* $cast \$arg \s* ,
222 \s* ( (??{ $bal }) ) # Set from
223 ( (??{ $size }) )? # Possible sizeof set-from
226 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
229 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
231 # Match an XS keyword
232 $BLOCK_re= '\s*(' . join('|', qw(
233 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE
234 OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE
235 VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE
236 INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
240 our ($C_group_rex, $C_arg);
241 # Group in C (no support for comments or literals)
242 $C_group_rex = qr/ [({\[]
243 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
245 # Chunk in C without comma at toplevel (no comments):
246 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
247 | (??{ $C_group_rex })
248 | " (?: (?> [^\\"]+ )
250 )* " # String literal
251 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
254 # Identify the version of xsubpp used
257 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
258 * contents of $filename. Do not edit this file, edit $filename instead.
260 * ANY CHANGES MADE HERE WILL BE LOST!
267 print("#line 1 \"$filepathname\"\n")
273 my $podstartline = $.;
276 # We can't just write out a /* */ comment, as our embedded
277 # POD might itself be in a comment. We can't put a /**/
278 # comment inside #if 0, as the C standard says that the source
279 # file is decomposed into preprocessing characters in the stage
280 # before preprocessing commands are executed.
281 # I don't want to leave the text as barewords, because the spec
282 # isn't clear whether macros are expanded before or after
283 # preprocessing commands are executed, and someone pathological
284 # may just have defined one of the 3 words as a macro that does
285 # something strange. Multiline strings are illegal in C, so
286 # the "" we write must be a string literal. And they aren't
287 # concatenated until 2 steps later, so we are safe.
289 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
290 printf("#line %d \"$filepathname\"\n", $. + 1)
296 # At this point $. is at end of file so die won't state the start
297 # of the problem, and as we haven't yet read any lines &death won't
298 # show the correct line in the message either.
299 die ("Error: Unterminated pod in $filename, line $podstartline\n")
302 last if ($Package, $Prefix) =
303 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
307 unless (defined $_) {
308 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
309 exit 0; # Not a fatal error for the caller process
312 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
315 #ifndef PERL_UNUSED_VAR
316 # define PERL_UNUSED_VAR(var) if (0) var = var
322 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
323 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
325 /* prototype to pass -Wmissing-prototypes */
327 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
330 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
332 const GV *const gv = CvGV(cv);
334 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
337 const char *const gvname = GvNAME(gv);
338 const HV *const stash = GvSTASH(gv);
339 const char *const hvname = stash ? HvNAME(stash) : NULL;
342 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
344 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
346 /* Pants. I don't think that it should be possible to get here. */
347 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
350 #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
352 #ifdef PERL_IMPLICIT_CONTEXT
353 #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
355 #define croak_xs_usage S_croak_xs_usage
360 /* NOTE: the prototype of newXSproto() is different in versions of perls,
361 * so we define a portable version of newXSproto()
364 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
366 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
367 #endif /* !defined(newXS_flags) */
371 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
377 while (fetch_para()) {
378 # Print initial preprocessor statements and blank lines
379 while (@line && $line[0] !~ /^[^\#]/) {
380 my $line = shift(@line);
382 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
384 if ($statement eq 'if') {
385 $XSS_work_idx = @XSStack;
386 push(@XSStack, {type => 'if'});
388 death ("Error: `$statement' with no matching `if'")
389 if $XSStack[-1]{type} ne 'if';
390 if ($XSStack[-1]{varname}) {
391 push(@InitFileCode, "#endif\n");
392 push(@BootCode, "#endif");
395 my(@fns) = keys %{$XSStack[-1]{functions}};
396 if ($statement ne 'endif') {
397 # Hide the functions defined in other #if branches, and reset.
398 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
399 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
401 my($tmp) = pop(@XSStack);
402 0 while (--$XSS_work_idx
403 && $XSStack[$XSS_work_idx]{type} ne 'if');
404 # Keep all new defined functions
405 push(@fns, keys %{$tmp->{other_functions}});
406 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
411 next PARAGRAPH unless @line;
413 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
414 # We are inside an #if, but have not yet #defined its xsubpp variable.
415 print "#define $cpp_next_tmp 1\n\n";
416 push(@InitFileCode, "#if $cpp_next_tmp\n");
417 push(@BootCode, "#if $cpp_next_tmp");
418 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
421 death ("Code is not inside a function"
422 ." (maybe last function was ended by a blank line "
423 ." followed by a statement on column one?)")
424 if $line[0] =~ /^\s/;
426 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
427 my (@fake_INPUT_pre); # For length(s) generated variables
430 # initialize info arrays
436 undef($processing_arg_with_types) ;
437 undef(%argtype_seen) ;
441 undef($proto_in_this_xsub) ;
442 undef($scope_in_this_xsub) ;
444 undef($prepush_done);
445 $interface_macro = 'XSINTERFACE_FUNC' ;
446 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
447 $ProtoThisXSUB = $WantPrototypes ;
452 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
453 &{"${kwd}_handler"}() ;
454 next PARAGRAPH unless @line ;
458 if (check_keyword("BOOT")) {
460 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
461 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
462 push (@BootCode, @line, "") ;
467 # extract return type, function name and arguments
468 ($ret_type) = TidyType($_);
469 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
471 # Allow one-line ANSI-like declaration
474 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
476 # a function definition needs at least 2 lines
477 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
480 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
481 $static = 1 if $ret_type =~ s/^static\s+//;
483 $func_header = shift(@line);
484 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
485 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
487 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
488 $class = "$4 $class" if $4;
489 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
490 ($clean_func_name = $func_name) =~ s/^$Prefix//;
491 $Full_func_name = "${Packid}_$clean_func_name";
493 $Full_func_name = $SymSet->addsym($Full_func_name);
496 # Check for duplicate function definition
497 for my $tmp (@XSStack) {
498 next unless defined $tmp->{functions}{$Full_func_name};
499 Warn("Warning: duplicate function definition '$clean_func_name' detected");
502 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
503 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
506 $orig_args =~ s/\\\s*/ /g; # process line continuations
509 my %only_C_inlist; # Not in the signature of Perl function
510 if ($process_argtypes and $orig_args =~ /\S/) {
511 my $args = "$orig_args ,";
512 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
513 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
517 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
518 my ($pre, $name) = ($arg =~ /(.*?) \s*
519 \b ( \w+ | length\( \s*\w+\s* \) )
521 next unless defined($pre) && length($pre);
524 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
526 $out_type = $type if $type ne 'IN';
527 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
528 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
531 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
532 $name = "XSauto_length_of_$1";
534 die "Default value on length() argument: `$_'"
537 if (length $pre or $islength) { # Has a type
539 push @fake_INPUT_pre, $arg;
541 push @fake_INPUT, $arg;
543 # warn "pushing '$arg'\n";
544 $argtype_seen{$name}++;
545 $_ = "$name$default"; # Assigns to @args
547 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
548 push @outlist, $name if $out_type =~ /OUTLIST$/;
549 $in_out{$name} = $out_type if $out_type;
552 @args = split(/\s*,\s*/, $orig_args);
553 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
556 @args = split(/\s*,\s*/, $orig_args);
558 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
560 next if $out_type eq 'IN';
561 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
562 push @outlist, $name if $out_type =~ /OUTLIST$/;
563 $in_out{$_} = $out_type;
567 if (defined($class)) {
568 my $arg0 = ((defined($static) or $func_name eq 'new')
570 unshift(@args, $arg0);
575 my $report_args = '';
576 foreach my $i (0 .. $#args) {
577 if ($args[$i] =~ s/\.\.\.//) {
579 if ($args[$i] eq '' && $i == $#args) {
580 $report_args .= ", ...";
585 if ($only_C_inlist{$args[$i]}) {
586 push @args_num, undef;
588 push @args_num, ++$num_args;
589 $report_args .= ", $args[$i]";
591 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
594 $defaults{$args[$i]} = $2;
595 $defaults{$args[$i]} =~ s/"/\\"/g;
597 $proto_arg[$i+1] = '$' ;
599 $min_args = $num_args - $extra_args;
600 $report_args =~ s/"/\\"/g;
601 $report_args =~ s/^,\s+//;
602 my @func_args = @args;
603 shift @func_args if defined($class);
606 s/^/&/ if $in_out{$_};
608 $func_args = join(", ", @func_args);
609 @args_match{@args} = @args_num;
611 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
612 $CODE = grep(/^\s*CODE\s*:/, @line);
613 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
614 # to set explicit return values.
615 $EXPLICIT_RETURN = ($CODE &&
616 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
617 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
618 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
620 $xsreturn = 1 if $EXPLICIT_RETURN;
622 $externC = $externC ? qq[extern "C"] : "";
624 # print function header
627 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
628 #XS(XS_${Full_func_name})
636 print Q(<<"EOF") if $ALIAS ;
639 print Q(<<"EOF") if $INTERFACE ;
640 # dXSFUNCTION($ret_type);
643 $cond = ($min_args ? qq(items < $min_args) : 0);
644 } elsif ($min_args == $num_args) {
645 $cond = qq(items != $min_args);
647 $cond = qq(items < $min_args || items > $num_args);
650 print Q(<<"EOF") if $except;
658 # croak_xs_usage(cv, "$report_args");
661 # cv likely to be unused
663 # PERL_UNUSED_VAR(cv); /* -W */
667 #gcc -Wall: if an xsub has PPCODE is used
668 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
669 #hence `ax' (setup by dXSARGS) is unused
670 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
671 #but such a move could break third-party extensions
672 print Q(<<"EOF") if $PPCODE;
673 # PERL_UNUSED_VAR(ax); /* -Wall */
676 print Q(<<"EOF") if $PPCODE;
680 # Now do a block of some sort.
683 $cond = ''; # last CASE: condidional
684 push(@line, "$END:");
685 push(@line_no, $line_no[-1]);
689 &CASE_handler if check_keyword("CASE");
694 # do initialization of input variables
702 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
704 print Q(<<"EOF") if $ScopeThisXSUB;
709 if (!$thisdone && defined($class)) {
710 if (defined($static) or $func_name eq 'new') {
712 $var_types{"CLASS"} = "char *";
713 &generate_init("char *", 1, "CLASS");
717 $var_types{"THIS"} = "$class *";
718 &generate_init("$class *", 1, "THIS");
723 if (/^\s*NOT_IMPLEMENTED_YET/) {
724 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
727 if ($ret_type ne "void") {
728 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
730 $args_match{"RETVAL"} = 0;
731 $var_types{"RETVAL"} = $ret_type;
733 if $WantOptimize and $targetable{$type_kind{$ret_type}};
736 if (@fake_INPUT or @fake_INPUT_pre) {
737 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
739 $processing_arg_with_types = 1;
744 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
746 if (check_keyword("PPCODE")) {
748 death ("PPCODE must be last thing") if @line;
749 print "\tLEAVE;\n" if $ScopeThisXSUB;
750 print "\tPUTBACK;\n\treturn;\n";
751 } elsif (check_keyword("CODE")) {
753 } elsif (defined($class) and $func_name eq "DESTROY") {
755 print "delete THIS;\n";
758 if ($ret_type ne "void") {
762 if (defined($static)) {
763 if ($func_name eq 'new') {
764 $func_name = "$class";
768 } elsif (defined($class)) {
769 if ($func_name eq 'new') {
770 $func_name .= " $class";
775 $func_name =~ s/^\Q$args{'s'}//
776 if exists $args{'s'};
777 $func_name = 'XSFUNCTION' if $interface;
778 print "$func_name($func_args);\n";
782 # do output variables
783 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
784 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
785 # $wantRETVAL set if 'RETVAL =' autogenerated
786 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
788 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
790 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
791 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
793 # all OUTPUT done, so now push the return value on the stack
794 if ($gotRETVAL && $RETVAL_code) {
795 print "\t$RETVAL_code\n";
796 } elsif ($gotRETVAL || $wantRETVAL) {
797 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
799 my $type = $ret_type;
801 # 0: type, 1: with_size, 2: how, 3: how_size
802 if ($t and not $t->[1] and $t->[0] eq 'p') {
803 # PUSHp corresponds to setpvn. Treate setpv directly
804 my $what = eval qq("$t->[2]");
807 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
811 my $what = eval qq("$t->[2]");
815 $size = '' unless defined $size;
816 $size = eval qq("$size");
818 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
822 # RETVAL almost never needs SvSETMAGIC()
823 &generate_output($ret_type, 0, 'RETVAL', 0);
827 $xsreturn = 1 if $ret_type ne "void";
830 print "\tXSprePUSH;" if $c and not $prepush_done;
831 print "\tEXTEND(SP,$c);\n" if $c;
833 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
836 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
838 print Q(<<"EOF") if $ScopeThisXSUB;
841 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
845 # print function trailer
849 print Q(<<"EOF") if $except;
852 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
855 if (check_keyword("CASE")) {
856 blurt ("Error: No `CASE:' at top of function")
858 $_ = "CASE: $_"; # Restore CASE: label
861 last if $_ eq "$END:";
862 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
865 print Q(<<"EOF") if $except;
867 # Perl_croak(aTHX_ errbuf);
871 print Q(<<"EOF") unless $PPCODE;
872 # XSRETURN($xsreturn);
875 print Q(<<"EOF") unless $PPCODE;
885 our $newXS = "newXS" ;
888 # Build the prototype string for the xsub
889 if ($ProtoThisXSUB) {
890 $newXS = "newXSproto_portable";
892 if ($ProtoThisXSUB eq 2) {
893 # User has specified empty prototype
895 elsif ($ProtoThisXSUB eq 1) {
897 if ($min_args < $num_args) {
899 $proto_arg[$min_args] .= ";" ;
901 push @proto_arg, "$s\@"
904 $proto = join ("", grep defined, @proto_arg);
907 # User has specified a prototype
908 $proto = $ProtoThisXSUB;
910 $proto = qq{, "$proto"};
914 $XsubAliases{$pname} = 0
915 unless defined $XsubAliases{$pname} ;
916 while ( ($name, $value) = each %XsubAliases) {
917 push(@InitFileCode, Q(<<"EOF"));
918 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
919 # XSANY.any_i32 = $value ;
923 elsif (@Attributes) {
924 push(@InitFileCode, Q(<<"EOF"));
925 # cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);
926 # apply_attrs_string("$Package", cv, "@Attributes", 0);
930 while ( ($name, $value) = each %Interfaces) {
931 $name = "$Package\::$name" unless $name =~ /::/;
932 push(@InitFileCode, Q(<<"EOF"));
933 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
934 # $interface_macro_set(cv,$value) ;
938 elsif($newXS eq 'newXS'){ # work around P5NCI's empty newXS macro
940 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
944 " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
948 if ($Overload) # make it findable with fetchmethod
951 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
952 #XS(XS_${Packid}_nil)
959 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
960 /* Making a sub named "${Package}::()" allows the package */
961 /* to be findable via fetchmethod(), and causes */
962 /* overload::Overloaded("${Package}") to return true. */
963 (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto);
964 MAKE_FETCHMETHOD_WORK
967 # print initialization routine
976 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
977 #XS(boot_$Module_cname)
989 #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
990 #file name argument. If the wrong qualifier is used, it causes breakage with
991 #C++ compilers and warnings with recent gcc.
992 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
994 print Q(<<"EOF") if $Full_func_name;
995 ##if (PERL_REVISION == 5 && PERL_VERSION < 9)
996 # char* file = __FILE__;
998 # const char* file = __FILE__;
1005 # PERL_UNUSED_VAR(cv); /* -W */
1006 # PERL_UNUSED_VAR(items); /* -W */
1007 ##ifdef XS_APIVERSION_BOOTCHECK
1008 # XS_APIVERSION_BOOTCHECK;
1012 print Q(<<"EOF") if $WantVersionChk ;
1013 # XS_VERSION_BOOTCHECK ;
1017 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1023 print Q(<<"EOF") if ($Overload);
1024 # /* register the overloading (type 'A') magic */
1025 # PL_amagic_generation++;
1026 # /* The magic for overload gets a GV* via gv_fetchmeth as */
1027 # /* mentioned above, and looks in the SV* slot of it for */
1028 # /* the "fallback" status. */
1030 # get_sv( "${Package}::()", TRUE ),
1035 print @InitFileCode;
1037 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1043 print "\n /* Initialisation Section */\n\n" ;
1046 print "\n /* End of Initialisation Section */\n\n" ;
1050 ##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
1051 # if (PL_unitcheckav)
1052 # call_list(PL_scopestack_ix, PL_unitcheckav);
1062 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1067 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1073 sub errors { $errors }
1075 sub standard_typemap_locations {
1076 # Add all the default typemap locations to the search path
1077 my @tm = qw(typemap);
1079 my $updir = File::Spec->updir;
1080 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1081 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1083 unshift @tm, File::Spec->catfile($dir, 'typemap');
1084 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1086 foreach my $dir (@INC) {
1087 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1088 unshift @tm, $file if -e $file;
1095 $_[0] =~ s/^\s+|\s+$//go ;
1102 # rationalise any '*' by joining them into bunches and removing whitespace
1106 # change multiple whitespace into a single space
1109 # trim leading & trailing whitespace
1110 TrimWhitespace($_) ;
1115 # Input: ($_, @line) == unparsed input.
1116 # Output: ($_, @line) == (rest of line, following lines).
1117 # Return: the matched keyword if found, otherwise 0
1119 $_ = shift(@line) while !/\S/ && @line;
1120 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1124 # the "do" is required for right semantics
1125 do { $_ = shift(@line) } while !/\S/ && @line;
1127 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1128 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1129 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1132 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1138 while (!/\S/ && @line) {
1142 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1149 sub process_keyword($)
1154 &{"${kwd}_handler"}()
1155 while $kwd = check_keyword($pattern) ;
1159 blurt ("Error: `CASE:' after unconditional `CASE:'")
1160 if $condnum && $cond eq '';
1162 TrimWhitespace($cond);
1163 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1168 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1169 last if /^\s*NOT_IMPLEMENTED_YET/;
1170 next unless /\S/; # skip blank lines
1172 TrimWhitespace($_) ;
1175 # remove trailing semicolon if no initialisation
1176 s/\s*;$//g unless /[=;+].*\S/ ;
1178 # Process the length(foo) declarations
1179 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1180 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1181 $lengthof{$2} = $name;
1182 # $islengthof{$name} = $1;
1183 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
1186 # check for optional initialisation code
1188 $var_init = $1 if s/\s*([=;+].*)$//s ;
1189 $var_init =~ s/"/\\"/g;
1192 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1193 or blurt("Error: invalid argument declaration '$line'"), next;
1195 # Check for duplicate definitions
1196 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1197 if $arg_list{$var_name}++
1198 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1200 $thisdone |= $var_name eq "THIS";
1201 $retvaldone |= $var_name eq "RETVAL";
1202 $var_types{$var_name} = $var_type;
1203 # XXXX This check is a safeguard against the unfinished conversion of
1204 # generate_init(). When generate_init() is fixed,
1205 # one can use 2-args map_type() unconditionally.
1206 if ($var_type =~ / \( \s* \* \s* \) /x) {
1207 # Function pointers are not yet supported with &output_init!
1208 print "\t" . &map_type($var_type, $var_name);
1211 print "\t" . &map_type($var_type);
1214 $var_num = $args_match{$var_name};
1216 $proto_arg[$var_num] = ProtoString($var_type)
1218 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1219 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1220 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1221 and $var_init !~ /\S/) {
1222 if ($name_printed) {
1225 print "\t$var_name;\n";
1227 } elsif ($var_init =~ /\S/) {
1228 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1229 } elsif ($var_num) {
1230 # generate initialization code
1231 &generate_init($var_type, $var_num, $var_name, $name_printed);
1238 sub OUTPUT_handler {
1239 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1241 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1242 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1245 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1246 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1247 if $outargs{$outarg} ++ ;
1248 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1249 # deal with RETVAL last
1250 $RETVAL_code = $outcode ;
1254 blurt ("Error: OUTPUT $outarg not an argument"), next
1255 unless defined($args_match{$outarg});
1256 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1257 unless defined $var_types{$outarg} ;
1258 $var_num = $args_match{$outarg};
1260 print "\t$outcode\n";
1261 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1263 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1265 delete $in_out{$outarg} # No need to auto-OUTPUT
1266 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1270 sub C_ARGS_handler() {
1271 my $in = merge_section();
1273 TrimWhitespace($in);
1277 sub INTERFACE_MACRO_handler() {
1278 my $in = merge_section();
1280 TrimWhitespace($in);
1281 if ($in =~ /\s/) { # two
1282 ($interface_macro, $interface_macro_set) = split ' ', $in;
1284 $interface_macro = $in;
1285 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1287 $interface = 1; # local
1288 $Interfaces = 1; # global
1291 sub INTERFACE_handler() {
1292 my $in = merge_section();
1294 TrimWhitespace($in);
1296 foreach (split /[\s,]+/, $in) {
1298 $name =~ s/^$Prefix//;
1299 $Interfaces{$name} = $_;
1302 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1304 $interface = 1; # local
1305 $Interfaces = 1; # global
1308 sub CLEANUP_handler() { print_section() }
1309 sub PREINIT_handler() { print_section() }
1310 sub POSTCALL_handler() { print_section() }
1311 sub INIT_handler() { print_section() }
1316 my ($orig) = $line ;
1320 # Parse alias definitions
1322 # alias = value alias = value ...
1324 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1326 $orig_alias = $alias ;
1329 # check for optional package definition in the alias
1330 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1332 # check for duplicate alias name & duplicate value
1333 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1334 if defined $XsubAliases{$alias} ;
1336 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1337 if $XsubAliasValues{$value} ;
1340 $XsubAliases{$alias} = $value ;
1341 $XsubAliasValues{$value} = $orig_alias ;
1344 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1348 sub ATTRS_handler ()
1350 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1352 TrimWhitespace($_) ;
1353 push @Attributes, $_;
1357 sub ALIAS_handler ()
1359 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1361 TrimWhitespace($_) ;
1362 GetAliases($_) if $_ ;
1366 sub OVERLOAD_handler()
1368 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1370 TrimWhitespace($_) ;
1371 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1372 $Overload = 1 unless $Overload;
1373 my $overload = "$Package\::(".$1 ;
1375 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
1380 sub FALLBACK_handler()
1382 # the rest of the current line should contain either TRUE,
1385 TrimWhitespace($_) ;
1387 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1388 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1389 UNDEF => "&PL_sv_undef",
1392 # check for valid FALLBACK value
1393 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1395 $Fallback = $map{uc $_} ;
1399 sub REQUIRE_handler ()
1401 # the rest of the current line should contain a version number
1404 TrimWhitespace($Ver) ;
1406 death ("Error: REQUIRE expects a version number")
1409 # check that the version number is of the form n.n
1410 death ("Error: REQUIRE: expected a number, got '$Ver'")
1411 unless $Ver =~ /^\d+(\.\d*)?/ ;
1413 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1414 unless $VERSION >= $Ver ;
1417 sub VERSIONCHECK_handler ()
1419 # the rest of the current line should contain either ENABLE or
1422 TrimWhitespace($_) ;
1424 # check for ENABLE/DISABLE
1425 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1426 unless /^(ENABLE|DISABLE)/i ;
1428 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1429 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1433 sub PROTOTYPE_handler ()
1437 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1438 if $proto_in_this_xsub ++ ;
1440 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1443 TrimWhitespace($_) ;
1444 if ($_ eq 'DISABLE') {
1446 } elsif ($_ eq 'ENABLE') {
1449 # remove any whitespace
1451 death("Error: Invalid prototype '$_'")
1452 unless ValidProtoString($_) ;
1453 $ProtoThisXSUB = C_string($_) ;
1457 # If no prototype specified, then assume empty prototype ""
1458 $ProtoThisXSUB = 2 unless $specified ;
1464 sub SCOPE_handler ()
1466 death("Error: Only 1 SCOPE declaration allowed per xsub")
1467 if $scope_in_this_xsub ++ ;
1470 death ("Error: SCOPE: ENABLE/DISABLE")
1471 unless /^(ENABLE|DISABLE)\b/i;
1472 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
1475 sub PROTOTYPES_handler ()
1477 # the rest of the current line should contain either ENABLE or
1480 TrimWhitespace($_) ;
1482 # check for ENABLE/DISABLE
1483 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1484 unless /^(ENABLE|DISABLE)/i ;
1486 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1487 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1495 # Save the current file context.
1498 LastLine => $lastline,
1499 LastLineNo => $lastline_no,
1501 LineNo => \@line_no,
1502 Filename => $filename,
1503 Filepathname => $filepathname,
1505 IsPipe => scalar($filename =~ /\|\s*$/),
1511 sub INCLUDE_handler ()
1513 # the rest of the current line should contain a valid filename
1515 TrimWhitespace($_) ;
1517 death("INCLUDE: filename missing")
1520 death("INCLUDE: output pipe is illegal")
1523 # simple minded recursion detector
1524 death("INCLUDE loop detected")
1525 if $IncludedFiles{$_} ;
1527 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1529 if (/\|\s*$/ && /^\s*perl\s/) {
1530 Warn("The INCLUDE directive with a command is discouraged." .
1531 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1532 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1533 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1534 " the use of \$^X as the currently running perl, see" .
1535 " 'perldoc perlxs' for details.");
1540 $FH = Symbol::gensym();
1543 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1547 #/* INCLUDE: Including '$_' from '$filename' */
1552 $filepathname = File::Spec->catfile($dir, $filename);
1554 # Prime the pump by reading the first
1557 # skip leading blank lines
1559 last unless /^\s*$/ ;
1568 my @args = split /\s+/, $cmd;
1571 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
1573 return join (' ', ($cmd, @args));
1576 sub INCLUDE_COMMAND_handler ()
1578 # the rest of the current line should contain a valid command
1580 TrimWhitespace($_) ;
1582 $_ = QuoteArgs($_) if $^O eq 'VMS';
1584 death("INCLUDE_COMMAND: command missing")
1587 death("INCLUDE_COMMAND: pipes are illegal")
1588 if /^\s*\|/ or /\|\s*$/ ;
1590 PushXSStack( IsPipe => 1 );
1592 $FH = Symbol::gensym();
1594 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1595 # the same perl interpreter as we're currently running
1599 open ($FH, "-|", "$_")
1600 or death("Cannot run command '$_' to include its output: $!") ;
1604 #/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */
1609 $filepathname = $filename;
1610 $filepathname =~ s/\"/\\"/g;
1612 # Prime the pump by reading the first
1615 # skip leading blank lines
1617 last unless /^\s*$/ ;
1626 return 0 unless $XSStack[-1]{type} eq 'file' ;
1628 my $data = pop @XSStack ;
1629 my $ThisFile = $filename ;
1630 my $isPipe = $data->{IsPipe};
1632 -- $IncludedFiles{$filename}
1637 $FH = $data->{Handle} ;
1638 # $filename is the leafname, which for some reason isused for diagnostic
1639 # messages, whereas $filepathname is the full pathname, and is used for
1641 $filename = $data->{Filename} ;
1642 $filepathname = $data->{Filepathname} ;
1643 $lastline = $data->{LastLine} ;
1644 $lastline_no = $data->{LastLineNo} ;
1645 @line = @{ $data->{Line} } ;
1646 @line_no = @{ $data->{LineNo} } ;
1648 if ($isPipe and $? ) {
1650 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1656 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1663 sub ValidProtoString ($)
1667 if ( $string =~ /^$proto_re+$/ ) {
1678 $string =~ s[\\][\\\\]g ;
1686 $proto_letter{$type} or "\$" ;
1690 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1692 my ($cpp, $cpplevel);
1694 if ($cpp =~ /^\#\s*if/) {
1696 } elsif (!$cpplevel) {
1697 Warn("Warning: #else/elif/endif without #if in this function");
1698 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1699 if $XSStack[-1]{type} eq 'if';
1701 } elsif ($cpp =~ /^\#\s*endif/) {
1705 Warn("Warning: #if without #endif in this function") if $cpplevel;
1713 $text =~ s/\[\[/{/g;
1714 $text =~ s/\]\]/}/g;
1718 # Read next xsub into @line from ($lastline, <$FH>).
1721 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1722 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1725 return PopFile() if !defined $lastline;
1728 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1730 $Package = defined($2) ? $2 : ''; # keep -w happy
1731 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1732 $Prefix = quotemeta $Prefix ;
1733 ($Module_cname = $Module) =~ s/\W/_/g;
1734 ($Packid = $Package) =~ tr/:/_/;
1735 $Packprefix = $Package;
1736 $Packprefix .= "::" if $Packprefix ne "";
1741 # Skip embedded PODs
1742 while ($lastline =~ /^=/) {
1743 while ($lastline = <$FH>) {
1744 last if ($lastline =~ /^=cut\s*$/);
1746 death ("Error: Unterminated pod") unless $lastline;
1749 $lastline =~ s/^\s+$//;
1751 if ($lastline !~ /^\s*#/ ||
1753 # ANSI: if ifdef ifndef elif else endif define undef
1755 # gcc: warning include_next
1757 # others: ident (gcc notes that some cpps have this one)
1758 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1759 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1760 push(@line, $lastline);
1761 push(@line_no, $lastline_no) ;
1764 # Read next line and continuation lines
1765 last unless defined($lastline = <$FH>);
1768 $lastline .= $tmp_line
1769 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1772 $lastline =~ s/^\s+$//;
1774 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1779 local($type, $num, $var, $init, $name_printed) = @_;
1780 local($arg) = "ST(" . ($num - 1) . ")";
1782 if ( $init =~ /^=/ ) {
1783 if ($name_printed) {
1784 eval qq/print " $init\\n"/;
1786 eval qq/print "\\t$var $init\\n"/;
1790 if ( $init =~ s/^\+// && $num ) {
1791 &generate_init($type, $num, $var, $name_printed);
1792 } elsif ($name_printed) {
1796 eval qq/print "\\t$var;\\n"/;
1800 $deferred .= eval qq/"\\n\\t$init\\n"/;
1807 # work out the line number
1808 my $line_no = $line_no[@line_no - @line -1] ;
1810 print STDERR "@_ in $filename, line $line_no\n" ;
1826 local($type, $num, $var) = @_;
1827 local($arg) = "ST(" . ($num - 1) . ")";
1828 local($argoff) = $num - 1;
1832 $type = TidyType($type) ;
1833 blurt("Error: '$type' not in typemap"), return
1834 unless defined($type_kind{$type});
1836 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1837 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1838 $tk = $type_kind{$type};
1839 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1840 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1841 print "\t$var" unless $name_printed;
1842 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1843 die "default value not supported with length(NAME) supplied"
1844 if defined $defaults{$var};
1847 $type =~ tr/:/_/ unless $hiertype;
1848 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1849 unless defined $input_expr{$tk} ;
1850 $expr = $input_expr{$tk};
1851 if ($expr =~ /DO_ARRAY_ELEM/) {
1852 blurt("Error: '$subtype' not in typemap"), return
1853 unless defined($type_kind{$subtype});
1854 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1855 unless defined $input_expr{$type_kind{$subtype}} ;
1856 $subexpr = $input_expr{$type_kind{$subtype}};
1857 $subexpr =~ s/\$type/\$subtype/g;
1858 $subexpr =~ s/ntype/subtype/g;
1859 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1860 $subexpr =~ s/\n\t/\n\t\t/g;
1861 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1862 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1863 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1865 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1868 if (defined($defaults{$var})) {
1869 $expr =~ s/(\t+)/$1 /g;
1871 if ($name_printed) {
1874 eval qq/print "\\t$var;\\n"/;
1877 if ($defaults{$var} eq 'NO_INIT') {
1878 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1880 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1883 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1884 if ($name_printed) {
1887 eval qq/print "\\t$var;\\n"/;
1890 $deferred .= eval qq/"\\n$expr;\\n"/;
1893 die "panic: do not know how to handle this branch for function pointers"
1895 eval qq/print "$expr;\\n"/;
1900 sub generate_output {
1901 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1902 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1903 local($argoff) = $num - 1;
1906 $type = TidyType($type) ;
1907 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1908 print "\t$arg = sv_newmortal();\n";
1909 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1910 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1912 blurt("Error: '$type' not in typemap"), return
1913 unless defined($type_kind{$type});
1914 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1915 unless defined $output_expr{$type_kind{$type}} ;
1916 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1917 $ntype =~ s/\(\)//g;
1918 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1919 $expr = $output_expr{$type_kind{$type}};
1920 if ($expr =~ /DO_ARRAY_ELEM/) {
1921 blurt("Error: '$subtype' not in typemap"), return
1922 unless defined($type_kind{$subtype});
1923 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1924 unless defined $output_expr{$type_kind{$subtype}} ;
1925 $subexpr = $output_expr{$type_kind{$subtype}};
1926 $subexpr =~ s/ntype/subtype/g;
1927 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1928 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1929 $subexpr =~ s/\n\t/\n\t\t/g;
1930 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1931 eval "print qq\a$expr\a";
1933 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1934 } elsif ($var eq 'RETVAL') {
1935 if ($expr =~ /^\t\$arg = new/) {
1936 # We expect that $arg has refcnt 1, so we need to
1938 eval "print qq\a$expr\a";
1940 print "\tsv_2mortal(ST($num));\n";
1941 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1942 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1943 # We expect that $arg has refcnt >=1, so we need
1945 eval "print qq\a$expr\a";
1947 print "\tsv_2mortal(ST(0));\n";
1948 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1950 # Just hope that the entry would safely write it
1951 # over an already mortalized value. By
1952 # coincidence, something like $arg = &sv_undef
1954 print "\tST(0) = sv_newmortal();\n";
1955 eval "print qq\a$expr\a";
1957 # new mortals don't have set magic
1959 } elsif ($do_push) {
1960 print "\tPUSHs(sv_newmortal());\n";
1962 eval "print qq\a$expr\a";
1964 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1965 } elsif ($arg =~ /^ST\(\d+\)$/) {
1966 eval "print qq\a$expr\a";
1968 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1974 my($type, $varname) = @_;
1976 # C++ has :: in types too so skip this
1977 $type =~ tr/:/_/ unless $hiertype;
1978 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1980 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1981 (substr $type, pos $type, 0) = " $varname ";
1983 $type .= "\t$varname";
1990 #########################################################
1992 ExtUtils::ParseXS::CountLines;
1994 use vars qw($SECTION_END_MARKER);
1997 my ($class, $cfile, $fh) = @_;
1998 $cfile =~ s/\\/\\\\/g;
1999 $SECTION_END_MARKER = qq{#line --- "$cfile"};
2001 return bless {buffer => '',
2010 $self->{buffer} .= $_;
2011 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
2013 ++ $self->{line_no};
2014 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
2015 print {$self->{fh}} $line;
2023 $self->PRINT(sprintf($fmt, @_));
2027 # Not necessary if we're careful to end with a "\n"
2029 print {$self->{fh}} $self->{buffer};
2033 # This sub does nothing, but is neccessary for references to be released.
2037 return $SECTION_END_MARKER;
2046 ExtUtils::ParseXS - converts Perl XS code into C code
2050 use ExtUtils::ParseXS qw(process_file);
2052 process_file( filename => 'foo.xs' );
2054 process_file( filename => 'foo.xs',
2057 typemap => 'path/to/typemap',
2068 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
2069 necessary to let C functions manipulate Perl values and creates the glue
2070 necessary to let Perl access those functions. The compiler uses typemaps to
2071 determine how to map C function parameters and variables to Perl values.
2073 The compiler will search for typemap files called I<typemap>. It will use
2074 the following search path to find default typemaps, with the rightmost
2075 typemap taking precedence.
2077 ../../../typemap:../../typemap:../typemap:typemap
2081 None by default. C<process_file()> may be exported upon request.
2090 This function processes an XS file and sends output to a C file.
2091 Named parameters control how the processing is done. The following
2092 parameters are accepted:
2098 Adds C<extern "C"> to the C code. Default is false.
2102 Retains C<::> in type names so that C++ hierachical types can be
2103 mapped. Default is false.
2107 Adds exception handling stubs to the C code. Default is false.
2111 Indicates that a user-supplied typemap should take precedence over the
2112 default typemaps. A single typemap may be specified as a string, or
2113 multiple typemaps can be specified in an array reference, with the
2114 last typemap having the highest precedence.
2118 Generates prototype code for all xsubs. Default is false.
2120 =item B<versioncheck>
2122 Makes sure at run time that the object file (derived from the C<.xs>
2123 file) and the C<.pm> files have the same version number. Default is
2126 =item B<linenumbers>
2128 Adds C<#line> directives to the C output so error messages will look
2129 like they came from the original XS file. Default is true.
2133 Enables certain optimizations. The only optimization that is currently
2134 affected is the use of I<target>s by the output C code (see L<perlguts>).
2135 Not optimizing may significantly slow down the generated code, but this is the way
2136 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2140 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2141 declarations. Default is true.
2145 Enable recognition of ANSI-like descriptions of function signature.
2150 I have no clue what this does. Strips function prefixes?
2156 This function returns the number of [a certain kind of] errors
2157 encountered during processing of the XS file.
2163 Based on xsubpp code, written by Larry Wall.
2171 Ken Williams, <ken@mathforum.org>
2175 David Golden, <dagolden@cpan.org>
2181 Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All
2184 This library is free software; you can redistribute it and/or
2185 modify it under the same terms as Perl itself.
2187 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2188 Porters, which was released under the same license terms.
2192 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.