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 venerated 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 */
1009 print Q(<<"EOF") if $WantVersionChk ;
1010 # XS_VERSION_BOOTCHECK ;
1014 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1020 print Q(<<"EOF") if ($Overload);
1021 # /* register the overloading (type 'A') magic */
1022 # PL_amagic_generation++;
1023 # /* The magic for overload gets a GV* via gv_fetchmeth as */
1024 # /* mentioned above, and looks in the SV* slot of it for */
1025 # /* the "fallback" status. */
1027 # get_sv( "${Package}::()", TRUE ),
1032 print @InitFileCode;
1034 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1040 print "\n /* Initialisation Section */\n\n" ;
1043 print "\n /* End of Initialisation Section */\n\n" ;
1047 ##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
1048 # if (PL_unitcheckav)
1049 # call_list(PL_scopestack_ix, PL_unitcheckav);
1059 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1064 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1070 sub errors { $errors }
1072 sub standard_typemap_locations {
1073 # Add all the default typemap locations to the search path
1074 my @tm = qw(typemap);
1076 my $updir = File::Spec->updir;
1077 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1078 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1080 unshift @tm, File::Spec->catfile($dir, 'typemap');
1081 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1083 foreach my $dir (@INC) {
1084 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1085 unshift @tm, $file if -e $file;
1092 $_[0] =~ s/^\s+|\s+$//go ;
1099 # rationalise any '*' by joining them into bunches and removing whitespace
1103 # change multiple whitespace into a single space
1106 # trim leading & trailing whitespace
1107 TrimWhitespace($_) ;
1112 # Input: ($_, @line) == unparsed input.
1113 # Output: ($_, @line) == (rest of line, following lines).
1114 # Return: the matched keyword if found, otherwise 0
1116 $_ = shift(@line) while !/\S/ && @line;
1117 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1121 # the "do" is required for right semantics
1122 do { $_ = shift(@line) } while !/\S/ && @line;
1124 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1125 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1126 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1129 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1135 while (!/\S/ && @line) {
1139 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1146 sub process_keyword($)
1151 &{"${kwd}_handler"}()
1152 while $kwd = check_keyword($pattern) ;
1156 blurt ("Error: `CASE:' after unconditional `CASE:'")
1157 if $condnum && $cond eq '';
1159 TrimWhitespace($cond);
1160 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1165 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1166 last if /^\s*NOT_IMPLEMENTED_YET/;
1167 next unless /\S/; # skip blank lines
1169 TrimWhitespace($_) ;
1172 # remove trailing semicolon if no initialisation
1173 s/\s*;$//g unless /[=;+].*\S/ ;
1175 # Process the length(foo) declarations
1176 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1177 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1178 $lengthof{$2} = $name;
1179 # $islengthof{$name} = $1;
1180 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
1183 # check for optional initialisation code
1185 $var_init = $1 if s/\s*([=;+].*)$//s ;
1186 $var_init =~ s/"/\\"/g;
1189 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1190 or blurt("Error: invalid argument declaration '$line'"), next;
1192 # Check for duplicate definitions
1193 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1194 if $arg_list{$var_name}++
1195 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1197 $thisdone |= $var_name eq "THIS";
1198 $retvaldone |= $var_name eq "RETVAL";
1199 $var_types{$var_name} = $var_type;
1200 # XXXX This check is a safeguard against the unfinished conversion of
1201 # generate_init(). When generate_init() is fixed,
1202 # one can use 2-args map_type() unconditionally.
1203 if ($var_type =~ / \( \s* \* \s* \) /x) {
1204 # Function pointers are not yet supported with &output_init!
1205 print "\t" . &map_type($var_type, $var_name);
1208 print "\t" . &map_type($var_type);
1211 $var_num = $args_match{$var_name};
1213 $proto_arg[$var_num] = ProtoString($var_type)
1215 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1216 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1217 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1218 and $var_init !~ /\S/) {
1219 if ($name_printed) {
1222 print "\t$var_name;\n";
1224 } elsif ($var_init =~ /\S/) {
1225 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1226 } elsif ($var_num) {
1227 # generate initialization code
1228 &generate_init($var_type, $var_num, $var_name, $name_printed);
1235 sub OUTPUT_handler {
1236 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1238 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1239 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1242 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1243 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1244 if $outargs{$outarg} ++ ;
1245 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1246 # deal with RETVAL last
1247 $RETVAL_code = $outcode ;
1251 blurt ("Error: OUTPUT $outarg not an argument"), next
1252 unless defined($args_match{$outarg});
1253 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1254 unless defined $var_types{$outarg} ;
1255 $var_num = $args_match{$outarg};
1257 print "\t$outcode\n";
1258 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1260 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1262 delete $in_out{$outarg} # No need to auto-OUTPUT
1263 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1267 sub C_ARGS_handler() {
1268 my $in = merge_section();
1270 TrimWhitespace($in);
1274 sub INTERFACE_MACRO_handler() {
1275 my $in = merge_section();
1277 TrimWhitespace($in);
1278 if ($in =~ /\s/) { # two
1279 ($interface_macro, $interface_macro_set) = split ' ', $in;
1281 $interface_macro = $in;
1282 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1284 $interface = 1; # local
1285 $Interfaces = 1; # global
1288 sub INTERFACE_handler() {
1289 my $in = merge_section();
1291 TrimWhitespace($in);
1293 foreach (split /[\s,]+/, $in) {
1295 $name =~ s/^$Prefix//;
1296 $Interfaces{$name} = $_;
1299 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1301 $interface = 1; # local
1302 $Interfaces = 1; # global
1305 sub CLEANUP_handler() { print_section() }
1306 sub PREINIT_handler() { print_section() }
1307 sub POSTCALL_handler() { print_section() }
1308 sub INIT_handler() { print_section() }
1313 my ($orig) = $line ;
1317 # Parse alias definitions
1319 # alias = value alias = value ...
1321 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1323 $orig_alias = $alias ;
1326 # check for optional package definition in the alias
1327 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1329 # check for duplicate alias name & duplicate value
1330 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1331 if defined $XsubAliases{$alias} ;
1333 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1334 if $XsubAliasValues{$value} ;
1337 $XsubAliases{$alias} = $value ;
1338 $XsubAliasValues{$value} = $orig_alias ;
1341 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1345 sub ATTRS_handler ()
1347 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1349 TrimWhitespace($_) ;
1350 push @Attributes, $_;
1354 sub ALIAS_handler ()
1356 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1358 TrimWhitespace($_) ;
1359 GetAliases($_) if $_ ;
1363 sub OVERLOAD_handler()
1365 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1367 TrimWhitespace($_) ;
1368 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1369 $Overload = 1 unless $Overload;
1370 my $overload = "$Package\::(".$1 ;
1372 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
1377 sub FALLBACK_handler()
1379 # the rest of the current line should contain either TRUE,
1382 TrimWhitespace($_) ;
1384 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1385 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1386 UNDEF => "&PL_sv_undef",
1389 # check for valid FALLBACK value
1390 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1392 $Fallback = $map{uc $_} ;
1396 sub REQUIRE_handler ()
1398 # the rest of the current line should contain a version number
1401 TrimWhitespace($Ver) ;
1403 death ("Error: REQUIRE expects a version number")
1406 # check that the version number is of the form n.n
1407 death ("Error: REQUIRE: expected a number, got '$Ver'")
1408 unless $Ver =~ /^\d+(\.\d*)?/ ;
1410 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1411 unless $VERSION >= $Ver ;
1414 sub VERSIONCHECK_handler ()
1416 # the rest of the current line should contain either ENABLE or
1419 TrimWhitespace($_) ;
1421 # check for ENABLE/DISABLE
1422 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1423 unless /^(ENABLE|DISABLE)/i ;
1425 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1426 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1430 sub PROTOTYPE_handler ()
1434 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1435 if $proto_in_this_xsub ++ ;
1437 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1440 TrimWhitespace($_) ;
1441 if ($_ eq 'DISABLE') {
1443 } elsif ($_ eq 'ENABLE') {
1446 # remove any whitespace
1448 death("Error: Invalid prototype '$_'")
1449 unless ValidProtoString($_) ;
1450 $ProtoThisXSUB = C_string($_) ;
1454 # If no prototype specified, then assume empty prototype ""
1455 $ProtoThisXSUB = 2 unless $specified ;
1461 sub SCOPE_handler ()
1463 death("Error: Only 1 SCOPE declaration allowed per xsub")
1464 if $scope_in_this_xsub ++ ;
1467 death ("Error: SCOPE: ENABLE/DISABLE")
1468 unless /^(ENABLE|DISABLE)\b/i;
1469 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
1472 sub PROTOTYPES_handler ()
1474 # the rest of the current line should contain either ENABLE or
1477 TrimWhitespace($_) ;
1479 # check for ENABLE/DISABLE
1480 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1481 unless /^(ENABLE|DISABLE)/i ;
1483 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1484 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1492 # Save the current file context.
1495 LastLine => $lastline,
1496 LastLineNo => $lastline_no,
1498 LineNo => \@line_no,
1499 Filename => $filename,
1500 Filepathname => $filepathname,
1502 IsPipe => scalar($filename =~ /\|\s*$/),
1508 sub INCLUDE_handler ()
1510 # the rest of the current line should contain a valid filename
1512 TrimWhitespace($_) ;
1514 death("INCLUDE: filename missing")
1517 death("INCLUDE: output pipe is illegal")
1520 # simple minded recursion detector
1521 death("INCLUDE loop detected")
1522 if $IncludedFiles{$_} ;
1524 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1526 if (/\|\s*$/ && /^\s*perl\s/) {
1527 Warn("The INCLUDE directive with a command is discouraged." .
1528 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1529 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1530 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1531 " the use of \$^X as the currently running perl, see" .
1532 " 'perldoc perlxs' for details.");
1537 $FH = Symbol::gensym();
1540 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1544 #/* INCLUDE: Including '$_' from '$filename' */
1549 $filepathname = File::Spec->catfile($dir, $filename);
1551 # Prime the pump by reading the first
1554 # skip leading blank lines
1556 last unless /^\s*$/ ;
1565 my @args = split /\s+/, $cmd;
1568 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
1570 return join (' ', ($cmd, @args));
1573 sub INCLUDE_COMMAND_handler ()
1575 # the rest of the current line should contain a valid command
1577 TrimWhitespace($_) ;
1579 $_ = QuoteArgs($_) if $^O eq 'VMS';
1581 death("INCLUDE_COMMAND: command missing")
1584 death("INCLUDE_COMMAND: pipes are illegal")
1585 if /^\s*\|/ or /\|\s*$/ ;
1587 PushXSStack( IsPipe => 1 );
1589 $FH = Symbol::gensym();
1591 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1592 # the same perl interpreter as we're currently running
1596 open ($FH, "-|", "$_")
1597 or death("Cannot run command '$_' to include its output: $!") ;
1601 #/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */
1606 $filepathname = $filename;
1607 $filepathname =~ s/\"/\\"/g;
1609 # Prime the pump by reading the first
1612 # skip leading blank lines
1614 last unless /^\s*$/ ;
1623 return 0 unless $XSStack[-1]{type} eq 'file' ;
1625 my $data = pop @XSStack ;
1626 my $ThisFile = $filename ;
1627 my $isPipe = $data->{IsPipe};
1629 -- $IncludedFiles{$filename}
1634 $FH = $data->{Handle} ;
1635 # $filename is the leafname, which for some reason isused for diagnostic
1636 # messages, whereas $filepathname is the full pathname, and is used for
1638 $filename = $data->{Filename} ;
1639 $filepathname = $data->{Filepathname} ;
1640 $lastline = $data->{LastLine} ;
1641 $lastline_no = $data->{LastLineNo} ;
1642 @line = @{ $data->{Line} } ;
1643 @line_no = @{ $data->{LineNo} } ;
1645 if ($isPipe and $? ) {
1647 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1653 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1660 sub ValidProtoString ($)
1664 if ( $string =~ /^$proto_re+$/ ) {
1675 $string =~ s[\\][\\\\]g ;
1683 $proto_letter{$type} or "\$" ;
1687 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1689 my ($cpp, $cpplevel);
1691 if ($cpp =~ /^\#\s*if/) {
1693 } elsif (!$cpplevel) {
1694 Warn("Warning: #else/elif/endif without #if in this function");
1695 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1696 if $XSStack[-1]{type} eq 'if';
1698 } elsif ($cpp =~ /^\#\s*endif/) {
1702 Warn("Warning: #if without #endif in this function") if $cpplevel;
1710 $text =~ s/\[\[/{/g;
1711 $text =~ s/\]\]/}/g;
1715 # Read next xsub into @line from ($lastline, <$FH>).
1718 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1719 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1722 return PopFile() if !defined $lastline;
1725 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1727 $Package = defined($2) ? $2 : ''; # keep -w happy
1728 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1729 $Prefix = quotemeta $Prefix ;
1730 ($Module_cname = $Module) =~ s/\W/_/g;
1731 ($Packid = $Package) =~ tr/:/_/;
1732 $Packprefix = $Package;
1733 $Packprefix .= "::" if $Packprefix ne "";
1738 # Skip embedded PODs
1739 while ($lastline =~ /^=/) {
1740 while ($lastline = <$FH>) {
1741 last if ($lastline =~ /^=cut\s*$/);
1743 death ("Error: Unterminated pod") unless $lastline;
1746 $lastline =~ s/^\s+$//;
1748 if ($lastline !~ /^\s*#/ ||
1750 # ANSI: if ifdef ifndef elif else endif define undef
1752 # gcc: warning include_next
1754 # others: ident (gcc notes that some cpps have this one)
1755 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1756 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1757 push(@line, $lastline);
1758 push(@line_no, $lastline_no) ;
1761 # Read next line and continuation lines
1762 last unless defined($lastline = <$FH>);
1765 $lastline .= $tmp_line
1766 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1769 $lastline =~ s/^\s+$//;
1771 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1776 local($type, $num, $var, $init, $name_printed) = @_;
1777 local($arg) = "ST(" . ($num - 1) . ")";
1779 if ( $init =~ /^=/ ) {
1780 if ($name_printed) {
1781 eval qq/print " $init\\n"/;
1783 eval qq/print "\\t$var $init\\n"/;
1787 if ( $init =~ s/^\+// && $num ) {
1788 &generate_init($type, $num, $var, $name_printed);
1789 } elsif ($name_printed) {
1793 eval qq/print "\\t$var;\\n"/;
1797 $deferred .= eval qq/"\\n\\t$init\\n"/;
1804 # work out the line number
1805 my $line_no = $line_no[@line_no - @line -1] ;
1807 print STDERR "@_ in $filename, line $line_no\n" ;
1823 local($type, $num, $var) = @_;
1824 local($arg) = "ST(" . ($num - 1) . ")";
1825 local($argoff) = $num - 1;
1829 $type = TidyType($type) ;
1830 blurt("Error: '$type' not in typemap"), return
1831 unless defined($type_kind{$type});
1833 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1834 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1835 $tk = $type_kind{$type};
1836 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1837 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1838 print "\t$var" unless $name_printed;
1839 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1840 die "default value not supported with length(NAME) supplied"
1841 if defined $defaults{$var};
1844 $type =~ tr/:/_/ unless $hiertype;
1845 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1846 unless defined $input_expr{$tk} ;
1847 $expr = $input_expr{$tk};
1848 if ($expr =~ /DO_ARRAY_ELEM/) {
1849 blurt("Error: '$subtype' not in typemap"), return
1850 unless defined($type_kind{$subtype});
1851 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1852 unless defined $input_expr{$type_kind{$subtype}} ;
1853 $subexpr = $input_expr{$type_kind{$subtype}};
1854 $subexpr =~ s/\$type/\$subtype/g;
1855 $subexpr =~ s/ntype/subtype/g;
1856 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1857 $subexpr =~ s/\n\t/\n\t\t/g;
1858 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1859 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1860 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1862 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1865 if (defined($defaults{$var})) {
1866 $expr =~ s/(\t+)/$1 /g;
1868 if ($name_printed) {
1871 eval qq/print "\\t$var;\\n"/;
1874 if ($defaults{$var} eq 'NO_INIT') {
1875 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1877 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1880 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1881 if ($name_printed) {
1884 eval qq/print "\\t$var;\\n"/;
1887 $deferred .= eval qq/"\\n$expr;\\n"/;
1890 die "panic: do not know how to handle this branch for function pointers"
1892 eval qq/print "$expr;\\n"/;
1897 sub generate_output {
1898 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1899 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1900 local($argoff) = $num - 1;
1903 $type = TidyType($type) ;
1904 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1905 print "\t$arg = sv_newmortal();\n";
1906 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1907 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1909 blurt("Error: '$type' not in typemap"), return
1910 unless defined($type_kind{$type});
1911 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1912 unless defined $output_expr{$type_kind{$type}} ;
1913 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1914 $ntype =~ s/\(\)//g;
1915 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1916 $expr = $output_expr{$type_kind{$type}};
1917 if ($expr =~ /DO_ARRAY_ELEM/) {
1918 blurt("Error: '$subtype' not in typemap"), return
1919 unless defined($type_kind{$subtype});
1920 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1921 unless defined $output_expr{$type_kind{$subtype}} ;
1922 $subexpr = $output_expr{$type_kind{$subtype}};
1923 $subexpr =~ s/ntype/subtype/g;
1924 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1925 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1926 $subexpr =~ s/\n\t/\n\t\t/g;
1927 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1928 eval "print qq\a$expr\a";
1930 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1931 } elsif ($var eq 'RETVAL') {
1932 if ($expr =~ /^\t\$arg = new/) {
1933 # We expect that $arg has refcnt 1, so we need to
1935 eval "print qq\a$expr\a";
1937 print "\tsv_2mortal(ST($num));\n";
1938 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1939 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1940 # We expect that $arg has refcnt >=1, so we need
1942 eval "print qq\a$expr\a";
1944 print "\tsv_2mortal(ST(0));\n";
1945 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1947 # Just hope that the entry would safely write it
1948 # over an already mortalized value. By
1949 # coincidence, something like $arg = &sv_undef
1951 print "\tST(0) = sv_newmortal();\n";
1952 eval "print qq\a$expr\a";
1954 # new mortals don't have set magic
1956 } elsif ($do_push) {
1957 print "\tPUSHs(sv_newmortal());\n";
1959 eval "print qq\a$expr\a";
1961 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1962 } elsif ($arg =~ /^ST\(\d+\)$/) {
1963 eval "print qq\a$expr\a";
1965 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1971 my($type, $varname) = @_;
1973 # C++ has :: in types too so skip this
1974 $type =~ tr/:/_/ unless $hiertype;
1975 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1977 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1978 (substr $type, pos $type, 0) = " $varname ";
1980 $type .= "\t$varname";
1987 #########################################################
1989 ExtUtils::ParseXS::CountLines;
1991 use vars qw($SECTION_END_MARKER);
1994 my ($class, $cfile, $fh) = @_;
1995 $cfile =~ s/\\/\\\\/g;
1996 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1998 return bless {buffer => '',
2007 $self->{buffer} .= $_;
2008 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
2010 ++ $self->{line_no};
2011 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
2012 print {$self->{fh}} $line;
2020 $self->PRINT(sprintf($fmt, @_));
2024 # Not necessary if we're careful to end with a "\n"
2026 print {$self->{fh}} $self->{buffer};
2030 # This sub does nothing, but is neccessary for references to be released.
2034 return $SECTION_END_MARKER;
2043 ExtUtils::ParseXS - converts Perl XS code into C code
2047 use ExtUtils::ParseXS qw(process_file);
2049 process_file( filename => 'foo.xs' );
2051 process_file( filename => 'foo.xs',
2054 typemap => 'path/to/typemap',
2065 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
2066 necessary to let C functions manipulate Perl values and creates the glue
2067 necessary to let Perl access those functions. The compiler uses typemaps to
2068 determine how to map C function parameters and variables to Perl values.
2070 The compiler will search for typemap files called I<typemap>. It will use
2071 the following search path to find default typemaps, with the rightmost
2072 typemap taking precedence.
2074 ../../../typemap:../../typemap:../typemap:typemap
2078 None by default. C<process_file()> may be exported upon request.
2087 This function processes an XS file and sends output to a C file.
2088 Named parameters control how the processing is done. The following
2089 parameters are accepted:
2095 Adds C<extern "C"> to the C code. Default is false.
2099 Retains C<::> in type names so that C++ hierachical types can be
2100 mapped. Default is false.
2104 Adds exception handling stubs to the C code. Default is false.
2108 Indicates that a user-supplied typemap should take precedence over the
2109 default typemaps. A single typemap may be specified as a string, or
2110 multiple typemaps can be specified in an array reference, with the
2111 last typemap having the highest precedence.
2115 Generates prototype code for all xsubs. Default is false.
2117 =item B<versioncheck>
2119 Makes sure at run time that the object file (derived from the C<.xs>
2120 file) and the C<.pm> files have the same version number. Default is
2123 =item B<linenumbers>
2125 Adds C<#line> directives to the C output so error messages will look
2126 like they came from the original XS file. Default is true.
2130 Enables certain optimizations. The only optimization that is currently
2131 affected is the use of I<target>s by the output C code (see L<perlguts>).
2132 Not optimizing may significantly slow down the generated code, but this is the way
2133 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2137 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2138 declarations. Default is true.
2142 Enable recognition of ANSI-like descriptions of function signature.
2147 I have no clue what this does. Strips function prefixes?
2153 This function returns the number of [a certain kind of] errors
2154 encountered during processing of the XS file.
2160 Based on xsubpp code, written by Larry Wall.
2168 Ken Williams, <ken@mathforum.org>
2172 David Golden, <dagolden@cpan.org>
2178 Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All
2181 This library is free software; you can redistribute it and/or
2182 modify it under the same terms as Perl itself.
2184 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2185 Porters, which was released under the same license terms.
2189 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.