1 package ExtUtils::ParseXS;
3 use 5.006; # We use /??{}/ in regexes
10 use ExtUtils::ParseXS::Utilities qw(
11 standard_typemap_locations
16 our (@ISA, @EXPORT_OK, $VERSION);
18 @EXPORT_OK = qw(process_file);
20 $VERSION = eval $VERSION if $VERSION =~ /_/;
22 # use strict; # One of these days ...
24 my(@XSStack); # Stack of conditionals and INCLUDEs
25 my($XSS_work_idx, $cpp_next_tmp);
28 $ProtoUsed, @InitFileCode, $FH, $proto_re, $Overload, $errors, $Fallback,
29 $hiertype, $WantPrototypes, $WantVersionChk, $WantLineNumbers, $filepathname,
30 $dir, $filename, %IncludedFiles,
32 %input_expr, %output_expr,
35 %type_kind, %proto_letter,
36 %targetable, $BLOCK_re, $lastline, $lastline_no, $Package, $Prefix,
37 @line, @BootCode, %args_match, %defaults, %var_types, %arg_list, @proto_arg,
38 $processing_arg_with_types, %argtype_seen, @outlist, %in_out, %lengthof,
39 $proto_in_this_xsub, $scope_in_this_xsub, $interface, $prepush_done,
40 $interface_macro, $interface_macro_set, $ProtoThisXSUB, $ScopeThisXSUB,
41 $xsreturn, @line_no, $ret_type, $func_header, $orig_args,
46 # Allow for $package->process_file(%hash) in the future
47 my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
49 $ProtoUsed = exists $args{prototypes};
69 my ($Is_VMS, $SymSet);
72 # Establish set of global symbols with max length 28, since xsubpp
73 # will later add the 'XS_' prefix.
74 require ExtUtils::XSSymSet;
75 $SymSet = new ExtUtils::XSSymSet 28;
77 @XSStack = ({type => 'none'});
78 ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
80 $FH = Symbol::gensym();
81 $proto_re = "[" . quotemeta('\$%&*@;[]_') . "]";
84 $Fallback = '&PL_sv_undef';
86 # Most of the 1500 lines below uses these globals. We'll have to
87 # clean this up sometime, probably. For now, we just pull them out
90 $hiertype = $args{hiertype};
91 $WantPrototypes = $args{prototypes};
92 $WantVersionChk = $args{versioncheck};
93 my $except = $args{except} ? ' TRY' : '';
94 $WantLineNumbers = $args{linenumbers};
95 my $WantOptimize = $args{optimize};
96 my $process_inout = $args{inout};
97 my $process_argtypes = $args{argtypes};
98 my @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
100 for ($args{filename}) {
101 die "Missing required parameter 'filename'" unless $_;
103 ($dir, $filename) = (dirname($_), basename($_));
104 $filepathname =~ s/\\/\\\\/g;
105 $IncludedFiles{$_}++;
108 # Open the input file
109 open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
111 # Open the output file if given as a string. If they provide some
112 # other kind of reference, trust them that we can print to it.
113 if (not ref $args{output}) {
114 open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
115 $args{outfile} = $args{output};
119 # Really, we shouldn't have to chdir() or select() in the first
120 # place. For now, just save & restore.
121 my $orig_cwd = cwd();
122 my $orig_fh = select();
126 my $csuffix = $args{csuffix};
128 if ($WantLineNumbers) {
130 if ( $args{outfile} ) {
131 $cfile = $args{outfile};
134 $cfile = $args{filename};
135 $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
137 tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
138 select PSEUDO_STDOUT;
141 select $args{output};
144 foreach my $typemap (@tm) {
145 die "Can't find $typemap in $pwd\n" unless -r $typemap;
148 push @tm, standard_typemap_locations( \@INC );
150 foreach my $typemap (@tm) {
151 next unless -f $typemap;
152 # skip directories, binary files etc.
153 warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
155 open my $TYPEMAP, '<', $typemap
156 or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
157 my $mode = 'Typemap';
159 my $current = \$junk;
162 my $line_no = $. + 1;
164 $mode = 'Input'; $current = \$junk; next;
167 $mode = 'Output'; $current = \$junk; next;
169 if (/^TYPEMAP\s*$/) {
170 $mode = 'Typemap'; $current = \$junk; next;
172 if ($mode eq 'Typemap') {
176 # skip blank lines and comment lines
177 next if /^$/ or /^#/;
178 my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
179 warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
180 $type = tidy_type($type);
181 $type_kind{$type} = $kind;
182 # prototype defaults to '$'
183 $proto = "\$" unless $proto;
184 warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
185 unless ValidProtoString($proto);
186 $proto_letter{$type} = C_string($proto);
191 elsif ($mode eq 'Input') {
193 $input_expr{$_} = '';
194 $current = \$input_expr{$_};
198 $output_expr{$_} = '';
199 $current = \$output_expr{$_};
205 foreach my $value (values %input_expr) {
206 $value =~ s/;*\s+\z//;
207 # Move C pre-processor instructions to column 1 to be strictly ANSI
208 # conformant. Some pre-processors are fussy about this.
209 $value =~ s/^\s+#/#/mg;
211 foreach my $value (values %output_expr) {
213 $value =~ s/^\s+#/#/mg;
217 our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
218 $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
219 $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
221 foreach my $key (keys %output_expr) {
222 # We can still bootstrap compile 're', because in code re.pm is
223 # available to miniperl, and does not attempt to load the XS code.
226 my ($t, $with_size, $arg, $sarg) =
227 ($output_expr{$key} =~
228 m[^ \s+ sv_set ( [iunp] ) v (n)? # Type, is_setpvn
229 \s* \( \s* $cast \$arg \s* ,
230 \s* ( (??{ $bal }) ) # Set from
231 ( (??{ $size }) )? # Possible sizeof set-from
235 $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
238 my $END = "!End!\n\n"; # "impossible" keyword (multiple newline)
240 # Match an XS keyword
241 $BLOCK_re = '\s*(' . join('|', qw(
242 REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE
243 OUTPUT CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE
244 VERSIONCHECK INCLUDE INCLUDE_COMMAND SCOPE INTERFACE
245 INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
248 our ($C_group_rex, $C_arg);
249 # Group in C (no support for comments or literals)
250 $C_group_rex = qr/ [({\[]
251 (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
253 # Chunk in C without comma at toplevel (no comments):
254 $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
255 | (??{ $C_group_rex })
256 | " (?: (?> [^\\"]+ )
258 )* " # String literal
259 | ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
262 # Identify the version of xsubpp used
265 * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
266 * contents of $filename. Do not edit this file, edit $filename instead.
268 * ANY CHANGES MADE HERE WILL BE LOST!
275 print("#line 1 \"$filepathname\"\n")
281 my $podstartline = $.;
284 # We can't just write out a /* */ comment, as our embedded
285 # POD might itself be in a comment. We can't put a /**/
286 # comment inside #if 0, as the C standard says that the source
287 # file is decomposed into preprocessing characters in the stage
288 # before preprocessing commands are executed.
289 # I don't want to leave the text as barewords, because the spec
290 # isn't clear whether macros are expanded before or after
291 # preprocessing commands are executed, and someone pathological
292 # may just have defined one of the 3 words as a macro that does
293 # something strange. Multiline strings are illegal in C, so
294 # the "" we write must be a string literal. And they aren't
295 # concatenated until 2 steps later, so we are safe.
297 print("#if 0\n \"Skipped embedded POD.\"\n#endif\n");
298 printf("#line %d \"$filepathname\"\n", $. + 1)
304 # At this point $. is at end of file so die won't state the start
305 # of the problem, and as we haven't yet read any lines &death won't
306 # show the correct line in the message either.
307 die ("Error: Unterminated pod in $filename, line $podstartline\n")
310 last if ($Package, $Prefix) =
311 /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
315 unless (defined $_) {
316 warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
317 exit 0; # Not a fatal error for the caller process
320 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
323 #ifndef PERL_UNUSED_VAR
324 # define PERL_UNUSED_VAR(var) if (0) var = var
330 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
331 #define PERL_ARGS_ASSERT_CROAK_XS_USAGE assert(cv); assert(params)
333 /* prototype to pass -Wmissing-prototypes */
335 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params);
338 S_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
340 const GV *const gv = CvGV(cv);
342 PERL_ARGS_ASSERT_CROAK_XS_USAGE;
345 const char *const gvname = GvNAME(gv);
346 const HV *const stash = GvSTASH(gv);
347 const char *const hvname = stash ? HvNAME(stash) : NULL;
350 Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
352 Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
354 /* Pants. I don't think that it should be possible to get here. */
355 Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
358 #undef PERL_ARGS_ASSERT_CROAK_XS_USAGE
360 #ifdef PERL_IMPLICIT_CONTEXT
361 #define croak_xs_usage(a,b) S_croak_xs_usage(aTHX_ a,b)
363 #define croak_xs_usage S_croak_xs_usage
368 /* NOTE: the prototype of newXSproto() is different in versions of perls,
369 * so we define a portable version of newXSproto()
372 #define newXSproto_portable(name, c_impl, file, proto) newXS_flags(name, c_impl, file, proto, 0)
374 #define newXSproto_portable(name, c_impl, file, proto) (PL_Sv=(SV*)newXS(name, c_impl, file), sv_setpv(PL_Sv, proto), (CV*)PL_Sv)
375 #endif /* !defined(newXS_flags) */
379 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
385 while (fetch_para()) {
386 # Print initial preprocessor statements and blank lines
387 while (@line && $line[0] !~ /^[^\#]/) {
388 my $line = shift(@line);
390 next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
392 if ($statement eq 'if') {
393 $XSS_work_idx = @XSStack;
394 push(@XSStack, {type => 'if'});
397 death ("Error: `$statement' with no matching `if'")
398 if $XSStack[-1]{type} ne 'if';
399 if ($XSStack[-1]{varname}) {
400 push(@InitFileCode, "#endif\n");
401 push(@BootCode, "#endif");
404 my(@fns) = keys %{$XSStack[-1]{functions}};
405 if ($statement ne 'endif') {
406 # Hide the functions defined in other #if branches, and reset.
407 @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
408 @{$XSStack[-1]}{qw(varname functions)} = ('', {});
411 my($tmp) = pop(@XSStack);
412 0 while (--$XSS_work_idx
413 && $XSStack[$XSS_work_idx]{type} ne 'if');
414 # Keep all new defined functions
415 push(@fns, keys %{$tmp->{other_functions}});
416 @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
421 next PARAGRAPH unless @line;
423 if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
424 # We are inside an #if, but have not yet #defined its xsubpp variable.
425 print "#define $cpp_next_tmp 1\n\n";
426 push(@InitFileCode, "#if $cpp_next_tmp\n");
427 push(@BootCode, "#if $cpp_next_tmp");
428 $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
431 death ("Code is not inside a function"
432 ." (maybe last function was ended by a blank line "
433 ." followed by a statement on column one?)")
434 if $line[0] =~ /^\s/;
436 my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
437 my (@fake_INPUT_pre); # For length(s) generated variables
440 # initialize info arrays
446 undef($processing_arg_with_types);
447 undef(%argtype_seen);
451 undef($proto_in_this_xsub);
452 undef($scope_in_this_xsub);
454 undef($prepush_done);
455 $interface_macro = 'XSINTERFACE_FUNC';
456 $interface_macro_set = 'XSINTERFACE_FUNC_SET';
457 $ProtoThisXSUB = $WantPrototypes;
462 while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE(?:_COMMAND)?|SCOPE")) {
463 &{"${kwd}_handler"}();
464 next PARAGRAPH unless @line;
468 if (check_keyword("BOOT")) {
470 push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
471 if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
472 push (@BootCode, @line, "");
476 # extract return type, function name and arguments
477 ($ret_type) = tidy_type($_);
478 $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
480 # Allow one-line ANSI-like declaration
483 and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
485 # a function definition needs at least 2 lines
486 blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
489 $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
490 $static = 1 if $ret_type =~ s/^static\s+//;
492 $func_header = shift(@line);
493 blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
494 unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
496 ($class, $func_name, $orig_args) = ($1, $2, $3);
497 $class = "$4 $class" if $4;
498 ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
499 ($clean_func_name = $func_name) =~ s/^$Prefix//;
500 $Full_func_name = "${Packid}_$clean_func_name";
502 $Full_func_name = $SymSet->addsym($Full_func_name);
505 # Check for duplicate function definition
506 for my $tmp (@XSStack) {
507 next unless defined $tmp->{functions}{$Full_func_name};
508 Warn("Warning: duplicate function definition '$clean_func_name' detected");
511 $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++;
512 %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
515 $orig_args =~ s/\\\s*/ /g; # process line continuations
518 my %only_C_inlist; # Not in the signature of Perl function
519 if ($process_argtypes and $orig_args =~ /\S/) {
520 my $args = "$orig_args ,";
521 if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
522 @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
526 my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
527 my ($pre, $name) = ($arg =~ /(.*?) \s*
528 \b ( \w+ | length\( \s*\w+\s* \) )
530 next unless defined($pre) && length($pre);
533 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//) {
535 $out_type = $type if $type ne 'IN';
536 $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
537 $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\b\s*//;
540 if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
541 $name = "XSauto_length_of_$1";
543 die "Default value on length() argument: `$_'"
546 if (length $pre or $islength) { # Has a type
548 push @fake_INPUT_pre, $arg;
551 push @fake_INPUT, $arg;
553 # warn "pushing '$arg'\n";
554 $argtype_seen{$name}++;
555 $_ = "$name$default"; # Assigns to @args
557 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
558 push @outlist, $name if $out_type =~ /OUTLIST$/;
559 $in_out{$name} = $out_type if $out_type;
563 @args = split(/\s*,\s*/, $orig_args);
564 Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
568 @args = split(/\s*,\s*/, $orig_args);
570 if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\b\s*//) {
572 next if $out_type eq 'IN';
573 $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
574 push @outlist, $name if $out_type =~ /OUTLIST$/;
575 $in_out{$_} = $out_type;
579 if (defined($class)) {
580 my $arg0 = ((defined($static) or $func_name eq 'new')
582 unshift(@args, $arg0);
587 my $report_args = '';
588 foreach my $i (0 .. $#args) {
589 if ($args[$i] =~ s/\.\.\.//) {
591 if ($args[$i] eq '' && $i == $#args) {
592 $report_args .= ", ...";
597 if ($only_C_inlist{$args[$i]}) {
598 push @args_num, undef;
601 push @args_num, ++$num_args;
602 $report_args .= ", $args[$i]";
604 if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
607 $defaults{$args[$i]} = $2;
608 $defaults{$args[$i]} =~ s/"/\\"/g;
610 $proto_arg[$i+1] = '$';
612 $min_args = $num_args - $extra_args;
613 $report_args =~ s/"/\\"/g;
614 $report_args =~ s/^,\s+//;
615 my @func_args = @args;
616 shift @func_args if defined($class);
619 s/^/&/ if $in_out{$_};
621 $func_args = join(", ", @func_args);
622 @args_match{@args} = @args_num;
624 $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
625 $CODE = grep(/^\s*CODE\s*:/, @line);
626 # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
627 # to set explicit return values.
628 $EXPLICIT_RETURN = ($CODE &&
629 ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
630 $ALIAS = grep(/^\s*ALIAS\s*:/, @line);
631 $INTERFACE = grep(/^\s*INTERFACE\s*:/, @line);
633 $xsreturn = 1 if $EXPLICIT_RETURN;
635 $externC = $externC ? qq[extern "C"] : "";
637 # print function header
640 #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
641 #XS(XS_${Full_func_name})
649 print Q(<<"EOF") if $ALIAS;
652 print Q(<<"EOF") if $INTERFACE;
653 # dXSFUNCTION($ret_type);
656 $cond = ($min_args ? qq(items < $min_args) : 0);
658 elsif ($min_args == $num_args) {
659 $cond = qq(items != $min_args);
662 $cond = qq(items < $min_args || items > $num_args);
665 print Q(<<"EOF") if $except;
673 # croak_xs_usage(cv, "$report_args");
677 # cv likely to be unused
679 # PERL_UNUSED_VAR(cv); /* -W */
683 #gcc -Wall: if an xsub has PPCODE is used
684 #it is possible none of ST, XSRETURN or XSprePUSH macros are used
685 #hence `ax' (setup by dXSARGS) is unused
686 #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
687 #but such a move could break third-party extensions
688 print Q(<<"EOF") if $PPCODE;
689 # PERL_UNUSED_VAR(ax); /* -Wall */
692 print Q(<<"EOF") if $PPCODE;
696 # Now do a block of some sort.
699 $cond = ''; # last CASE: condidional
700 push(@line, "$END:");
701 push(@line_no, $line_no[-1]);
705 &CASE_handler if check_keyword("CASE");
710 # do initialization of input variables
718 process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD");
720 print Q(<<"EOF") if $ScopeThisXSUB;
725 if (!$thisdone && defined($class)) {
726 if (defined($static) or $func_name eq 'new') {
728 $var_types{"CLASS"} = "char *";
729 &generate_init("char *", 1, "CLASS");
733 $var_types{"THIS"} = "$class *";
734 &generate_init("$class *", 1, "THIS");
739 if (/^\s*NOT_IMPLEMENTED_YET/) {
740 print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
744 if ($ret_type ne "void") {
745 print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
747 $args_match{"RETVAL"} = 0;
748 $var_types{"RETVAL"} = $ret_type;
750 if $WantOptimize and $targetable{$type_kind{$ret_type}};
753 if (@fake_INPUT or @fake_INPUT_pre) {
754 unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
756 $processing_arg_with_types = 1;
761 process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD");
763 if (check_keyword("PPCODE")) {
765 death ("PPCODE must be last thing") if @line;
766 print "\tLEAVE;\n" if $ScopeThisXSUB;
767 print "\tPUTBACK;\n\treturn;\n";
769 elsif (check_keyword("CODE")) {
772 elsif (defined($class) and $func_name eq "DESTROY") {
774 print "delete THIS;\n";
778 if ($ret_type ne "void") {
782 if (defined($static)) {
783 if ($func_name eq 'new') {
784 $func_name = "$class";
790 elsif (defined($class)) {
791 if ($func_name eq 'new') {
792 $func_name .= " $class";
798 $func_name =~ s/^\Q$args{'s'}//
799 if exists $args{'s'};
800 $func_name = 'XSFUNCTION' if $interface;
801 print "$func_name($func_args);\n";
805 # do output variables
806 $gotRETVAL = 0; # 1 if RETVAL seen in OUTPUT section;
807 undef $RETVAL_code ; # code to set RETVAL (from OUTPUT section);
808 # $wantRETVAL set if 'RETVAL =' autogenerated
809 ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
811 process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
813 &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
814 for grep $in_out{$_} =~ /OUT$/, keys %in_out;
816 # all OUTPUT done, so now push the return value on the stack
817 if ($gotRETVAL && $RETVAL_code) {
818 print "\t$RETVAL_code\n";
820 elsif ($gotRETVAL || $wantRETVAL) {
821 my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
823 my $type = $ret_type;
825 # 0: type, 1: with_size, 2: how, 3: how_size
826 if ($t and not $t->[1] and $t->[0] eq 'p') {
827 # PUSHp corresponds to setpvn. Treate setpv directly
828 my $what = eval qq("$t->[2]");
831 print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
835 my $what = eval qq("$t->[2]");
839 $size = '' unless defined $size;
840 $size = eval qq("$size");
842 print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
846 # RETVAL almost never needs SvSETMAGIC()
847 &generate_output($ret_type, 0, 'RETVAL', 0);
851 $xsreturn = 1 if $ret_type ne "void";
854 print "\tXSprePUSH;" if $c and not $prepush_done;
855 print "\tEXTEND(SP,$c);\n" if $c;
857 generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
860 process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
862 print Q(<<"EOF") if $ScopeThisXSUB;
865 print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
869 # print function trailer
873 print Q(<<"EOF") if $except;
876 # sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
879 if (check_keyword("CASE")) {
880 blurt ("Error: No `CASE:' at top of function")
882 $_ = "CASE: $_"; # Restore CASE: label
885 last if $_ eq "$END:";
886 death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function ($_)");
889 print Q(<<"EOF") if $except;
891 # Perl_croak(aTHX_ errbuf);
895 print Q(<<"EOF") unless $PPCODE;
896 # XSRETURN($xsreturn);
900 print Q(<<"EOF") unless $PPCODE;
910 our $newXS = "newXS";
913 # Build the prototype string for the xsub
914 if ($ProtoThisXSUB) {
915 $newXS = "newXSproto_portable";
917 if ($ProtoThisXSUB eq 2) {
918 # User has specified empty prototype
920 elsif ($ProtoThisXSUB eq 1) {
922 if ($min_args < $num_args) {
924 $proto_arg[$min_args] .= ";";
926 push @proto_arg, "$s\@"
929 $proto = join ("", grep defined, @proto_arg);
932 # User has specified a prototype
933 $proto = $ProtoThisXSUB;
935 $proto = qq{, "$proto"};
939 $XsubAliases{$pname} = 0
940 unless defined $XsubAliases{$pname};
941 while ( ($name, $value) = each %XsubAliases) {
942 push(@InitFileCode, Q(<<"EOF"));
943 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
944 # XSANY.any_i32 = $value;
948 elsif (@Attributes) {
949 push(@InitFileCode, Q(<<"EOF"));
950 # cv = ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);
951 # apply_attrs_string("$Package", cv, "@Attributes", 0);
955 while ( ($name, $value) = each %Interfaces) {
956 $name = "$Package\::$name" unless $name =~ /::/;
957 push(@InitFileCode, Q(<<"EOF"));
958 # cv = ${newXS}(\"$name\", XS_$Full_func_name, file$proto);
959 # $interface_macro_set(cv,$value);
963 elsif($newXS eq 'newXS'){ # work around P5NCI's empty newXS macro
965 " ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
969 " (void)${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
973 if ($Overload) # make it findable with fetchmethod
976 #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
977 #XS(XS_${Packid}_nil)
984 unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
985 /* Making a sub named "${Package}::()" allows the package */
986 /* to be findable via fetchmethod(), and causes */
987 /* overload::Overloaded("${Package}") to return true. */
988 (void)${newXS}("${Package}::()", XS_${Packid}_nil, file$proto);
989 MAKE_FETCHMETHOD_WORK
992 # print initialization routine
1001 #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
1002 #XS(boot_$Module_cname)
1014 #Under 5.8.x and lower, newXS is declared in proto.h as expecting a non-const
1015 #file name argument. If the wrong qualifier is used, it causes breakage with
1016 #C++ compilers and warnings with recent gcc.
1017 #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
1018 #so `file' is unused
1019 print Q(<<"EOF") if $Full_func_name;
1020 ##if (PERL_REVISION == 5 && PERL_VERSION < 9)
1021 # char* file = __FILE__;
1023 # const char* file = __FILE__;
1030 # PERL_UNUSED_VAR(cv); /* -W */
1031 # PERL_UNUSED_VAR(items); /* -W */
1034 print Q(<<"EOF") if $WantVersionChk;
1035 # XS_VERSION_BOOTCHECK;
1039 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
1045 print Q(<<"EOF") if ($Overload);
1046 # /* register the overloading (type 'A') magic */
1047 # PL_amagic_generation++;
1048 # /* The magic for overload gets a GV* via gv_fetchmeth as */
1049 # /* mentioned above, and looks in the SV* slot of it for */
1050 # /* the "fallback" status. */
1052 # get_sv( "${Package}::()", TRUE ),
1057 print @InitFileCode;
1059 print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces;
1064 print "\n /* Initialisation Section */\n\n";
1067 print "\n /* End of Initialisation Section */\n\n";
1071 ##if (PERL_REVISION == 5 && PERL_VERSION >= 9)
1072 # if (PL_unitcheckav)
1073 # call_list(PL_scopestack_ix, PL_unitcheckav);
1083 warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
1088 untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
1094 sub errors { $errors }
1096 # Input: ($_, @line) == unparsed input.
1097 # Output: ($_, @line) == (rest of line, following lines).
1098 # Return: the matched keyword if found, otherwise 0
1100 $_ = shift(@line) while !/\S/ && @line;
1101 s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
1105 # the "do" is required for right semantics
1106 do { $_ = shift(@line) } while !/\S/ && @line;
1108 print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
1109 if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
1110 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1113 print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
1119 while (!/\S/ && @line) {
1123 for (; defined($_) && !/^$BLOCK_re/o; $_ = shift(@line)) {
1130 sub process_keyword($) {
1134 &{"${kwd}_handler"}()
1135 while $kwd = check_keyword($pattern);
1139 blurt ("Error: `CASE:' after unconditional `CASE:'")
1140 if $condnum && $cond eq '';
1142 trim_whitespace($cond);
1143 print " ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
1148 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1149 last if /^\s*NOT_IMPLEMENTED_YET/;
1150 next unless /\S/; # skip blank lines
1152 trim_whitespace($_);
1155 # remove trailing semicolon if no initialisation
1156 s/\s*;$//g unless /[=;+].*\S/;
1158 # Process the length(foo) declarations
1159 if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
1160 print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
1161 $lengthof{$2} = $name;
1162 # $islengthof{$name} = $1;
1163 $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;\n";
1166 # check for optional initialisation code
1168 $var_init = $1 if s/\s*([=;+].*)$//s;
1169 $var_init =~ s/"/\\"/g;
1172 my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
1173 or blurt("Error: invalid argument declaration '$line'"), next;
1175 # Check for duplicate definitions
1176 blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
1177 if $arg_list{$var_name}++
1178 or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
1180 $thisdone |= $var_name eq "THIS";
1181 $retvaldone |= $var_name eq "RETVAL";
1182 $var_types{$var_name} = $var_type;
1183 # XXXX This check is a safeguard against the unfinished conversion of
1184 # generate_init(). When generate_init() is fixed,
1185 # one can use 2-args map_type() unconditionally.
1186 if ($var_type =~ / \( \s* \* \s* \) /x) {
1187 # Function pointers are not yet supported with &output_init!
1188 print "\t" . &map_type($var_type, $var_name);
1192 print "\t" . &map_type($var_type);
1195 $var_num = $args_match{$var_name};
1197 $proto_arg[$var_num] = ProtoString($var_type)
1199 $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
1200 if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
1201 or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
1202 and $var_init !~ /\S/) {
1203 if ($name_printed) {
1207 print "\t$var_name;\n";
1210 elsif ($var_init =~ /\S/) {
1211 &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
1214 # generate initialization code
1215 &generate_init($var_type, $var_num, $var_name, $name_printed);
1223 sub OUTPUT_handler {
1224 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1226 if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
1227 $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
1230 my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s;
1231 blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
1232 if $outargs{$outarg} ++;
1233 if (!$gotRETVAL and $outarg eq 'RETVAL') {
1234 # deal with RETVAL last
1235 $RETVAL_code = $outcode;
1239 blurt ("Error: OUTPUT $outarg not an argument"), next
1240 unless defined($args_match{$outarg});
1241 blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
1242 unless defined $var_types{$outarg};
1243 $var_num = $args_match{$outarg};
1245 print "\t$outcode\n";
1246 print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
1249 &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
1251 delete $in_out{$outarg} # No need to auto-OUTPUT
1252 if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
1256 sub C_ARGS_handler() {
1257 my $in = merge_section();
1259 trim_whitespace($in);
1263 sub INTERFACE_MACRO_handler() {
1264 my $in = merge_section();
1266 trim_whitespace($in);
1267 if ($in =~ /\s/) { # two
1268 ($interface_macro, $interface_macro_set) = split ' ', $in;
1271 $interface_macro = $in;
1272 $interface_macro_set = 'UNKNOWN_CVT'; # catch later
1274 $interface = 1; # local
1275 $Interfaces = 1; # global
1278 sub INTERFACE_handler() {
1279 my $in = merge_section();
1281 trim_whitespace($in);
1283 foreach (split /[\s,]+/, $in) {
1285 $name =~ s/^$Prefix//;
1286 $Interfaces{$name} = $_;
1289 # XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
1291 $interface = 1; # local
1292 $Interfaces = 1; # global
1295 sub CLEANUP_handler() { print_section() }
1296 sub PREINIT_handler() { print_section() }
1297 sub POSTCALL_handler() { print_section() }
1298 sub INIT_handler() { print_section() }
1306 # Parse alias definitions
1308 # alias = value alias = value ...
1310 while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
1312 $orig_alias = $alias;
1315 # check for optional package definition in the alias
1316 $alias = $Packprefix . $alias if $alias !~ /::/;
1318 # check for duplicate alias name & duplicate value
1319 Warn("Warning: Ignoring duplicate alias '$orig_alias'")
1320 if defined $XsubAliases{$alias};
1322 Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
1323 if $XsubAliasValues{$value};
1326 $XsubAliases{$alias} = $value;
1327 $XsubAliasValues{$value} = $orig_alias;
1330 blurt("Error: Cannot parse ALIAS definitions from '$orig'")
1334 sub ATTRS_handler () {
1335 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1337 trim_whitespace($_);
1338 push @Attributes, $_;
1342 sub ALIAS_handler () {
1343 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1345 trim_whitespace($_);
1346 GetAliases($_) if $_;
1350 sub OVERLOAD_handler() {
1351 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1353 trim_whitespace($_);
1354 while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
1355 $Overload = 1 unless $Overload;
1356 my $overload = "$Package\::(".$1;
1358 " (void)${newXS}(\"$overload\", XS_$Full_func_name, file$proto);\n");
1363 sub FALLBACK_handler() {
1364 # the rest of the current line should contain either TRUE,
1367 trim_whitespace($_);
1369 TRUE => "&PL_sv_yes", 1 => "&PL_sv_yes",
1370 FALSE => "&PL_sv_no", 0 => "&PL_sv_no",
1371 UNDEF => "&PL_sv_undef",
1374 # check for valid FALLBACK value
1375 death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_};
1377 $Fallback = $map{uc $_};
1381 sub REQUIRE_handler () {
1382 # the rest of the current line should contain a version number
1385 trim_whitespace($Ver);
1387 death ("Error: REQUIRE expects a version number")
1390 # check that the version number is of the form n.n
1391 death ("Error: REQUIRE: expected a number, got '$Ver'")
1392 unless $Ver =~ /^\d+(\.\d*)?/;
1394 death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
1395 unless $VERSION >= $Ver;
1398 sub VERSIONCHECK_handler () {
1399 # the rest of the current line should contain either ENABLE or
1402 trim_whitespace($_);
1404 # check for ENABLE/DISABLE
1405 death ("Error: VERSIONCHECK: ENABLE/DISABLE")
1406 unless /^(ENABLE|DISABLE)/i;
1408 $WantVersionChk = 1 if $1 eq 'ENABLE';
1409 $WantVersionChk = 0 if $1 eq 'DISABLE';
1413 sub PROTOTYPE_handler () {
1416 death("Error: Only 1 PROTOTYPE definition allowed per xsub")
1417 if $proto_in_this_xsub ++;
1419 for (; !/^$BLOCK_re/o; $_ = shift(@line)) {
1422 trim_whitespace($_);
1423 if ($_ eq 'DISABLE') {
1426 elsif ($_ eq 'ENABLE') {
1430 # remove any whitespace
1432 death("Error: Invalid prototype '$_'")
1433 unless ValidProtoString($_);
1434 $ProtoThisXSUB = C_string($_);
1438 # If no prototype specified, then assume empty prototype ""
1439 $ProtoThisXSUB = 2 unless $specified;
1444 sub SCOPE_handler () {
1445 death("Error: Only 1 SCOPE declaration allowed per xsub")
1446 if $scope_in_this_xsub ++;
1448 trim_whitespace($_);
1449 death ("Error: SCOPE: ENABLE/DISABLE")
1450 unless /^(ENABLE|DISABLE)\b/i;
1451 $ScopeThisXSUB = ( uc($1) eq 'ENABLE' );
1454 sub PROTOTYPES_handler () {
1455 # the rest of the current line should contain either ENABLE or
1458 trim_whitespace($_);
1460 # check for ENABLE/DISABLE
1461 death ("Error: PROTOTYPES: ENABLE/DISABLE")
1462 unless /^(ENABLE|DISABLE)/i;
1464 $WantPrototypes = 1 if $1 eq 'ENABLE';
1465 $WantPrototypes = 0 if $1 eq 'DISABLE';
1470 # Save the current file context.
1473 LastLine => $lastline,
1474 LastLineNo => $lastline_no,
1476 LineNo => \@line_no,
1477 Filename => $filename,
1478 Filepathname => $filepathname,
1480 IsPipe => scalar($filename =~ /\|\s*$/),
1486 sub INCLUDE_handler () {
1487 # the rest of the current line should contain a valid filename
1489 trim_whitespace($_);
1491 death("INCLUDE: filename missing")
1494 death("INCLUDE: output pipe is illegal")
1497 # simple minded recursion detector
1498 death("INCLUDE loop detected")
1499 if $IncludedFiles{$_};
1501 ++ $IncludedFiles{$_} unless /\|\s*$/;
1503 if (/\|\s*$/ && /^\s*perl\s/) {
1504 Warn("The INCLUDE directive with a command is discouraged." .
1505 " Use INCLUDE_COMMAND instead! In particular using 'perl'" .
1506 " in an 'INCLUDE: ... |' directive is not guaranteed to pick" .
1507 " up the correct perl. The INCLUDE_COMMAND directive allows" .
1508 " the use of \$^X as the currently running perl, see" .
1509 " 'perldoc perlxs' for details.");
1514 $FH = Symbol::gensym();
1517 open ($FH, "$_") or death("Cannot open '$_': $!");
1521 #/* INCLUDE: Including '$_' from '$filename' */
1526 $filepathname = File::Spec->catfile($dir, $filename);
1528 # Prime the pump by reading the first
1531 # skip leading blank lines
1533 last unless /^\s*$/;
1542 my @args = split /\s+/, $cmd;
1545 $_ = q(").$_.q(") if !/^\"/ && length($_) > 0;
1547 return join (' ', ($cmd, @args));
1550 sub INCLUDE_COMMAND_handler () {
1551 # the rest of the current line should contain a valid command
1553 trim_whitespace($_);
1555 $_ = QuoteArgs($_) if $^O eq 'VMS';
1557 death("INCLUDE_COMMAND: command missing")
1560 death("INCLUDE_COMMAND: pipes are illegal")
1561 if /^\s*\|/ or /\|\s*$/;
1563 PushXSStack( IsPipe => 1 );
1565 $FH = Symbol::gensym();
1567 # If $^X is used in INCLUDE_COMMAND, we know it's supposed to be
1568 # the same perl interpreter as we're currently running
1572 open ($FH, "-|", "$_")
1573 or death("Cannot run command '$_' to include its output: $!");
1577 #/* INCLUDE_COMMAND: Including output of '$_' from '$filename' */
1582 $filepathname = $filename;
1583 $filepathname =~ s/\"/\\"/g;
1585 # Prime the pump by reading the first
1588 # skip leading blank lines
1590 last unless /^\s*$/;
1598 return 0 unless $XSStack[-1]{type} eq 'file';
1600 my $data = pop @XSStack;
1601 my $ThisFile = $filename;
1602 my $isPipe = $data->{IsPipe};
1604 -- $IncludedFiles{$filename}
1609 $FH = $data->{Handle};
1610 # $filename is the leafname, which for some reason isused for diagnostic
1611 # messages, whereas $filepathname is the full pathname, and is used for
1613 $filename = $data->{Filename};
1614 $filepathname = $data->{Filepathname};
1615 $lastline = $data->{LastLine};
1616 $lastline_no = $data->{LastLineNo};
1617 @line = @{ $data->{Line} };
1618 @line_no = @{ $data->{LineNo} };
1620 if ($isPipe and $? ) {
1622 print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n" ;
1628 #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
1635 sub ValidProtoString ($) {
1638 if ( $string =~ /^$proto_re+$/ ) {
1648 $string =~ s[\\][\\\\]g;
1652 sub ProtoString ($) {
1655 $proto_letter{$type} or "\$";
1659 my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
1661 my ($cpp, $cpplevel);
1663 if ($cpp =~ /^\#\s*if/) {
1666 elsif (!$cpplevel) {
1667 Warn("Warning: #else/elif/endif without #if in this function");
1668 print STDERR " (precede it with a blank line if the matching #if is outside the function)\n"
1669 if $XSStack[-1]{type} eq 'if';
1672 elsif ($cpp =~ /^\#\s*endif/) {
1676 Warn("Warning: #if without #endif in this function") if $cpplevel;
1684 $text =~ s/\[\[/{/g;
1685 $text =~ s/\]\]/}/g;
1689 # Read next xsub into @line from ($lastline, <$FH>).
1692 death ("Error: Unterminated `#if/#ifdef/#ifndef'")
1693 if !defined $lastline && $XSStack[-1]{type} eq 'if';
1696 return PopFile() if !defined $lastline;
1699 /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
1701 $Package = defined($2) ? $2 : ''; # keep -w happy
1702 $Prefix = defined($3) ? $3 : ''; # keep -w happy
1703 $Prefix = quotemeta $Prefix;
1704 ($Module_cname = $Module) =~ s/\W/_/g;
1705 ($Packid = $Package) =~ tr/:/_/;
1706 $Packprefix = $Package;
1707 $Packprefix .= "::" if $Packprefix ne "";
1712 # Skip embedded PODs
1713 while ($lastline =~ /^=/) {
1714 while ($lastline = <$FH>) {
1715 last if ($lastline =~ /^=cut\s*$/);
1717 death ("Error: Unterminated pod") unless $lastline;
1720 $lastline =~ s/^\s+$//;
1722 if ($lastline !~ /^\s*#/ ||
1724 # ANSI: if ifdef ifndef elif else endif define undef
1726 # gcc: warning include_next
1728 # others: ident (gcc notes that some cpps have this one)
1729 $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
1730 last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
1731 push(@line, $lastline);
1732 push(@line_no, $lastline_no);
1735 # Read next line and continuation lines
1736 last unless defined($lastline = <$FH>);
1739 $lastline .= $tmp_line
1740 while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
1743 $lastline =~ s/^\s+$//;
1745 pop(@line), pop(@line_no) while @line && $line[-1] eq "";
1750 local($type, $num, $var, $init, $name_printed) = @_;
1751 local($arg) = "ST(" . ($num - 1) . ")";
1753 if ( $init =~ /^=/ ) {
1754 if ($name_printed) {
1755 eval qq/print " $init\\n"/;
1758 eval qq/print "\\t$var $init\\n"/;
1763 if ( $init =~ s/^\+// && $num ) {
1764 &generate_init($type, $num, $var, $name_printed);
1766 elsif ($name_printed) {
1771 eval qq/print "\\t$var;\\n"/;
1775 $deferred .= eval qq/"\\n\\t$init\\n"/;
1781 # work out the line number
1782 my $line_no = $line_no[@line_no - @line -1];
1784 print STDERR "@_ in $filename, line $line_no\n";
1798 local($type, $num, $var) = @_;
1799 local($arg) = "ST(" . ($num - 1) . ")";
1800 local($argoff) = $num - 1;
1804 $type = tidy_type($type);
1805 blurt("Error: '$type' not in typemap"), return
1806 unless defined($type_kind{$type});
1808 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1809 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1810 $tk = $type_kind{$type};
1811 $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
1812 if ($tk eq 'T_PV' and exists $lengthof{$var}) {
1813 print "\t$var" unless $name_printed;
1814 print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
1815 die "default value not supported with length(NAME) supplied"
1816 if defined $defaults{$var};
1819 $type =~ tr/:/_/ unless $hiertype;
1820 blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1821 unless defined $input_expr{$tk};
1822 $expr = $input_expr{$tk};
1823 if ($expr =~ /DO_ARRAY_ELEM/) {
1824 blurt("Error: '$subtype' not in typemap"), return
1825 unless defined($type_kind{$subtype});
1826 blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1827 unless defined $input_expr{$type_kind{$subtype}};
1828 $subexpr = $input_expr{$type_kind{$subtype}};
1829 $subexpr =~ s/\$type/\$subtype/g;
1830 $subexpr =~ s/ntype/subtype/g;
1831 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1832 $subexpr =~ s/\n\t/\n\t\t/g;
1833 $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
1834 $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
1835 $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
1837 if ($expr =~ m#/\*.*scope.*\*/#i) { # "scope" in C comments
1840 if (defined($defaults{$var})) {
1841 $expr =~ s/(\t+)/$1 /g;
1843 if ($name_printed) {
1847 eval qq/print "\\t$var;\\n"/;
1850 if ($defaults{$var} eq 'NO_INIT') {
1851 $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
1854 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
1858 elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
1859 if ($name_printed) {
1863 eval qq/print "\\t$var;\\n"/;
1866 $deferred .= eval qq/"\\n$expr;\\n"/;
1870 die "panic: do not know how to handle this branch for function pointers"
1872 eval qq/print "$expr;\\n"/;
1877 sub generate_output {
1878 local($type, $num, $var, $do_setmagic, $do_push) = @_;
1879 local($arg) = "ST(" . ($num - ($num != 0)) . ")";
1880 local($argoff) = $num - 1;
1883 $type = tidy_type($type);
1884 if ($type =~ /^array\(([^,]*),(.*)\)/) {
1885 print "\t$arg = sv_newmortal();\n";
1886 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
1887 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1890 blurt("Error: '$type' not in typemap"), return
1891 unless defined($type_kind{$type});
1892 blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
1893 unless defined $output_expr{$type_kind{$type}};
1894 ($ntype = $type) =~ s/\s*\*/Ptr/g;
1895 $ntype =~ s/\(\)//g;
1896 ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
1897 $expr = $output_expr{$type_kind{$type}};
1898 if ($expr =~ /DO_ARRAY_ELEM/) {
1899 blurt("Error: '$subtype' not in typemap"), return
1900 unless defined($type_kind{$subtype});
1901 blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
1902 unless defined $output_expr{$type_kind{$subtype}};
1903 $subexpr = $output_expr{$type_kind{$subtype}};
1904 $subexpr =~ s/ntype/subtype/g;
1905 $subexpr =~ s/\$arg/ST(ix_$var)/g;
1906 $subexpr =~ s/\$var/${var}[ix_$var]/g;
1907 $subexpr =~ s/\n\t/\n\t\t/g;
1908 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
1909 eval "print qq\a$expr\a";
1911 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
1913 elsif ($var eq 'RETVAL') {
1914 if ($expr =~ /^\t\$arg = new/) {
1915 # We expect that $arg has refcnt 1, so we need to
1917 eval "print qq\a$expr\a";
1919 print "\tsv_2mortal(ST($num));\n";
1920 print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
1922 elsif ($expr =~ /^\s*\$arg\s*=/) {
1923 # We expect that $arg has refcnt >=1, so we need
1925 eval "print qq\a$expr\a";
1927 print "\tsv_2mortal(ST(0));\n";
1928 print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
1931 # Just hope that the entry would safely write it
1932 # over an already mortalized value. By
1933 # coincidence, something like $arg = &sv_undef
1935 print "\tST(0) = sv_newmortal();\n";
1936 eval "print qq\a$expr\a";
1938 # new mortals don't have set magic
1942 print "\tPUSHs(sv_newmortal());\n";
1944 eval "print qq\a$expr\a";
1946 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1948 elsif ($arg =~ /^ST\(\d+\)$/) {
1949 eval "print qq\a$expr\a";
1951 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
1957 my($type, $varname) = @_;
1959 # C++ has :: in types too so skip this
1960 $type =~ tr/:/_/ unless $hiertype;
1961 $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
1963 if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
1964 (substr $type, pos $type, 0) = " $varname ";
1967 $type .= "\t$varname";
1974 #########################################################
1976 ExtUtils::ParseXS::CountLines;
1978 our $SECTION_END_MARKER;
1981 my ($class, $cfile, $fh) = @_;
1982 $cfile =~ s/\\/\\\\/g;
1983 $SECTION_END_MARKER = qq{#line --- "$cfile"};
1995 $self->{buffer} .= $_;
1996 while ($self->{buffer} =~ s/^([^\n]*\n)//) {
1998 ++ $self->{line_no};
1999 $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
2000 print {$self->{fh}} $line;
2008 $self->PRINT(sprintf($fmt, @_));
2012 # Not necessary if we're careful to end with a "\n"
2014 print {$self->{fh}} $self->{buffer};
2018 # This sub does nothing, but is neccessary for references to be released.
2022 return $SECTION_END_MARKER;