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);
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 OUTPUT
234 CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
235 SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
239 our ($C_group_rex, $C_arg);
240 # Group in C (no support for comments or literals)
241 $C_group_rex = qr/ [({\[]
242 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
244 # Chunk in C without comma at toplevel (no comments):
245 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
246 | (??{ $C_group_rex })
247 | " (?: (?> [^\\"]+ )
249 )* " # String literal
250 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
253 # Identify the version of xsubpp used
256 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
257 * contents of $filename. Do not edit this file, edit $filename instead.
259 * ANY CHANGES MADE HERE WILL BE LOST!
266 print("#line 1 \"$filepathname\"\n")
272 my $podstartline = $.;
275 # We can't just write out a /* */ comment, as our embedded
276 # POD might itself be in a comment. We can't put a /**/
277 # comment inside #if 0, as the C standard says that the source
278 # file is decomposed into preprocessing characters in the stage
279 # before preprocessing commands are executed.
280 # I don't want to leave the text as barewords, because the spec
281 # isn't clear whether macros are expanded before or after
282 # preprocessing commands are executed, and someone pathological
283 # may just have defined one of the 3 words as a macro that does
284 # something strange. Multiline strings are illegal in C, so
285 # the "" we write must be a string literal. And they aren't
286 # concatenated until 2 steps later, so we are safe.
288 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
289 printf("#line %d \"$filepathname\"\n", $. + 1)
295 # At this point $. is at end of file so die won't state the start
296 # of the problem, and as we haven't yet read any lines &death won't
297 # show the correct line in the message either.
298 die ("Error: Unterminated pod in $filename, line $podstartline\n")
301 last if ($Package, $Prefix) =
302 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
306 unless (defined $_) {
307 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
308 exit 0; # Not a fatal error for the caller process
311 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
314 #ifndef PERL_UNUSED_VAR
315 # define PERL_UNUSED_VAR(var) if (0) var = var
321 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
322 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
324 /* prototype to pass -Wmissing-prototypes */
326 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
329 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
331 const GV *const gv = CvGV(cv);
333 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
336 const char *const gvname = GvNAME(gv);
337 const HV *const stash = GvSTASH(gv);
338 const char *const hvname = stash ? HvNAME(stash) : NULL;
341 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
343 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
345 /* Pants. I don't think that it should be possible to get here. */
346 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
349 #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
351 #ifdef PERL_IMPLICIT_CONTEXT
352 #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
354 #define croak_xs_usage S_croak_xs_usage
359 /* NOTE: the prototype of newXSproto() is different in versions of perls,
360 * so we define a portable version of newXSproto()
363 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
365 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
366 #endif /* !defined(newXS_flags) */
370 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
376 while (fetch_para()) {
377 # Print initial preprocessor statements and blank lines
378 while (@line && $line[0] !~ /^[^\#]/) {
379 my $line = shift(@line);
381 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
383 if ($statement eq 'if') {
384 $XSS_work_idx = @XSStack;
385 push(@XSStack, {type => 'if'});
387 death ("Error: `$statement' with no matching `if'")
388 if $XSStack[-1]{type} ne 'if';
389 if ($XSStack[-1]{varname}) {
390 push(@InitFileCode, "#endif\n");
391 push(@BootCode, "#endif");
394 my(@fns) = keys %{$XSStack[-1]{functions}};
395 if ($statement ne 'endif') {
396 # Hide the functions defined in other #if branches, and reset.
397 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
398 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
400 my($tmp) = pop(@XSStack);
401 0 while (--$XSS_work_idx
402 && $XSStack[$XSS_work_idx]{type} ne 'if');
403 # Keep all new defined functions
404 push(@fns, keys %{$tmp->{other_functions}});
405 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
410 next PARAGRAPH unless @line;
412 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
413 # We are inside an #if, but have not yet #defined its xsubpp variable.
414 print "#define $cpp_next_tmp 1\n\n";
415 push(@InitFileCode, "#if $cpp_next_tmp\n");
416 push(@BootCode, "#if $cpp_next_tmp");
417 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
420 death ("Code is not inside a function"
421 ." (maybe last function was ended by a blank line "
422 ." followed by a statement on column one?)")
423 if $line[0] =~ /^\s/;
425 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
426 my (@fake_INPUT_pre); # For length(s) generated variables
429 # initialize info arrays
435 undef($processing_arg_with_types) ;
436 undef(%argtype_seen) ;
440 undef($proto_in_this_xsub) ;
441 undef($scope_in_this_xsub) ;
443 undef($prepush_done);
444 $interface_macro = 'XSINTERFACE_FUNC' ;
445 $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
446 $ProtoThisXSUB = $WantPrototypes ;
451 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE|SCOPE")) {
452 &{"${kwd}_handler"}() ;
453 next PARAGRAPH unless @line ;
457 if (check_keyword("BOOT")) {
459 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
460 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
461 push (@BootCode, @line, "") ;
466 # extract return type, function name and arguments
467 ($ret_type) = TidyType($_);
468 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
470 # Allow one-line ANSI-like declaration
473 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
475 # a function definition needs at least 2 lines
476 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
479 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
480 $static = 1 if $ret_type =~ s/^static\s+//;
482 $func_header = shift(@line);
483 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
484 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
486 ($class, $func_name, $orig_args) = ($1, $2, $3) ;
487 $class = "$4 $class" if $4;
488 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
489 ($clean_func_name = $func_name) =~ s/^$Prefix//;
490 $Full_func_name = "${Packid}_$clean_func_name";
492 $Full_func_name = $SymSet->addsym($Full_func_name);
495 # Check for duplicate function definition
496 for my $tmp (@XSStack) {
497 next unless defined $tmp->{functions}{$Full_func_name};
498 Warn("Warning: duplicate function definition '$clean_func_name' detected");
501 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
502 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
505 $orig_args =~ s/\\\s*/ /g; # process line continuations
508 my %only_C_inlist; # Not in the signature of Perl function
509 if ($process_argtypes and $orig_args =~ /\S/) {
510 my $args = "$orig_args ,";
511 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
512 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
516 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
517 my ($pre, $name) = ($arg =~ /(.*?) \s*
518 \b ( \w+ | length\( \s*\w+\s* \) )
520 next unless defined($pre) && length($pre);
523 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
525 $out_type = $type if $type ne 'IN';
526 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
527 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
530 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
531 $name = "XSauto_length_of_$1";
533 die "Default value on length() argument: `$_'"
536 if (length $pre or $islength) { # Has a type
538 push @fake_INPUT_pre, $arg;
540 push @fake_INPUT, $arg;
542 # warn "pushing '$arg'\n";
543 $argtype_seen{$name}++;
544 $_ = "$name$default"; # Assigns to @args
546 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
547 push @outlist, $name if $out_type =~ /OUTLIST$/;
548 $in_out{$name} = $out_type if $out_type;
551 @args = split(/\s*,\s*/, $orig_args);
552 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
555 @args = split(/\s*,\s*/, $orig_args);
557 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
559 next if $out_type eq 'IN';
560 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
561 push @outlist, $name if $out_type =~ /OUTLIST$/;
562 $in_out{$_} = $out_type;
566 if (defined($class)) {
567 my $arg0 = ((defined($static) or $func_name eq 'new')
569 unshift(@args, $arg0);
574 my $report_args = '';
575 foreach my $i (0 .. $#args) {
576 if ($args[$i] =~ s/\.\.\.//) {
578 if ($args[$i] eq '' && $i == $#args) {
579 $report_args .= ", ...";
584 if ($only_C_inlist{$args[$i]}) {
585 push @args_num, undef;
587 push @args_num, ++$num_args;
588 $report_args .= ", $args[$i]";
590 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
593 $defaults{$args[$i]} = $2;
594 $defaults{$args[$i]} =~ s/"/\\"/g;
596 $proto_arg[$i+1] = '$' ;
598 $min_args = $num_args - $extra_args;
599 $report_args =~ s/"/\\"/g;
600 $report_args =~ s/^,\s+//;
601 my @func_args = @args;
602 shift @func_args if defined($class);
605 s/^/&/ if $in_out{$_};
607 $func_args = join(", ", @func_args);
608 @args_match{@args} = @args_num;
610 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
611 $CODE = grep(/^\s*CODE\s*:/, @line);
612 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
613 # to set explicit return values.
614 $EXPLICIT_RETURN = ($CODE &&
615 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
616 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
617 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
619 $xsreturn = 1 if $EXPLICIT_RETURN;
621 $externC = $externC ? qq[extern "C"] : "";
623 # print function header
626 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
627 #XS(XS_${Full_func_name})
635 print Q(<<"EOF") if $ALIAS ;
638 print Q(<<"EOF") if $INTERFACE ;
639 # dXSFUNCTION($ret_type);
642 $cond = ($min_args ? qq(items < $min_args) : 0);
643 } elsif ($min_args == $num_args) {
644 $cond = qq(items != $min_args);
646 $cond = qq(items < $min_args || items > $num_args);
649 print Q(<<"EOF") if $except;
657 # croak_xs_usage(cv, "$report_args");
660 # cv likely to be unused
662 # PERL_UNUSED_VAR(cv); /* -W */
666 #gcc -Wall: if an xsub has PPCODE is used
667 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
668 #hence `ax' (setup by dXSARGS) is unused
669 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
670 #but such a move could break third-party extensions
671 print Q(<<"EOF") if $PPCODE;
672 # PERL_UNUSED_VAR(ax); /* -Wall */
675 print Q(<<"EOF") if $PPCODE;
679 # Now do a block of some sort.
682 $cond = ''; # last CASE: condidional
683 push(@line, "$END:");
684 push(@line_no, $line_no[-1]);
688 &CASE_handler if check_keyword("CASE");
693 # do initialization of input variables
701 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
703 print Q(<<"EOF") if $ScopeThisXSUB;
708 if (!$thisdone && defined($class)) {
709 if (defined($static) or $func_name eq 'new') {
711 $var_types{"CLASS"} = "char *";
712 &generate_init("char *", 1, "CLASS");
716 $var_types{"THIS"} = "$class *";
717 &generate_init("$class *", 1, "THIS");
722 if (/^\s*NOT_IMPLEMENTED_YET/) {
723 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
726 if ($ret_type ne "void") {
727 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
729 $args_match{"RETVAL"} = 0;
730 $var_types{"RETVAL"} = $ret_type;
732 if $WantOptimize and $targetable{$type_kind{$ret_type}};
735 if (@fake_INPUT or @fake_INPUT_pre) {
736 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
738 $processing_arg_with_types = 1;
743 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
745 if (check_keyword("PPCODE")) {
747 death ("PPCODE must be last thing") if @line;
748 print "\tLEAVE;\n" if $ScopeThisXSUB;
749 print "\tPUTBACK;\n\treturn;\n";
750 } elsif (check_keyword("CODE")) {
752 } elsif (defined($class) and $func_name eq "DESTROY") {
754 print "delete THIS;\n";
757 if ($ret_type ne "void") {
761 if (defined($static)) {
762 if ($func_name eq 'new') {
763 $func_name = "$class";
767 } elsif (defined($class)) {
768 if ($func_name eq 'new') {
769 $func_name .= " $class";
774 $func_name =~ s/^\Q$args{'s'}//
775 if exists $args{'s'};
776 $func_name = 'XSFUNCTION' if $interface;
777 print "$func_name($func_args);\n";
781 # do output variables
782 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
783 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
784 # $wantRETVAL set if 'RETVAL =' autogenerated
785 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
787 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
789 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
790 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
792 # all OUTPUT done, so now push the return value on the stack
793 if ($gotRETVAL && $RETVAL_code) {
794 print "\t$RETVAL_code\n";
795 } elsif ($gotRETVAL || $wantRETVAL) {
796 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
798 my $type = $ret_type;
800 # 0: type, 1: with_size, 2: how, 3: how_size
801 if ($t and not $t->[1] and $t->[0] eq 'p') {
802 # PUSHp corresponds to setpvn. Treate setpv directly
803 my $what = eval qq("$t->[2]");
806 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
810 my $what = eval qq("$t->[2]");
814 $size = '' unless defined $size;
815 $size = eval qq("$size");
817 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
821 # RETVAL almost never needs SvSETMAGIC()
822 &generate_output($ret_type, 0, 'RETVAL', 0);
826 $xsreturn = 1 if $ret_type ne "void";
829 print "\tXSprePUSH;" if $c and not $prepush_done;
830 print "\tEXTEND(SP,$c);\n" if $c;
832 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
835 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
837 print Q(<<"EOF") if $ScopeThisXSUB;
840 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
844 # print function trailer
848 print Q(<<"EOF") if $except;
851 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
854 if (check_keyword("CASE")) {
855 blurt ("Error: No `CASE:' at top of function")
857 $_ = "CASE: $_"; # Restore CASE: label
860 last if $_ eq "$END:";
861 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
864 print Q(<<"EOF") if $except;
866 # Perl_croak(aTHX_ errbuf);
870 print Q(<<"EOF") unless $PPCODE;
871 # XSRETURN($xsreturn);
874 print Q(<<"EOF") unless $PPCODE;
884 our $newXS = "newXS" ;
887 # Build the prototype string for the xsub
888 if ($ProtoThisXSUB) {
889 $newXS = "newXSproto_portable";
891 if ($ProtoThisXSUB eq 2) {
892 # User has specified empty prototype
894 elsif ($ProtoThisXSUB eq 1) {
896 if ($min_args < $num_args) {
898 $proto_arg[$min_args] .= ";" ;
900 push @proto_arg, "$s\@"
903 $proto = join ("", grep defined, @proto_arg);
906 # User has specified a prototype
907 $proto = $ProtoThisXSUB;
909 $proto = qq{, "$proto"};
913 $XsubAliases{$pname} = 0
914 unless defined $XsubAliases{$pname} ;
915 while ( ($name, $value) = each %XsubAliases) {
916 push(@InitFileCode, Q(<<"EOF"));
917 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
918 # XSANY.any_i32 = $value ;
922 elsif (@Attributes) {
923 push(@InitFileCode, Q(<<"EOF"));
924 # cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);
925 # apply_attrs_string("$Package", cv, "@Attributes", 0);
929 while ( ($name, $value) = each %Interfaces) {
930 $name = "$Package\::$name" unless $name =~ /::/;
931 push(@InitFileCode, Q(<<"EOF"));
932 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
933 # $interface_macro_set(cv,$value) ;
939 " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
943 if ($Overload) # make it findable with fetchmethod
946 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
947 #XS(XS_${Packid}_nil)
954 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
955 /* Making a sub named "${Package}::()" allows the package */
956 /* to be findable via fetchmethod(), and causes */
957 /* overload::Overloaded("${Package}") to return true. */
958 (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto);
959 MAKE_FETCHMETHOD_WORK
962 # print initialization routine
971 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
972 #XS(boot_$Module_cname)
984 #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
985 #file name argument. If the wrong qualifier is used, it causes breakage with
986 #C++ compilers and warnings with recent gcc.
987 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
989 print Q(<<"EOF") if $Full_func_name;
990 ##if (PERL_REVISION == 5 && PERL_VERSION < 9)
991 # char* file = __FILE__;
993 # const char* file = __FILE__;
1000 # PERL_UNUSED_VAR(cv); /* -W */
1001 # PERL_UNUSED_VAR(items); /* -W */
1004 print Q(<<"EOF") if $WantVersionChk ;
1005 # XS_VERSION_BOOTCHECK ;
1009 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1015 print Q(<<"EOF") if ($Overload);
1016 # /* register the overloading (type 'A') magic */
1017 # PL_amagic_generation++;
1018 # /* The magic for overload gets a GV* via gv_fetchmeth as */
1019 # /* mentioned above, and looks in the SV* slot of it for */
1020 # /* the "fallback" status. */
1022 # get_sv( "${Package}::()", TRUE ),
1027 print @InitFileCode;
1029 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
1035 print "\n /* Initialisation Section */\n\n" ;
1038 print "\n /* End of Initialisation Section */\n\n" ;
1042 ##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
1043 # if (PL_unitcheckav)
1044 # call_list(PL_scopestack_ix, PL_unitcheckav);
1054 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1059 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1065 sub errors { $errors }
1067 sub standard_typemap_locations {
1068 # Add all the default typemap locations to the search path
1069 my @tm = qw(typemap);
1071 my $updir = File::Spec->updir;
1072 foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
1073 File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
1075 unshift @tm, File::Spec->catfile($dir, 'typemap');
1076 unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
1078 foreach my $dir (@INC) {
1079 my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
1080 unshift @tm, $file if -e $file;
1087 $_[0] =~ s/^\s+|\s+$//go ;
1094 # rationalise any '*' by joining them into bunches and removing whitespace
1098 # change multiple whitespace into a single space
1101 # trim leading & trailing whitespace
1102 TrimWhitespace($_) ;
1107 # Input: ($_, @line) == unparsed input.
1108 # Output: ($_, @line) == (rest of line, following lines).
1109 # Return: the matched keyword if found, otherwise 0
1111 $_ = shift(@line) while !/\S/ && @line;
1112 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1116 # the "do" is required for right semantics
1117 do { $_ = shift(@line) } while !/\S/ && @line;
1119 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1120 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1121 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1124 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1130 while (!/\S/ && @line) {
1134 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1141 sub process_keyword($)
1146 &{"${kwd}_handler"}()
1147 while $kwd = check_keyword($pattern) ;
1151 blurt ("Error: `CASE:' after unconditional `CASE:'")
1152 if $condnum && $cond eq '';
1154 TrimWhitespace($cond);
1155 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1160 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1161 last if /^\s*NOT_IMPLEMENTED_YET/;
1162 next unless /\S/; # skip blank lines
1164 TrimWhitespace($_) ;
1167 # remove trailing semicolon if no initialisation
1168 s/\s*;$//g unless /[=;+].*\S/ ;
1170 # Process the length(foo) declarations
1171 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1172 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1173 $lengthof{$2} = $name;
1174 # $islengthof{$name} = $1;
1175 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
1178 # check for optional initialisation code
1180 $var_init = $1 if s/\s*([=;+].*)$//s ;
1181 $var_init =~ s/"/\\"/g;
1184 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1185 or blurt("Error: invalid argument declaration '$line'"), next;
1187 # Check for duplicate definitions
1188 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1189 if $arg_list{$var_name}++
1190 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1192 $thisdone |= $var_name eq "THIS";
1193 $retvaldone |= $var_name eq "RETVAL";
1194 $var_types{$var_name} = $var_type;
1195 # XXXX This check is a safeguard against the unfinished conversion of
1196 # generate_init(). When generate_init() is fixed,
1197 # one can use 2-args map_type() unconditionally.
1198 if ($var_type =~ / \( \s* \* \s* \) /x) {
1199 # Function pointers are not yet supported with &output_init!
1200 print "\t" . &map_type($var_type, $var_name);
1203 print "\t" . &map_type($var_type);
1206 $var_num = $args_match{$var_name};
1208 $proto_arg[$var_num] = ProtoString($var_type)
1210 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1211 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1212 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1213 and $var_init !~ /\S/) {
1214 if ($name_printed) {
1217 print "\t$var_name;\n";
1219 } elsif ($var_init =~ /\S/) {
1220 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1221 } elsif ($var_num) {
1222 # generate initialization code
1223 &generate_init($var_type, $var_num, $var_name, $name_printed);
1230 sub OUTPUT_handler {
1231 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1233 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1234 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1237 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
1238 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1239 if $outargs{$outarg} ++ ;
1240 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1241 # deal with RETVAL last
1242 $RETVAL_code = $outcode ;
1246 blurt ("Error: OUTPUT $outarg not an argument"), next
1247 unless defined($args_match{$outarg});
1248 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1249 unless defined $var_types{$outarg} ;
1250 $var_num = $args_match{$outarg};
1252 print "\t$outcode\n";
1253 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1255 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1257 delete $in_out{$outarg} # No need to auto-OUTPUT
1258 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1262 sub C_ARGS_handler() {
1263 my $in = merge_section();
1265 TrimWhitespace($in);
1269 sub INTERFACE_MACRO_handler() {
1270 my $in = merge_section();
1272 TrimWhitespace($in);
1273 if ($in =~ /\s/) { # two
1274 ($interface_macro, $interface_macro_set) = split ' ', $in;
1276 $interface_macro = $in;
1277 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1279 $interface = 1; # local
1280 $Interfaces = 1; # global
1283 sub INTERFACE_handler() {
1284 my $in = merge_section();
1286 TrimWhitespace($in);
1288 foreach (split /[\s,]+/, $in) {
1290 $name =~ s/^$Prefix//;
1291 $Interfaces{$name} = $_;
1294 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1296 $interface = 1; # local
1297 $Interfaces = 1; # global
1300 sub CLEANUP_handler() { print_section() }
1301 sub PREINIT_handler() { print_section() }
1302 sub POSTCALL_handler() { print_section() }
1303 sub INIT_handler() { print_section() }
1308 my ($orig) = $line ;
1312 # Parse alias definitions
1314 # alias = value alias = value ...
1316 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1318 $orig_alias = $alias ;
1321 # check for optional package definition in the alias
1322 $alias = $Packprefix . $alias if $alias !~ /::/ ;
1324 # check for duplicate alias name & duplicate value
1325 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1326 if defined $XsubAliases{$alias} ;
1328 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1329 if $XsubAliasValues{$value} ;
1332 $XsubAliases{$alias} = $value ;
1333 $XsubAliasValues{$value} = $orig_alias ;
1336 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1340 sub ATTRS_handler ()
1342 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1344 TrimWhitespace($_) ;
1345 push @Attributes, $_;
1349 sub ALIAS_handler ()
1351 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1353 TrimWhitespace($_) ;
1354 GetAliases($_) if $_ ;
1358 sub OVERLOAD_handler()
1360 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1362 TrimWhitespace($_) ;
1363 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1364 $Overload = 1 unless $Overload;
1365 my $overload = "$Package\::(".$1 ;
1367 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
1372 sub FALLBACK_handler()
1374 # the rest of the current line should contain either TRUE,
1377 TrimWhitespace($_) ;
1379 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1380 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1381 UNDEF => "&PL_sv_undef",
1384 # check for valid FALLBACK value
1385 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
1387 $Fallback = $map{uc $_} ;
1391 sub REQUIRE_handler ()
1393 # the rest of the current line should contain a version number
1396 TrimWhitespace($Ver) ;
1398 death ("Error: REQUIRE expects a version number")
1401 # check that the version number is of the form n.n
1402 death ("Error: REQUIRE: expected a number, got '$Ver'")
1403 unless $Ver =~ /^\d+(\.\d*)?/ ;
1405 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1406 unless $VERSION >= $Ver ;
1409 sub VERSIONCHECK_handler ()
1411 # the rest of the current line should contain either ENABLE or
1414 TrimWhitespace($_) ;
1416 # check for ENABLE/DISABLE
1417 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1418 unless /^(ENABLE|DISABLE)/i ;
1420 $WantVersionChk = 1 if $1 eq 'ENABLE' ;
1421 $WantVersionChk = 0 if $1 eq 'DISABLE' ;
1425 sub PROTOTYPE_handler ()
1429 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1430 if $proto_in_this_xsub ++ ;
1432 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1435 TrimWhitespace($_) ;
1436 if ($_ eq 'DISABLE') {
1438 } elsif ($_ eq 'ENABLE') {
1441 # remove any whitespace
1443 death("Error: Invalid prototype '$_'")
1444 unless ValidProtoString($_) ;
1445 $ProtoThisXSUB = C_string($_) ;
1449 # If no prototype specified, then assume empty prototype ""
1450 $ProtoThisXSUB = 2 unless $specified ;
1456 sub SCOPE_handler ()
1458 death("Error: Only 1 SCOPE declaration allowed per xsub")
1459 if $scope_in_this_xsub ++ ;
1462 death ("Error: SCOPE: ENABLE/DISABLE")
1463 unless /^(ENABLE|DISABLE)\b/i;
1464 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
1467 sub PROTOTYPES_handler ()
1469 # the rest of the current line should contain either ENABLE or
1472 TrimWhitespace($_) ;
1474 # check for ENABLE/DISABLE
1475 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1476 unless /^(ENABLE|DISABLE)/i ;
1478 $WantPrototypes = 1 if $1 eq 'ENABLE' ;
1479 $WantPrototypes = 0 if $1 eq 'DISABLE' ;
1484 sub INCLUDE_handler ()
1486 # the rest of the current line should contain a valid filename
1488 TrimWhitespace($_) ;
1490 death("INCLUDE: filename missing")
1493 death("INCLUDE: output pipe is illegal")
1496 # simple minded recursion detector
1497 death("INCLUDE loop detected")
1498 if $IncludedFiles{$_} ;
1500 ++ $IncludedFiles{$_} unless /\|\s*$/ ;
1502 # Save the current file context.
1505 LastLine => $lastline,
1506 LastLineNo => $lastline_no,
1508 LineNo => \@line_no,
1509 Filename => $filename,
1510 Filepathname => $filepathname,
1514 $FH = Symbol::gensym();
1517 open ($FH, "$_") or death("Cannot open '$_': $!") ;
1521 #/* INCLUDE: Including '$_' from '$filename' */
1526 $filepathname = "$dir/$filename";
1528 # Prime the pump by reading the first
1531 # skip leading blank lines
1533 last unless /^\s*$/ ;
1543 return 0 unless $XSStack[-1]{type} eq 'file' ;
1545 my $data = pop @XSStack ;
1546 my $ThisFile = $filename ;
1547 my $isPipe = ($filename =~ /\|\s*$/) ;
1549 -- $IncludedFiles{$filename}
1554 $FH = $data->{Handle} ;
1555 # $filename is the leafname, which for some reason isused for diagnostic
1556 # messages, whereas $filepathname is the full pathname, and is used for
1558 $filename = $data->{Filename} ;
1559 $filepathname = $data->{Filepathname} ;
1560 $lastline = $data->{LastLine} ;
1561 $lastline_no = $data->{LastLineNo} ;
1562 @line = @{ $data->{Line} } ;
1563 @line_no = @{ $data->{LineNo} } ;
1565 if ($isPipe and $? ) {
1567 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1573 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1580 sub ValidProtoString ($)
1584 if ( $string =~ /^$proto_re+$/ ) {
1595 $string =~ s[\\][\\\\]g ;
1603 $proto_letter{$type} or "\$" ;
1607 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1609 my ($cpp, $cpplevel);
1611 if ($cpp =~ /^\#\s*if/) {
1613 } elsif (!$cpplevel) {
1614 Warn("Warning: #else/elif/endif without #if in this function");
1615 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1616 if $XSStack[-1]{type} eq 'if';
1618 } elsif ($cpp =~ /^\#\s*endif/) {
1622 Warn("Warning: #if without #endif in this function") if $cpplevel;
1630 $text =~ s/\[\[/{/g;
1631 $text =~ s/\]\]/}/g;
1635 # Read next xsub into @line from ($lastline, <$FH>).
1638 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1639 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1642 return PopFile() if !defined $lastline;
1645 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1647 $Package = defined($2) ? $2 : ''; # keep -w happy
1648 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1649 $Prefix = quotemeta $Prefix ;
1650 ($Module_cname = $Module) =~ s/\W/_/g;
1651 ($Packid = $Package) =~ tr/:/_/;
1652 $Packprefix = $Package;
1653 $Packprefix .= "::" if $Packprefix ne "";
1658 # Skip embedded PODs
1659 while ($lastline =~ /^=/) {
1660 while ($lastline = <$FH>) {
1661 last if ($lastline =~ /^=cut\s*$/);
1663 death ("Error: Unterminated pod") unless $lastline;
1666 $lastline =~ s/^\s+$//;
1668 if ($lastline !~ /^\s*#/ ||
1670 # ANSI: if ifdef ifndef elif else endif define undef
1672 # gcc: warning include_next
1674 # others: ident (gcc notes that some cpps have this one)
1675 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1676 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1677 push(@line, $lastline);
1678 push(@line_no, $lastline_no) ;
1681 # Read next line and continuation lines
1682 last unless defined($lastline = <$FH>);
1685 $lastline .= $tmp_line
1686 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1689 $lastline =~ s/^\s+$//;
1691 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1696 local($type, $num, $var, $init, $name_printed) = @_;
1697 local($arg) = "ST(" . ($num - 1) . ")";
1699 if ( $init =~ /^=/ ) {
1700 if ($name_printed) {
1701 eval qq/print " $init\\n"/;
1703 eval qq/print "\\t$var $init\\n"/;
1707 if ( $init =~ s/^\+// && $num ) {
1708 &generate_init($type, $num, $var, $name_printed);
1709 } elsif ($name_printed) {
1713 eval qq/print "\\t$var;\\n"/;
1717 $deferred .= eval qq/"\\n\\t$init\\n"/;
1724 # work out the line number
1725 my $line_no = $line_no[@line_no - @line -1] ;
1727 print STDERR "@_ in $filename, line $line_no\n" ;
1743 local($type, $num, $var) = @_;
1744 local($arg) = "ST(" . ($num - 1) . ")";
1745 local($argoff) = $num - 1;
1749 $type = TidyType($type) ;
1750 blurt("Error: '$type' not in typemap"), return
1751 unless defined($type_kind{$type});
1753 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1754 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1755 $tk = $type_kind{$type};
1756 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1757 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1758 print "\t$var" unless $name_printed;
1759 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1760 die "default value not supported with length(NAME) supplied"
1761 if defined $defaults{$var};
1764 $type =~ tr/:/_/ unless $hiertype;
1765 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1766 unless defined $input_expr{$tk} ;
1767 $expr = $input_expr{$tk};
1768 if ($expr =~ /DO_ARRAY_ELEM/) {
1769 blurt("Error: '$subtype' not in typemap"), return
1770 unless defined($type_kind{$subtype});
1771 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1772 unless defined $input_expr{$type_kind{$subtype}} ;
1773 $subexpr = $input_expr{$type_kind{$subtype}};
1774 $subexpr =~ s/\$type/\$subtype/g;
1775 $subexpr =~ s/ntype/subtype/g;
1776 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1777 $subexpr =~ s/\n\t/\n\t\t/g;
1778 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1779 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1780 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1782 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1785 if (defined($defaults{$var})) {
1786 $expr =~ s/(\t+)/$1 /g;
1788 if ($name_printed) {
1791 eval qq/print "\\t$var;\\n"/;
1794 if ($defaults{$var} eq 'NO_INIT') {
1795 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1797 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1800 } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1801 if ($name_printed) {
1804 eval qq/print "\\t$var;\\n"/;
1807 $deferred .= eval qq/"\\n$expr;\\n"/;
1810 die "panic: do not know how to handle this branch for function pointers"
1812 eval qq/print "$expr;\\n"/;
1817 sub generate_output {
1818 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1819 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1820 local($argoff) = $num - 1;
1823 $type = TidyType($type) ;
1824 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1825 print "\t$arg = sv_newmortal();\n";
1826 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1827 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1829 blurt("Error: '$type' not in typemap"), return
1830 unless defined($type_kind{$type});
1831 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1832 unless defined $output_expr{$type_kind{$type}} ;
1833 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1834 $ntype =~ s/\(\)//g;
1835 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1836 $expr = $output_expr{$type_kind{$type}};
1837 if ($expr =~ /DO_ARRAY_ELEM/) {
1838 blurt("Error: '$subtype' not in typemap"), return
1839 unless defined($type_kind{$subtype});
1840 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1841 unless defined $output_expr{$type_kind{$subtype}} ;
1842 $subexpr = $output_expr{$type_kind{$subtype}};
1843 $subexpr =~ s/ntype/subtype/g;
1844 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1845 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1846 $subexpr =~ s/\n\t/\n\t\t/g;
1847 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1848 eval "print qq\a$expr\a";
1850 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1851 } elsif ($var eq 'RETVAL') {
1852 if ($expr =~ /^\t\$arg = new/) {
1853 # We expect that $arg has refcnt 1, so we need to
1855 eval "print qq\a$expr\a";
1857 print "\tsv_2mortal(ST($num));\n";
1858 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1859 } elsif ($expr =~ /^\s*\$arg\s*=/) {
1860 # We expect that $arg has refcnt >=1, so we need
1862 eval "print qq\a$expr\a";
1864 print "\tsv_2mortal(ST(0));\n";
1865 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1867 # Just hope that the entry would safely write it
1868 # over an already mortalized value. By
1869 # coincidence, something like $arg = &sv_undef
1871 print "\tST(0) = sv_newmortal();\n";
1872 eval "print qq\a$expr\a";
1874 # new mortals don't have set magic
1876 } elsif ($do_push) {
1877 print "\tPUSHs(sv_newmortal());\n";
1879 eval "print qq\a$expr\a";
1881 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1882 } elsif ($arg =~ /^ST\(\d+\)$/) {
1883 eval "print qq\a$expr\a";
1885 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1891 my($type, $varname) = @_;
1893 # C++ has :: in types too so skip this
1894 $type =~ tr/:/_/ unless $hiertype;
1895 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1897 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1898 (substr $type, pos $type, 0) = " $varname ";
1900 $type .= "\t$varname";
1907 #########################################################
1909 ExtUtils::ParseXS::CountLines;
1911 use vars qw($SECTION_END_MARKER);
1914 my ($class, $cfile, $fh) = @_;
1915 $cfile =~ s/\\/\\\\/g;
1916 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1918 return bless {buffer => '',
1927 $self->{buffer} .= $_;
1928 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1930 ++ $self->{line_no};
1931 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
1932 print {$self->{fh}} $line;
1940 $self->PRINT(sprintf($fmt, @_));
1944 # Not necessary if we're careful to end with a "\n"
1946 print {$self->{fh}} $self->{buffer};
1950 # This sub does nothing, but is neccessary for references to be released.
1954 return $SECTION_END_MARKER;
1963 ExtUtils::ParseXS - converts Perl XS code into C code
1967 use ExtUtils::ParseXS qw(process_file);
1969 process_file( filename => 'foo.xs' );
1971 process_file( filename => 'foo.xs',
1974 typemap => 'path/to/typemap',
1985 C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
1986 necessary to let C functions manipulate Perl values and creates the glue
1987 necessary to let Perl access those functions. The compiler uses typemaps to
1988 determine how to map C function parameters and variables to Perl values.
1990 The compiler will search for typemap files called I<typemap>. It will use
1991 the following search path to find default typemaps, with the rightmost
1992 typemap taking precedence.
1994 ../../../typemap:../../typemap:../typemap:typemap
1998 None by default. C<process_file()> may be exported upon request.
2007 This function processes an XS file and sends output to a C file.
2008 Named parameters control how the processing is done. The following
2009 parameters are accepted:
2015 Adds C<extern "C"> to the C code. Default is false.
2019 Retains C<::> in type names so that C++ hierachical types can be
2020 mapped. Default is false.
2024 Adds exception handling stubs to the C code. Default is false.
2028 Indicates that a user-supplied typemap should take precedence over the
2029 default typemaps. A single typemap may be specified as a string, or
2030 multiple typemaps can be specified in an array reference, with the
2031 last typemap having the highest precedence.
2035 Generates prototype code for all xsubs. Default is false.
2037 =item B<versioncheck>
2039 Makes sure at run time that the object file (derived from the C<.xs>
2040 file) and the C<.pm> files have the same version number. Default is
2043 =item B<linenumbers>
2045 Adds C<#line> directives to the C output so error messages will look
2046 like they came from the original XS file. Default is true.
2050 Enables certain optimizations. The only optimization that is currently
2051 affected is the use of I<target>s by the output C code (see L<perlguts>).
2052 Not optimizing may significantly slow down the generated code, but this is the way
2053 B<xsubpp> of 5.005 and earlier operated. Default is to optimize.
2057 Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
2058 declarations. Default is true.
2062 Enable recognition of ANSI-like descriptions of function signature.
2067 I have no clue what this does. Strips function prefixes?
2073 This function returns the number of [a certain kind of] errors
2074 encountered during processing of the XS file.
2080 Based on xsubpp code, written by Larry Wall.
2088 Ken Williams, <ken@mathforum.org>
2092 David Golden, <dagolden@cpan.org>
2098 Copyright 2002-2009 by Ken Williams, David Golden and other contributors. All
2101 This library is free software; you can redistribute it and/or
2102 modify it under the same terms as Perl itself.
2104 Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
2105 Porters, which was released under the same license terms.
2109 L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.