home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl / 5.10.0 / ExtUtils / ParseXS.pm < prev    next >
Encoding:
Perl POD Document  |  2009-06-26  |  54.4 KB  |  2,053 lines
  1. package ExtUtils::ParseXS;
  2.  
  3. use 5.006;  # We use /??{}/ in regexes
  4. use Cwd;
  5. use Config;
  6. use File::Basename;
  7. use File::Spec;
  8. use Symbol;
  9.  
  10. require Exporter;
  11.  
  12. @ISA = qw(Exporter);
  13. @EXPORT_OK = qw(process_file);
  14.  
  15. # use strict;  # One of these days...
  16.  
  17. my(@XSStack);    # Stack of conditionals and INCLUDEs
  18. my($XSS_work_idx, $cpp_next_tmp);
  19.  
  20. use vars qw($VERSION);
  21. $VERSION = '2.18_02';
  22.  
  23. use vars qw(%input_expr %output_expr $ProtoUsed @InitFileCode $FH $proto_re $Overload $errors $Fallback
  24.         $cplusplus $hiertype $WantPrototypes $WantVersionChk $except $WantLineNumbers
  25.         $WantOptimize $process_inout $process_argtypes @tm
  26.         $dir $filename $filepathname %IncludedFiles
  27.         %type_kind %proto_letter
  28.             %targetable $BLOCK_re $lastline $lastline_no
  29.             $Package $Prefix @line @BootCode %args_match %defaults %var_types %arg_list @proto_arg
  30.             $processing_arg_with_types %argtype_seen @outlist %in_out %lengthof
  31.             $proto_in_this_xsub $scope_in_this_xsub $interface $prepush_done $interface_macro $interface_macro_set
  32.             $ProtoThisXSUB $ScopeThisXSUB $xsreturn
  33.             @line_no $ret_type $func_header $orig_args
  34.        ); # Add these just to get compilation to happen.
  35.  
  36.  
  37. sub process_file {
  38.   
  39.   # Allow for $package->process_file(%hash) in the future
  40.   my ($pkg, %args) = @_ % 2 ? @_ : (__PACKAGE__, @_);
  41.   
  42.   $ProtoUsed = exists $args{prototypes};
  43.   
  44.   # Set defaults.
  45.   %args = (
  46.        # 'C++' => 0, # Doesn't seem to *do* anything...
  47.        hiertype => 0,
  48.        except => 0,
  49.        prototypes => 0,
  50.        versioncheck => 1,
  51.        linenumbers => 1,
  52.        optimize => 1,
  53.        prototypes => 0,
  54.        inout => 1,
  55.        argtypes => 1,
  56.        typemap => [],
  57.        output => \*STDOUT,
  58.        csuffix => '.c',
  59.        %args,
  60.       );
  61.  
  62.   # Global Constants
  63.   
  64.   my ($Is_VMS, $SymSet);
  65.   if ($^O eq 'VMS') {
  66.     $Is_VMS = 1;
  67.     # Establish set of global symbols with max length 28, since xsubpp
  68.     # will later add the 'XS_' prefix.
  69.     require ExtUtils::XSSymSet;
  70.     $SymSet = new ExtUtils::XSSymSet 28;
  71.   }
  72.   @XSStack = ({type => 'none'});
  73.   ($XSS_work_idx, $cpp_next_tmp) = (0, "XSubPPtmpAAAA");
  74.   @InitFileCode = ();
  75.   $FH = Symbol::gensym();
  76.   $proto_re = "[" . quotemeta('\$%&*@;[]') . "]" ;
  77.   $Overload = 0;
  78.   $errors = 0;
  79.   $Fallback = 'PL_sv_undef';
  80.  
  81.   # Most of the 1500 lines below uses these globals.  We'll have to
  82.   # clean this up sometime, probably.  For now, we just pull them out
  83.   # of %args.  -Ken
  84.   
  85.   $cplusplus = $args{'C++'};
  86.   $hiertype = $args{hiertype};
  87.   $WantPrototypes = $args{prototypes};
  88.   $WantVersionChk = $args{versioncheck};
  89.   $except = $args{except} ? ' TRY' : '';
  90.   $WantLineNumbers = $args{linenumbers};
  91.   $WantOptimize = $args{optimize};
  92.   $process_inout = $args{inout};
  93.   $process_argtypes = $args{argtypes};
  94.   @tm = ref $args{typemap} ? @{$args{typemap}} : ($args{typemap});
  95.   
  96.   for ($args{filename}) {
  97.     die "Missing required parameter 'filename'" unless $_;
  98.     $filepathname = $_;
  99.     ($dir, $filename) = (dirname($_), basename($_));
  100.     $filepathname =~ s/\\/\\\\/g;
  101.     $IncludedFiles{$_}++;
  102.   }
  103.   
  104.   # Open the input file
  105.   open($FH, $args{filename}) or die "cannot open $args{filename}: $!\n";
  106.  
  107.   # Open the output file if given as a string.  If they provide some
  108.   # other kind of reference, trust them that we can print to it.
  109.   if (not ref $args{output}) {
  110.     open my($fh), "> $args{output}" or die "Can't create $args{output}: $!";
  111.     $args{outfile} = $args{output};
  112.     $args{output} = $fh;
  113.   }
  114.  
  115.   # Really, we shouldn't have to chdir() or select() in the first
  116.   # place.  For now, just save & restore.
  117.   my $orig_cwd = cwd();
  118.   my $orig_fh = select();
  119.   
  120.   chdir($dir);
  121.   my $pwd = cwd();
  122.   my $csuffix = $args{csuffix};
  123.   
  124.   if ($WantLineNumbers) {
  125.     my $cfile;
  126.     if ( $args{outfile} ) {
  127.       $cfile = $args{outfile};
  128.     } else {
  129.       $cfile = $args{filename};
  130.       $cfile =~ s/\.xs$/$csuffix/i or $cfile .= $csuffix;
  131.     }
  132.     tie(*PSEUDO_STDOUT, 'ExtUtils::ParseXS::CountLines', $cfile, $args{output});
  133.     select PSEUDO_STDOUT;
  134.   } else {
  135.     select $args{output};
  136.   }
  137.  
  138.   foreach my $typemap (@tm) {
  139.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  140.   }
  141.  
  142.   push @tm, standard_typemap_locations();
  143.  
  144.   foreach my $typemap (@tm) {
  145.     next unless -f $typemap ;
  146.     # skip directories, binary files etc.
  147.     warn("Warning: ignoring non-text typemap file '$typemap'\n"), next
  148.       unless -T $typemap ;
  149.     open(TYPEMAP, $typemap)
  150.       or warn ("Warning: could not open typemap file '$typemap': $!\n"), next;
  151.     my $mode = 'Typemap';
  152.     my $junk = "" ;
  153.     my $current = \$junk;
  154.     while (<TYPEMAP>) {
  155.       next if /^\s*        #/;
  156.         my $line_no = $. + 1;
  157.       if (/^INPUT\s*$/) {
  158.     $mode = 'Input';   $current = \$junk;  next;
  159.       }
  160.       if (/^OUTPUT\s*$/) {
  161.     $mode = 'Output';  $current = \$junk;  next;
  162.       }
  163.       if (/^TYPEMAP\s*$/) {
  164.     $mode = 'Typemap'; $current = \$junk;  next;
  165.       }
  166.       if ($mode eq 'Typemap') {
  167.     chomp;
  168.     my $line = $_ ;
  169.     TrimWhitespace($_) ;
  170.     # skip blank lines and comment lines
  171.     next if /^$/ or /^#/ ;
  172.     my($type,$kind, $proto) = /^\s*(.*?\S)\s+(\S+)\s*($proto_re*)\s*$/ or
  173.       warn("Warning: File '$typemap' Line $. '$line' TYPEMAP entry needs 2 or 3 columns\n"), next;
  174.     $type = TidyType($type) ;
  175.     $type_kind{$type} = $kind ;
  176.     # prototype defaults to '$'
  177.     $proto = "\$" unless $proto ;
  178.     warn("Warning: File '$typemap' Line $. '$line' Invalid prototype '$proto'\n")
  179.       unless ValidProtoString($proto) ;
  180.     $proto_letter{$type} = C_string($proto) ;
  181.       } elsif (/^\s/) {
  182.     $$current .= $_;
  183.       } elsif ($mode eq 'Input') {
  184.     s/\s+$//;
  185.     $input_expr{$_} = '';
  186.     $current = \$input_expr{$_};
  187.       } else {
  188.     s/\s+$//;
  189.     $output_expr{$_} = '';
  190.     $current = \$output_expr{$_};
  191.       }
  192.     }
  193.     close(TYPEMAP);
  194.   }
  195.  
  196.   foreach my $value (values %input_expr) {
  197.     $value =~ s/;*\s+\z//;
  198.     # Move C pre-processor instructions to column 1 to be strictly ANSI
  199.     # conformant. Some pre-processors are fussy about this.
  200.     $value =~ s/^\s+#/#/mg;
  201.   }
  202.   foreach my $value (values %output_expr) {
  203.     # And again.
  204.     $value =~ s/^\s+#/#/mg;
  205.   }
  206.  
  207.   my ($cast, $size);
  208.   our $bal = qr[(?:(?>[^()]+)|\((??{ $bal })\))*]; # ()-balanced
  209.   $cast = qr[(?:\(\s*SV\s*\*\s*\)\s*)?]; # Optional (SV*) cast
  210.   $size = qr[,\s* (??{ $bal }) ]x; # Third arg (to setpvn)
  211.  
  212.   foreach my $key (keys %output_expr) {
  213.     BEGIN { $^H |= 0x00200000 }; # Equivalent to: use re 'eval', but hardcoded so we can compile re.xs
  214.  
  215.     my ($t, $with_size, $arg, $sarg) =
  216.       ($output_expr{$key} =~
  217.        m[^ \s+ sv_set ( [iunp] ) v (n)?    # Type, is_setpvn
  218.      \s* \( \s* $cast \$arg \s* ,
  219.      \s* ( (??{ $bal }) )    # Set from
  220.      ( (??{ $size }) )?    # Possible sizeof set-from
  221.      \) \s* ; \s* $
  222.     ]x);
  223.     $targetable{$key} = [$t, $with_size, $arg, $sarg] if $t;
  224.   }
  225.  
  226.   my $END = "!End!\n\n";        # "impossible" keyword (multiple newline)
  227.  
  228.   # Match an XS keyword
  229.   $BLOCK_re= '\s*(' . join('|', qw(
  230.                    REQUIRE BOOT CASE PREINIT INPUT INIT CODE PPCODE OUTPUT
  231.                    CLEANUP ALIAS ATTRS PROTOTYPES PROTOTYPE VERSIONCHECK INCLUDE
  232.                    SCOPE INTERFACE INTERFACE_MACRO C_ARGS POSTCALL OVERLOAD FALLBACK
  233.                   )) . "|$END)\\s*:";
  234.  
  235.   
  236.   our ($C_group_rex, $C_arg);
  237.   # Group in C (no support for comments or literals)
  238.   $C_group_rex = qr/ [({\[]
  239.                (?: (?> [^()\[\]{}]+ ) | (??{ $C_group_rex }) )*
  240.                [)}\]] /x ;
  241.   # Chunk in C without comma at toplevel (no comments):
  242.   $C_arg = qr/ (?: (?> [^()\[\]{},"']+ )
  243.          |   (??{ $C_group_rex })
  244.          |   " (?: (?> [^\\"]+ )
  245.            |   \\.
  246.            )* "        # String literal
  247.                 |   ' (?: (?> [^\\']+ ) | \\. )* ' # Char literal
  248.          )* /xs;
  249.   
  250.   # Identify the version of xsubpp used
  251.   print <<EOM ;
  252. /*
  253.  * This file was generated automatically by ExtUtils::ParseXS version $VERSION from the
  254.  * contents of $filename. Do not edit this file, edit $filename instead.
  255.  *
  256.  *    ANY CHANGES MADE HERE WILL BE LOST! 
  257.  *
  258.  */
  259.  
  260. EOM
  261.  
  262.  
  263.   print("#line 1 \"$filepathname\"\n")
  264.     if $WantLineNumbers;
  265.  
  266.   firstmodule:
  267.   while (<$FH>) {
  268.     if (/^=/) {
  269.       my $podstartline = $.;
  270.       do {
  271.     if (/^=cut\s*$/) {
  272.       # We can't just write out a /* */ comment, as our embedded
  273.       # POD might itself be in a comment. We can't put a /**/
  274.       # comment inside #if 0, as the C standard says that the source
  275.       # file is decomposed into preprocessing characters in the stage
  276.       # before preprocessing commands are executed.
  277.       # I don't want to leave the text as barewords, because the spec
  278.       # isn't clear whether macros are expanded before or after
  279.       # preprocessing commands are executed, and someone pathological
  280.       # may just have defined one of the 3 words as a macro that does
  281.       # something strange. Multiline strings are illegal in C, so
  282.       # the "" we write must be a string literal. And they aren't
  283.       # concatenated until 2 steps later, so we are safe.
  284.       #     - Nicholas Clark
  285.       print("#if 0\n  \"Skipped embedded POD.\"\n#endif\n");
  286.       printf("#line %d \"$filepathname\"\n", $. + 1)
  287.         if $WantLineNumbers;
  288.       next firstmodule
  289.     }
  290.     
  291.       } while (<$FH>);
  292.       # At this point $. is at end of file so die won't state the start
  293.       # of the problem, and as we haven't yet read any lines &death won't
  294.       # show the correct line in the message either.
  295.       die ("Error: Unterminated pod in $filename, line $podstartline\n")
  296.     unless $lastline;
  297.     }
  298.     last if ($Package, $Prefix) =
  299.       /^MODULE\s*=\s*[\w:]+(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/;
  300.     
  301.     print $_;
  302.   }
  303.   unless (defined $_) {
  304.     warn "Didn't find a 'MODULE ... PACKAGE ... PREFIX' line\n";
  305.     exit 0; # Not a fatal error for the caller process
  306.   }
  307.  
  308.     print <<"EOF";
  309. #ifndef PERL_UNUSED_VAR
  310. #  define PERL_UNUSED_VAR(var) if (0) var = var
  311. #endif
  312.  
  313. EOF
  314.  
  315.   print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
  316.  
  317.   $lastline    = $_;
  318.   $lastline_no = $.;
  319.  
  320.  PARAGRAPH:
  321.   while (fetch_para()) {
  322.     # Print initial preprocessor statements and blank lines
  323.     while (@line && $line[0] !~ /^[^\#]/) {
  324.       my $line = shift(@line);
  325.       print $line, "\n";
  326.       next unless $line =~ /^\#\s*((if)(?:n?def)?|elsif|else|endif)\b/;
  327.       my $statement = $+;
  328.       if ($statement eq 'if') {
  329.     $XSS_work_idx = @XSStack;
  330.     push(@XSStack, {type => 'if'});
  331.       } else {
  332.     death ("Error: `$statement' with no matching `if'")
  333.       if $XSStack[-1]{type} ne 'if';
  334.     if ($XSStack[-1]{varname}) {
  335.       push(@InitFileCode, "#endif\n");
  336.       push(@BootCode,     "#endif");
  337.     }
  338.     
  339.     my(@fns) = keys %{$XSStack[-1]{functions}};
  340.     if ($statement ne 'endif') {
  341.       # Hide the functions defined in other #if branches, and reset.
  342.       @{$XSStack[-1]{other_functions}}{@fns} = (1) x @fns;
  343.       @{$XSStack[-1]}{qw(varname functions)} = ('', {});
  344.     } else {
  345.       my($tmp) = pop(@XSStack);
  346.       0 while (--$XSS_work_idx
  347.            && $XSStack[$XSS_work_idx]{type} ne 'if');
  348.       # Keep all new defined functions
  349.       push(@fns, keys %{$tmp->{other_functions}});
  350.       @{$XSStack[$XSS_work_idx]{functions}}{@fns} = (1) x @fns;
  351.     }
  352.       }
  353.     }
  354.     
  355.     next PARAGRAPH unless @line;
  356.     
  357.     if ($XSS_work_idx && !$XSStack[$XSS_work_idx]{varname}) {
  358.       # We are inside an #if, but have not yet #defined its xsubpp variable.
  359.       print "#define $cpp_next_tmp 1\n\n";
  360.       push(@InitFileCode, "#if $cpp_next_tmp\n");
  361.       push(@BootCode,     "#if $cpp_next_tmp");
  362.       $XSStack[$XSS_work_idx]{varname} = $cpp_next_tmp++;
  363.     }
  364.  
  365.     death ("Code is not inside a function"
  366.        ." (maybe last function was ended by a blank line "
  367.        ." followed by a statement on column one?)")
  368.       if $line[0] =~ /^\s/;
  369.     
  370.     my ($class, $externC, $static, $ellipsis, $wantRETVAL, $RETVAL_no_return);
  371.     my (@fake_INPUT_pre);    # For length(s) generated variables
  372.     my (@fake_INPUT);
  373.     
  374.     # initialize info arrays
  375.     undef(%args_match);
  376.     undef(%var_types);
  377.     undef(%defaults);
  378.     undef(%arg_list) ;
  379.     undef(@proto_arg) ;
  380.     undef($processing_arg_with_types) ;
  381.     undef(%argtype_seen) ;
  382.     undef(@outlist) ;
  383.     undef(%in_out) ;
  384.     undef(%lengthof) ;
  385.     undef($proto_in_this_xsub) ;
  386.     undef($scope_in_this_xsub) ;
  387.     undef($interface);
  388.     undef($prepush_done);
  389.     $interface_macro = 'XSINTERFACE_FUNC' ;
  390.     $interface_macro_set = 'XSINTERFACE_FUNC_SET' ;
  391.     $ProtoThisXSUB = $WantPrototypes ;
  392.     $ScopeThisXSUB = 0;
  393.     $xsreturn = 0;
  394.  
  395.     $_ = shift(@line);
  396.     while (my $kwd = check_keyword("REQUIRE|PROTOTYPES|FALLBACK|VERSIONCHECK|INCLUDE")) {
  397.       &{"${kwd}_handler"}() ;
  398.       next PARAGRAPH unless @line ;
  399.       $_ = shift(@line);
  400.     }
  401.  
  402.     if (check_keyword("BOOT")) {
  403.       &check_cpp;
  404.       push (@BootCode, "#line $line_no[@line_no - @line] \"$filepathname\"")
  405.     if $WantLineNumbers && $line[0] !~ /^\s*#\s*line\b/;
  406.       push (@BootCode, @line, "") ;
  407.       next PARAGRAPH ;
  408.     }
  409.  
  410.  
  411.     # extract return type, function name and arguments
  412.     ($ret_type) = TidyType($_);
  413.     $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
  414.  
  415.     # Allow one-line ANSI-like declaration
  416.     unshift @line, $2
  417.       if $process_argtypes
  418.     and $ret_type =~ s/^(.*?\w.*?)\s*\b(\w+\s*\(.*)/$1/s;
  419.  
  420.     # a function definition needs at least 2 lines
  421.     blurt ("Error: Function definition too short '$ret_type'"), next PARAGRAPH
  422.       unless @line ;
  423.  
  424.     $externC = 1 if $ret_type =~ s/^extern "C"\s+//;
  425.     $static  = 1 if $ret_type =~ s/^static\s+//;
  426.  
  427.     $func_header = shift(@line);
  428.     blurt ("Error: Cannot parse function definition from '$func_header'"), next PARAGRAPH
  429.       unless $func_header =~ /^(?:([\w:]*)::)?(\w+)\s*\(\s*(.*?)\s*\)\s*(const)?\s*(;\s*)?$/s;
  430.  
  431.     ($class, $func_name, $orig_args) =  ($1, $2, $3) ;
  432.     $class = "$4 $class" if $4;
  433.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  434.     ($clean_func_name = $func_name) =~ s/^$Prefix//;
  435.     $Full_func_name = "${Packid}_$clean_func_name";
  436.     if ($Is_VMS) {
  437.       $Full_func_name = $SymSet->addsym($Full_func_name);
  438.     }
  439.  
  440.     # Check for duplicate function definition
  441.     for my $tmp (@XSStack) {
  442.       next unless defined $tmp->{functions}{$Full_func_name};
  443.       Warn("Warning: duplicate function definition '$clean_func_name' detected");
  444.       last;
  445.     }
  446.     $XSStack[$XSS_work_idx]{functions}{$Full_func_name} ++ ;
  447.     %XsubAliases = %XsubAliasValues = %Interfaces = @Attributes = ();
  448.     $DoSetMagic = 1;
  449.  
  450.     $orig_args =~ s/\\\s*/ /g;    # process line continuations
  451.     my @args;
  452.  
  453.     my %only_C_inlist;        # Not in the signature of Perl function
  454.     if ($process_argtypes and $orig_args =~ /\S/) {
  455.       my $args = "$orig_args ,";
  456.       if ($args =~ /^( (??{ $C_arg }) , )* $ /x) {
  457.     @args = ($args =~ /\G ( (??{ $C_arg }) ) , /xg);
  458.     for ( @args ) {
  459.       s/^\s+//;
  460.       s/\s+$//;
  461.       my ($arg, $default) = / ( [^=]* ) ( (?: = .* )? ) /x;
  462.       my ($pre, $name) = ($arg =~ /(.*?) \s*
  463.                          \b ( \w+ | length\( \s*\w+\s* \) )
  464.                          \s* $ /x);
  465.       next unless defined($pre) && length($pre);
  466.       my $out_type = '';
  467.       my $inout_var;
  468.       if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//) {
  469.         my $type = $1;
  470.         $out_type = $type if $type ne 'IN';
  471.         $arg =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
  472.         $pre =~ s/^(IN|IN_OUTLIST|OUTLIST|OUT|IN_OUT)\s+//;
  473.       }
  474.       my $islength;
  475.       if ($name =~ /^length\( \s* (\w+) \s* \)\z/x) {
  476.         $name = "XSauto_length_of_$1";
  477.         $islength = 1;
  478.         die "Default value on length() argument: `$_'"
  479.           if length $default;
  480.       }
  481.       if (length $pre or $islength) { # Has a type
  482.         if ($islength) {
  483.           push @fake_INPUT_pre, $arg;
  484.         } else {
  485.           push @fake_INPUT, $arg;
  486.         }
  487.         # warn "pushing '$arg'\n";
  488.         $argtype_seen{$name}++;
  489.         $_ = "$name$default"; # Assigns to @args
  490.       }
  491.       $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST" or $islength;
  492.       push @outlist, $name if $out_type =~ /OUTLIST$/;
  493.       $in_out{$name} = $out_type if $out_type;
  494.     }
  495.       } else {
  496.     @args = split(/\s*,\s*/, $orig_args);
  497.     Warn("Warning: cannot parse argument list '$orig_args', fallback to split");
  498.       }
  499.     } else {
  500.       @args = split(/\s*,\s*/, $orig_args);
  501.       for (@args) {
  502.     if ($process_inout and s/^(IN|IN_OUTLIST|OUTLIST|IN_OUT|OUT)\s+//) {
  503.       my $out_type = $1;
  504.       next if $out_type eq 'IN';
  505.       $only_C_inlist{$_} = 1 if $out_type eq "OUTLIST";
  506.       push @outlist, $name if $out_type =~ /OUTLIST$/;
  507.       $in_out{$_} = $out_type;
  508.     }
  509.       }
  510.     }
  511.     if (defined($class)) {
  512.       my $arg0 = ((defined($static) or $func_name eq 'new')
  513.           ? "CLASS" : "THIS");
  514.       unshift(@args, $arg0);
  515.       ($report_args = "$arg0, $report_args") =~ s/^\w+, $/$arg0/;
  516.     }
  517.     my $extra_args = 0;
  518.     @args_num = ();
  519.     $num_args = 0;
  520.     my $report_args = '';
  521.     foreach my $i (0 .. $#args) {
  522.       if ($args[$i] =~ s/\.\.\.//) {
  523.     $ellipsis = 1;
  524.     if ($args[$i] eq '' && $i == $#args) {
  525.       $report_args .= ", ...";
  526.       pop(@args);
  527.       last;
  528.     }
  529.       }
  530.       if ($only_C_inlist{$args[$i]}) {
  531.     push @args_num, undef;
  532.       } else {
  533.     push @args_num, ++$num_args;
  534.     $report_args .= ", $args[$i]";
  535.       }
  536.       if ($args[$i] =~ /^([^=]*[^\s=])\s*=\s*(.*)/s) {
  537.     $extra_args++;
  538.     $args[$i] = $1;
  539.     $defaults{$args[$i]} = $2;
  540.     $defaults{$args[$i]} =~ s/"/\\"/g;
  541.       }
  542.       $proto_arg[$i+1] = '$' ;
  543.     }
  544.     $min_args = $num_args - $extra_args;
  545.     $report_args =~ s/"/\\"/g;
  546.     $report_args =~ s/^,\s+//;
  547.     my @func_args = @args;
  548.     shift @func_args if defined($class);
  549.  
  550.     for (@func_args) {
  551.       s/^/&/ if $in_out{$_};
  552.     }
  553.     $func_args = join(", ", @func_args);
  554.     @args_match{@args} = @args_num;
  555.  
  556.     $PPCODE = grep(/^\s*PPCODE\s*:/, @line);
  557.     $CODE = grep(/^\s*CODE\s*:/, @line);
  558.     # Detect CODE: blocks which use ST(n)= or XST_m*(n,v)
  559.     #   to set explicit return values.
  560.     $EXPLICIT_RETURN = ($CODE &&
  561.             ("@line" =~ /(\bST\s*\([^;]*=) | (\bXST_m\w+\s*\()/x ));
  562.     $ALIAS  = grep(/^\s*ALIAS\s*:/,  @line);
  563.     $INTERFACE  = grep(/^\s*INTERFACE\s*:/,  @line);
  564.  
  565.     $xsreturn = 1 if $EXPLICIT_RETURN;
  566.  
  567.     $externC = $externC ? qq[extern "C"] : "";
  568.  
  569.     # print function header
  570.     print Q(<<"EOF");
  571. #$externC
  572. #XS(XS_${Full_func_name}); /* prototype to pass -Wmissing-prototypes */
  573. #XS(XS_${Full_func_name})
  574. #[[
  575. ##ifdef dVAR
  576. #    dVAR; dXSARGS;
  577. ##else
  578. #    dXSARGS;
  579. ##endif
  580. EOF
  581.     print Q(<<"EOF") if $ALIAS ;
  582. #    dXSI32;
  583. EOF
  584.     print Q(<<"EOF") if $INTERFACE ;
  585. #    dXSFUNCTION($ret_type);
  586. EOF
  587.     if ($ellipsis) {
  588.       $cond = ($min_args ? qq(items < $min_args) : 0);
  589.     } elsif ($min_args == $num_args) {
  590.       $cond = qq(items != $min_args);
  591.     } else {
  592.       $cond = qq(items < $min_args || items > $num_args);
  593.     }
  594.  
  595.     print Q(<<"EOF") if $except;
  596. #    char errbuf[1024];
  597. #    *errbuf = '\0';
  598. EOF
  599.  
  600.     if ($ALIAS)
  601.       { print Q(<<"EOF") if $cond }
  602. #    if ($cond)
  603. #       Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "$report_args");
  604. EOF
  605.     else
  606.       { print Q(<<"EOF") if $cond }
  607. #    if ($cond)
  608. #       Perl_croak(aTHX_ "Usage: %s(%s)", "$pname", "$report_args");
  609. EOF
  610.     
  611.      # cv doesn't seem to be used, in most cases unless we go in 
  612.      # the if of this else
  613.      print Q(<<"EOF");
  614. #    PERL_UNUSED_VAR(cv); /* -W */
  615. EOF
  616.  
  617.     #gcc -Wall: if an xsub has PPCODE is used
  618.     #it is possible none of ST, XSRETURN or XSprePUSH macros are used
  619.     #hence `ax' (setup by dXSARGS) is unused
  620.     #XXX: could breakup the dXSARGS; into dSP;dMARK;dITEMS
  621.     #but such a move could break third-party extensions
  622.     print Q(<<"EOF") if $PPCODE;
  623. #    PERL_UNUSED_VAR(ax); /* -Wall */
  624. EOF
  625.  
  626.     print Q(<<"EOF") if $PPCODE;
  627. #    SP -= items;
  628. EOF
  629.  
  630.     # Now do a block of some sort.
  631.  
  632.     $condnum = 0;
  633.     $cond = '';            # last CASE: condidional
  634.     push(@line, "$END:");
  635.     push(@line_no, $line_no[-1]);
  636.     $_ = '';
  637.     &check_cpp;
  638.     while (@line) {
  639.       &CASE_handler if check_keyword("CASE");
  640.       print Q(<<"EOF");
  641. #   $except [[
  642. EOF
  643.  
  644.       # do initialization of input variables
  645.       $thisdone = 0;
  646.       $retvaldone = 0;
  647.       $deferred = "";
  648.       %arg_list = () ;
  649.       $gotRETVAL = 0;
  650.     
  651.       INPUT_handler() ;
  652.       process_keyword("INPUT|PREINIT|INTERFACE_MACRO|C_ARGS|ALIAS|ATTRS|PROTOTYPE|SCOPE|OVERLOAD") ;
  653.  
  654.       print Q(<<"EOF") if $ScopeThisXSUB;
  655. #   ENTER;
  656. #   [[
  657. EOF
  658.     
  659.       if (!$thisdone && defined($class)) {
  660.     if (defined($static) or $func_name eq 'new') {
  661.       print "\tchar *";
  662.       $var_types{"CLASS"} = "char *";
  663.       &generate_init("char *", 1, "CLASS");
  664.     }
  665.     else {
  666.       print "\t$class *";
  667.       $var_types{"THIS"} = "$class *";
  668.       &generate_init("$class *", 1, "THIS");
  669.     }
  670.       }
  671.       
  672.       # do code
  673.       if (/^\s*NOT_IMPLEMENTED_YET/) {
  674.     print "\n\tPerl_croak(aTHX_ \"$pname: not implemented yet\");\n";
  675.     $_ = '' ;
  676.       } else {
  677.     if ($ret_type ne "void") {
  678.       print "\t" . &map_type($ret_type, 'RETVAL') . ";\n"
  679.         if !$retvaldone;
  680.       $args_match{"RETVAL"} = 0;
  681.       $var_types{"RETVAL"} = $ret_type;
  682.       print "\tdXSTARG;\n"
  683.         if $WantOptimize and $targetable{$type_kind{$ret_type}};
  684.     }
  685.     
  686.     if (@fake_INPUT or @fake_INPUT_pre) {
  687.       unshift @line, @fake_INPUT_pre, @fake_INPUT, $_;
  688.       $_ = "";
  689.       $processing_arg_with_types = 1;
  690.       INPUT_handler() ;
  691.     }
  692.     print $deferred;
  693.     
  694.         process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS|OVERLOAD") ;
  695.     
  696.     if (check_keyword("PPCODE")) {
  697.       print_section();
  698.       death ("PPCODE must be last thing") if @line;
  699.       print "\tLEAVE;\n" if $ScopeThisXSUB;
  700.       print "\tPUTBACK;\n\treturn;\n";
  701.     } elsif (check_keyword("CODE")) {
  702.       print_section() ;
  703.     } elsif (defined($class) and $func_name eq "DESTROY") {
  704.       print "\n\t";
  705.       print "delete THIS;\n";
  706.     } else {
  707.       print "\n\t";
  708.       if ($ret_type ne "void") {
  709.         print "RETVAL = ";
  710.         $wantRETVAL = 1;
  711.       }
  712.       if (defined($static)) {
  713.         if ($func_name eq 'new') {
  714.           $func_name = "$class";
  715.         } else {
  716.           print "${class}::";
  717.         }
  718.       } elsif (defined($class)) {
  719.         if ($func_name eq 'new') {
  720.           $func_name .= " $class";
  721.         } else {
  722.           print "THIS->";
  723.         }
  724.       }
  725.       $func_name =~ s/^\Q$args{'s'}//
  726.         if exists $args{'s'};
  727.       $func_name = 'XSFUNCTION' if $interface;
  728.       print "$func_name($func_args);\n";
  729.     }
  730.       }
  731.       
  732.       # do output variables
  733.       $gotRETVAL = 0;        # 1 if RETVAL seen in OUTPUT section;
  734.       undef $RETVAL_code ;    # code to set RETVAL (from OUTPUT section);
  735.       # $wantRETVAL set if 'RETVAL =' autogenerated
  736.       ($wantRETVAL, $ret_type) = (0, 'void') if $RETVAL_no_return;
  737.       undef %outargs ;
  738.       process_keyword("POSTCALL|OUTPUT|ALIAS|ATTRS|PROTOTYPE|OVERLOAD");
  739.       
  740.       &generate_output($var_types{$_}, $args_match{$_}, $_, $DoSetMagic)
  741.     for grep $in_out{$_} =~ /OUT$/, keys %in_out;
  742.       
  743.       # all OUTPUT done, so now push the return value on the stack
  744.       if ($gotRETVAL && $RETVAL_code) {
  745.     print "\t$RETVAL_code\n";
  746.       } elsif ($gotRETVAL || $wantRETVAL) {
  747.     my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
  748.     my $var = 'RETVAL';
  749.     my $type = $ret_type;
  750.     
  751.     # 0: type, 1: with_size, 2: how, 3: how_size
  752.     if ($t and not $t->[1] and $t->[0] eq 'p') {
  753.       # PUSHp corresponds to setpvn.  Treate setpv directly
  754.       my $what = eval qq("$t->[2]");
  755.       warn $@ if $@;
  756.       
  757.       print "\tsv_setpv(TARG, $what); XSprePUSH; PUSHTARG;\n";
  758.       $prepush_done = 1;
  759.     }
  760.     elsif ($t) {
  761.       my $what = eval qq("$t->[2]");
  762.       warn $@ if $@;
  763.       
  764.       my $size = $t->[3];
  765.       $size = '' unless defined $size;
  766.       $size = eval qq("$size");
  767.       warn $@ if $@;
  768.       print "\tXSprePUSH; PUSH$t->[0]($what$size);\n";
  769.       $prepush_done = 1;
  770.     }
  771.     else {
  772.       # RETVAL almost never needs SvSETMAGIC()
  773.       &generate_output($ret_type, 0, 'RETVAL', 0);
  774.     }
  775.       }
  776.       
  777.       $xsreturn = 1 if $ret_type ne "void";
  778.       my $num = $xsreturn;
  779.       my $c = @outlist;
  780.       print "\tXSprePUSH;" if $c and not $prepush_done;
  781.       print "\tEXTEND(SP,$c);\n" if $c;
  782.       $xsreturn += $c;
  783.       generate_output($var_types{$_}, $num++, $_, 0, 1) for @outlist;
  784.       
  785.       # do cleanup
  786.       process_keyword("CLEANUP|ALIAS|ATTRS|PROTOTYPE|OVERLOAD") ;
  787.       
  788.       print Q(<<"EOF") if $ScopeThisXSUB;
  789. #   ]]
  790. EOF
  791.       print Q(<<"EOF") if $ScopeThisXSUB and not $PPCODE;
  792. #   LEAVE;
  793. EOF
  794.       
  795.       # print function trailer
  796.       print Q(<<"EOF");
  797. #    ]]
  798. EOF
  799.       print Q(<<"EOF") if $except;
  800. #    BEGHANDLERS
  801. #    CATCHALL
  802. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  803. #    ENDHANDLERS
  804. EOF
  805.       if (check_keyword("CASE")) {
  806.     blurt ("Error: No `CASE:' at top of function")
  807.       unless $condnum;
  808.     $_ = "CASE: $_";    # Restore CASE: label
  809.     next;
  810.       }
  811.       last if $_ eq "$END:";
  812.       death(/^$BLOCK_re/o ? "Misplaced `$1:'" : "Junk at end of function");
  813.     }
  814.     
  815.     print Q(<<"EOF") if $except;
  816. #    if (errbuf[0])
  817. #    Perl_croak(aTHX_ errbuf);
  818. EOF
  819.     
  820.     if ($xsreturn) {
  821.       print Q(<<"EOF") unless $PPCODE;
  822. #    XSRETURN($xsreturn);
  823. EOF
  824.     } else {
  825.       print Q(<<"EOF") unless $PPCODE;
  826. #    XSRETURN_EMPTY;
  827. EOF
  828.     }
  829.  
  830.     print Q(<<"EOF");
  831. #]]
  832. #
  833. EOF
  834.  
  835.     my $newXS = "newXS" ;
  836.     my $proto = "" ;
  837.     
  838.     # Build the prototype string for the xsub
  839.     if ($ProtoThisXSUB) {
  840.       $newXS = "newXSproto";
  841.       
  842.       if ($ProtoThisXSUB eq 2) {
  843.     # User has specified empty prototype
  844.       }
  845.       elsif ($ProtoThisXSUB eq 1) {
  846.     my $s = ';';
  847.     if ($min_args < $num_args)  {
  848.       $s = '';
  849.       $proto_arg[$min_args] .= ";" ;
  850.     }
  851.     push @proto_arg, "$s\@"
  852.       if $ellipsis ;
  853.     
  854.     $proto = join ("", grep defined, @proto_arg);
  855.       }
  856.       else {
  857.     # User has specified a prototype
  858.     $proto = $ProtoThisXSUB;
  859.       }
  860.       $proto = qq{, "$proto"};
  861.     }
  862.     
  863.     if (%XsubAliases) {
  864.       $XsubAliases{$pname} = 0
  865.     unless defined $XsubAliases{$pname} ;
  866.       while ( ($name, $value) = each %XsubAliases) {
  867.     push(@InitFileCode, Q(<<"EOF"));
  868. #        cv = newXS(\"$name\", XS_$Full_func_name, file);
  869. #        XSANY.any_i32 = $value ;
  870. EOF
  871.     push(@InitFileCode, Q(<<"EOF")) if $proto;
  872. #        sv_setpv((SV*)cv$proto) ;
  873. EOF
  874.       }
  875.     }
  876.     elsif (@Attributes) {
  877.       push(@InitFileCode, Q(<<"EOF"));
  878. #        cv = newXS(\"$pname\", XS_$Full_func_name, file);
  879. #        apply_attrs_string("$Package", cv, "@Attributes", 0);
  880. EOF
  881.     }
  882.     elsif ($interface) {
  883.       while ( ($name, $value) = each %Interfaces) {
  884.     $name = "$Package\::$name" unless $name =~ /::/;
  885.     push(@InitFileCode, Q(<<"EOF"));
  886. #        cv = newXS(\"$name\", XS_$Full_func_name, file);
  887. #        $interface_macro_set(cv,$value) ;
  888. EOF
  889.     push(@InitFileCode, Q(<<"EOF")) if $proto;
  890. #        sv_setpv((SV*)cv$proto) ;
  891. EOF
  892.       }
  893.     }
  894.     else {
  895.       push(@InitFileCode,
  896.        "        ${newXS}(\"$pname\", XS_$Full_func_name, file$proto);\n");
  897.     }
  898.   }
  899.  
  900.   if ($Overload) # make it findable with fetchmethod
  901.   {
  902.     print Q(<<"EOF");
  903. #XS(XS_${Packid}_nil); /* prototype to pass -Wmissing-prototypes */
  904. #XS(XS_${Packid}_nil)
  905. #{
  906. #   XSRETURN_EMPTY;
  907. #}
  908. #
  909. EOF
  910.     unshift(@InitFileCode, <<"MAKE_FETCHMETHOD_WORK");
  911.     /* Making a sub named "${Package}::()" allows the package */
  912.     /* to be findable via fetchmethod(), and causes */
  913.     /* overload::Overloaded("${Package}") to return true. */
  914.     newXS("${Package}::()", XS_${Packid}_nil, file$proto);
  915. MAKE_FETCHMETHOD_WORK
  916.   }
  917.  
  918.   # print initialization routine
  919.  
  920.   print Q(<<"EOF");
  921. ##ifdef __cplusplus
  922. #extern "C"
  923. ##endif
  924. EOF
  925.  
  926.   print Q(<<"EOF");
  927. #XS(boot_$Module_cname); /* prototype to pass -Wmissing-prototypes */
  928. #XS(boot_$Module_cname)
  929. EOF
  930.  
  931.   print Q(<<"EOF");
  932. #[[
  933. ##ifdef dVAR
  934. #    dVAR; dXSARGS;
  935. ##else
  936. #    dXSARGS;
  937. ##endif
  938. EOF
  939.  
  940.   #-Wall: if there is no $Full_func_name there are no xsubs in this .xs
  941.   #so `file' is unused
  942.   print Q(<<"EOF") if $Full_func_name;
  943. #    char* file = __FILE__;
  944. EOF
  945.  
  946.   print Q("#\n");
  947.  
  948.   print Q(<<"EOF");
  949. #    PERL_UNUSED_VAR(cv); /* -W */
  950. #    PERL_UNUSED_VAR(items); /* -W */
  951. EOF
  952.     
  953.   print Q(<<"EOF") if $WantVersionChk ;
  954. #    XS_VERSION_BOOTCHECK ;
  955. #
  956. EOF
  957.  
  958.   print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
  959. #    {
  960. #        CV * cv ;
  961. #
  962. EOF
  963.  
  964.   print Q(<<"EOF") if ($Overload);
  965. #    /* register the overloading (type 'A') magic */
  966. #    PL_amagic_generation++;
  967. #    /* The magic for overload gets a GV* via gv_fetchmeth as */
  968. #    /* mentioned above, and looks in the SV* slot of it for */
  969. #    /* the "fallback" status. */
  970. #    sv_setsv(
  971. #        get_sv( "${Package}::()", TRUE ),
  972. #        $Fallback
  973. #    );
  974. EOF
  975.  
  976.   print @InitFileCode;
  977.  
  978.   print Q(<<"EOF") if defined $XsubAliases or defined $Interfaces ;
  979. #    }
  980. EOF
  981.  
  982.   if (@BootCode)
  983.   {
  984.     print "\n    /* Initialisation Section */\n\n" ;
  985.     @line = @BootCode;
  986.     print_section();
  987.     print "\n    /* End of Initialisation Section */\n\n" ;
  988.   }
  989.  
  990.   if ($] >= 5.009) {
  991.     print <<'EOF';
  992.     if (PL_unitcheckav)
  993.          call_list(PL_scopestack_ix, PL_unitcheckav);
  994. EOF
  995.   }
  996.  
  997.   print Q(<<"EOF");
  998. #    XSRETURN_YES;
  999. #]]
  1000. #
  1001. EOF
  1002.  
  1003.   warn("Please specify prototyping behavior for $filename (see perlxs manual)\n")
  1004.     unless $ProtoUsed ;
  1005.  
  1006.   chdir($orig_cwd);
  1007.   select($orig_fh);
  1008.   untie *PSEUDO_STDOUT if tied *PSEUDO_STDOUT;
  1009.   close $FH;
  1010.  
  1011.   return 1;
  1012. }
  1013.  
  1014. sub errors { $errors }
  1015.  
  1016. sub standard_typemap_locations {
  1017.   # Add all the default typemap locations to the search path
  1018.   my @tm = qw(typemap);
  1019.   
  1020.   my $updir = File::Spec->updir;
  1021.   foreach my $dir (File::Spec->catdir(($updir) x 1), File::Spec->catdir(($updir) x 2),
  1022.            File::Spec->catdir(($updir) x 3), File::Spec->catdir(($updir) x 4)) {
  1023.     
  1024.     unshift @tm, File::Spec->catfile($dir, 'typemap');
  1025.     unshift @tm, File::Spec->catfile($dir, lib => ExtUtils => 'typemap');
  1026.   }
  1027.   foreach my $dir (@INC) {
  1028.     my $file = File::Spec->catfile($dir, ExtUtils => 'typemap');
  1029.     unshift @tm, $file if -e $file;
  1030.   }
  1031.   return @tm;
  1032. }
  1033.   
  1034. sub TrimWhitespace
  1035. {
  1036.   $_[0] =~ s/^\s+|\s+$//go ;
  1037. }
  1038.  
  1039. sub TidyType
  1040.   {
  1041.     local ($_) = @_ ;
  1042.  
  1043.     # rationalise any '*' by joining them into bunches and removing whitespace
  1044.     s#\s*(\*+)\s*#$1#g;
  1045.     s#(\*+)# $1 #g ;
  1046.  
  1047.     # change multiple whitespace into a single space
  1048.     s/\s+/ /g ;
  1049.  
  1050.     # trim leading & trailing whitespace
  1051.     TrimWhitespace($_) ;
  1052.  
  1053.     $_ ;
  1054. }
  1055.  
  1056. # Input:  ($_, @line) == unparsed input.
  1057. # Output: ($_, @line) == (rest of line, following lines).
  1058. # Return: the matched keyword if found, otherwise 0
  1059. sub check_keyword {
  1060.     $_ = shift(@line) while !/\S/ && @line;
  1061.     s/^(\s*)($_[0])\s*:\s*(?:#.*)?/$1/s && $2;
  1062. }
  1063.  
  1064. sub print_section {
  1065.     # the "do" is required for right semantics
  1066.     do { $_ = shift(@line) } while !/\S/ && @line;
  1067.  
  1068.     print("#line ", $line_no[@line_no - @line -1], " \"$filepathname\"\n")
  1069.     if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
  1070.     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1071.     print "$_\n";
  1072.     }
  1073.     print 'ExtUtils::ParseXS::CountLines'->end_marker, "\n" if $WantLineNumbers;
  1074. }
  1075.  
  1076. sub merge_section {
  1077.     my $in = '';
  1078.  
  1079.     while (!/\S/ && @line) {
  1080.       $_ = shift(@line);
  1081.     }
  1082.  
  1083.     for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1084.       $in .= "$_\n";
  1085.     }
  1086.     chomp $in;
  1087.     return $in;
  1088.   }
  1089.  
  1090. sub process_keyword($)
  1091.   {
  1092.     my($pattern) = @_ ;
  1093.     my $kwd ;
  1094.  
  1095.     &{"${kwd}_handler"}()
  1096.       while $kwd = check_keyword($pattern) ;
  1097.   }
  1098.  
  1099. sub CASE_handler {
  1100.   blurt ("Error: `CASE:' after unconditional `CASE:'")
  1101.     if $condnum && $cond eq '';
  1102.   $cond = $_;
  1103.   TrimWhitespace($cond);
  1104.   print "   ", ($condnum++ ? " else" : ""), ($cond ? " if ($cond)\n" : "\n");
  1105.   $_ = '' ;
  1106. }
  1107.  
  1108. sub INPUT_handler {
  1109.   for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1110.     last if /^\s*NOT_IMPLEMENTED_YET/;
  1111.     next unless /\S/;        # skip blank lines
  1112.  
  1113.     TrimWhitespace($_) ;
  1114.     my $line = $_ ;
  1115.  
  1116.     # remove trailing semicolon if no initialisation
  1117.     s/\s*;$//g unless /[=;+].*\S/ ;
  1118.  
  1119.     # Process the length(foo) declarations
  1120.     if (s/^([^=]*)\blength\(\s*(\w+)\s*\)\s*$/$1 XSauto_length_of_$2=NO_INIT/x) {
  1121.       print "\tSTRLEN\tSTRLEN_length_of_$2;\n";
  1122.       $lengthof{$2} = $name;
  1123.       # $islengthof{$name} = $1;
  1124.       $deferred .= "\n\tXSauto_length_of_$2 = STRLEN_length_of_$2;";
  1125.     }
  1126.  
  1127.     # check for optional initialisation code
  1128.     my $var_init = '' ;
  1129.     $var_init = $1 if s/\s*([=;+].*)$//s ;
  1130.     $var_init =~ s/"/\\"/g;
  1131.  
  1132.     s/\s+/ /g;
  1133.     my ($var_type, $var_addr, $var_name) = /^(.*?[^&\s])\s*(\&?)\s*\b(\w+)$/s
  1134.       or blurt("Error: invalid argument declaration '$line'"), next;
  1135.  
  1136.     # Check for duplicate definitions
  1137.     blurt ("Error: duplicate definition of argument '$var_name' ignored"), next
  1138.       if $arg_list{$var_name}++
  1139.     or defined $argtype_seen{$var_name} and not $processing_arg_with_types;
  1140.  
  1141.     $thisdone |= $var_name eq "THIS";
  1142.     $retvaldone |= $var_name eq "RETVAL";
  1143.     $var_types{$var_name} = $var_type;
  1144.     # XXXX This check is a safeguard against the unfinished conversion of
  1145.     # generate_init().  When generate_init() is fixed,
  1146.     # one can use 2-args map_type() unconditionally.
  1147.     if ($var_type =~ / \( \s* \* \s* \) /x) {
  1148.       # Function pointers are not yet supported with &output_init!
  1149.       print "\t" . &map_type($var_type, $var_name);
  1150.       $name_printed = 1;
  1151.     } else {
  1152.       print "\t" . &map_type($var_type);
  1153.       $name_printed = 0;
  1154.     }
  1155.     $var_num = $args_match{$var_name};
  1156.  
  1157.     $proto_arg[$var_num] = ProtoString($var_type)
  1158.       if $var_num ;
  1159.     $func_args =~ s/\b($var_name)\b/&$1/ if $var_addr;
  1160.     if ($var_init =~ /^[=;]\s*NO_INIT\s*;?\s*$/
  1161.     or $in_out{$var_name} and $in_out{$var_name} =~ /^OUT/
  1162.     and $var_init !~ /\S/) {
  1163.       if ($name_printed) {
  1164.     print ";\n";
  1165.       } else {
  1166.     print "\t$var_name;\n";
  1167.       }
  1168.     } elsif ($var_init =~ /\S/) {
  1169.       &output_init($var_type, $var_num, $var_name, $var_init, $name_printed);
  1170.     } elsif ($var_num) {
  1171.       # generate initialization code
  1172.       &generate_init($var_type, $var_num, $var_name, $name_printed);
  1173.     } else {
  1174.       print ";\n";
  1175.     }
  1176.   }
  1177. }
  1178.  
  1179. sub OUTPUT_handler {
  1180.   for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1181.     next unless /\S/;
  1182.     if (/^\s*SETMAGIC\s*:\s*(ENABLE|DISABLE)\s*/) {
  1183.       $DoSetMagic = ($1 eq "ENABLE" ? 1 : 0);
  1184.       next;
  1185.     }
  1186.     my ($outarg, $outcode) = /^\s*(\S+)\s*(.*?)\s*$/s ;
  1187.     blurt ("Error: duplicate OUTPUT argument '$outarg' ignored"), next
  1188.       if $outargs{$outarg} ++ ;
  1189.     if (!$gotRETVAL and $outarg eq 'RETVAL') {
  1190.       # deal with RETVAL last
  1191.       $RETVAL_code = $outcode ;
  1192.       $gotRETVAL = 1 ;
  1193.       next ;
  1194.     }
  1195.     blurt ("Error: OUTPUT $outarg not an argument"), next
  1196.       unless defined($args_match{$outarg});
  1197.     blurt("Error: No input definition for OUTPUT argument '$outarg' - ignored"), next
  1198.       unless defined $var_types{$outarg} ;
  1199.     $var_num = $args_match{$outarg};
  1200.     if ($outcode) {
  1201.       print "\t$outcode\n";
  1202.       print "\tSvSETMAGIC(ST(" , $var_num-1 , "));\n" if $DoSetMagic;
  1203.     } else {
  1204.       &generate_output($var_types{$outarg}, $var_num, $outarg, $DoSetMagic);
  1205.     }
  1206.     delete $in_out{$outarg}     # No need to auto-OUTPUT
  1207.       if exists $in_out{$outarg} and $in_out{$outarg} =~ /OUT$/;
  1208.   }
  1209. }
  1210.  
  1211. sub C_ARGS_handler() {
  1212.   my $in = merge_section();
  1213.  
  1214.   TrimWhitespace($in);
  1215.   $func_args = $in;
  1216. }
  1217.  
  1218. sub INTERFACE_MACRO_handler() {
  1219.   my $in = merge_section();
  1220.  
  1221.   TrimWhitespace($in);
  1222.   if ($in =~ /\s/) {        # two
  1223.     ($interface_macro, $interface_macro_set) = split ' ', $in;
  1224.   } else {
  1225.     $interface_macro = $in;
  1226.     $interface_macro_set = 'UNKNOWN_CVT'; # catch later
  1227.   }
  1228.   $interface = 1;        # local
  1229.   $Interfaces = 1;        # global
  1230. }
  1231.  
  1232. sub INTERFACE_handler() {
  1233.   my $in = merge_section();
  1234.  
  1235.   TrimWhitespace($in);
  1236.  
  1237.   foreach (split /[\s,]+/, $in) {
  1238.     my $name = $_;
  1239.     $name =~ s/^$Prefix//;
  1240.     $Interfaces{$name} = $_;
  1241.   }
  1242.   print Q(<<"EOF");
  1243. #    XSFUNCTION = $interface_macro($ret_type,cv,XSANY.any_dptr);
  1244. EOF
  1245.   $interface = 1;        # local
  1246.   $Interfaces = 1;        # global
  1247. }
  1248.  
  1249. sub CLEANUP_handler() { print_section() }
  1250. sub PREINIT_handler() { print_section() }
  1251. sub POSTCALL_handler() { print_section() }
  1252. sub INIT_handler()    { print_section() }
  1253.  
  1254. sub GetAliases
  1255.   {
  1256.     my ($line) = @_ ;
  1257.     my ($orig) = $line ;
  1258.     my ($alias) ;
  1259.     my ($value) ;
  1260.  
  1261.     # Parse alias definitions
  1262.     # format is
  1263.     #    alias = value alias = value ...
  1264.  
  1265.     while ($line =~ s/^\s*([\w:]+)\s*=\s*(\w+)\s*//) {
  1266.       $alias = $1 ;
  1267.       $orig_alias = $alias ;
  1268.       $value = $2 ;
  1269.  
  1270.       # check for optional package definition in the alias
  1271.       $alias = $Packprefix . $alias if $alias !~ /::/ ;
  1272.  
  1273.       # check for duplicate alias name & duplicate value
  1274.       Warn("Warning: Ignoring duplicate alias '$orig_alias'")
  1275.     if defined $XsubAliases{$alias} ;
  1276.  
  1277.       Warn("Warning: Aliases '$orig_alias' and '$XsubAliasValues{$value}' have identical values")
  1278.     if $XsubAliasValues{$value} ;
  1279.  
  1280.       $XsubAliases = 1;
  1281.       $XsubAliases{$alias} = $value ;
  1282.       $XsubAliasValues{$value} = $orig_alias ;
  1283.     }
  1284.  
  1285.     blurt("Error: Cannot parse ALIAS definitions from '$orig'")
  1286.       if $line ;
  1287.   }
  1288.  
  1289. sub ATTRS_handler ()
  1290.   {
  1291.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1292.       next unless /\S/;
  1293.       TrimWhitespace($_) ;
  1294.       push @Attributes, $_;
  1295.     }
  1296.   }
  1297.  
  1298. sub ALIAS_handler ()
  1299.   {
  1300.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1301.       next unless /\S/;
  1302.       TrimWhitespace($_) ;
  1303.       GetAliases($_) if $_ ;
  1304.     }
  1305.   }
  1306.  
  1307. sub OVERLOAD_handler()
  1308. {
  1309.   for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1310.     next unless /\S/;
  1311.     TrimWhitespace($_) ;
  1312.     while ( s/^\s*([\w:"\\)\+\-\*\/\%\<\>\.\&\|\^\!\~\{\}\=]+)\s*//) {
  1313.       $Overload = 1 unless $Overload;
  1314.       my $overload = "$Package\::(".$1 ;
  1315.       push(@InitFileCode,
  1316.        "        newXS(\"$overload\", XS_$Full_func_name, file$proto);\n");
  1317.     }
  1318.   }  
  1319. }
  1320.  
  1321. sub FALLBACK_handler()
  1322. {
  1323.   # the rest of the current line should contain either TRUE, 
  1324.   # FALSE or UNDEF
  1325.   
  1326.   TrimWhitespace($_) ;
  1327.   my %map = (
  1328.          TRUE => "PL_sv_yes", 1 => "PL_sv_yes",
  1329.          FALSE => "PL_sv_no", 0 => "PL_sv_no",
  1330.          UNDEF => "PL_sv_undef",
  1331.         ) ;
  1332.   
  1333.   # check for valid FALLBACK value
  1334.   death ("Error: FALLBACK: TRUE/FALSE/UNDEF") unless exists $map{uc $_} ;
  1335.   
  1336.   $Fallback = $map{uc $_} ;
  1337. }
  1338.  
  1339.  
  1340. sub REQUIRE_handler ()
  1341.   {
  1342.     # the rest of the current line should contain a version number
  1343.     my ($Ver) = $_ ;
  1344.  
  1345.     TrimWhitespace($Ver) ;
  1346.  
  1347.     death ("Error: REQUIRE expects a version number")
  1348.       unless $Ver ;
  1349.  
  1350.     # check that the version number is of the form n.n
  1351.     death ("Error: REQUIRE: expected a number, got '$Ver'")
  1352.       unless $Ver =~ /^\d+(\.\d*)?/ ;
  1353.  
  1354.     death ("Error: xsubpp $Ver (or better) required--this is only $VERSION.")
  1355.       unless $VERSION >= $Ver ;
  1356.   }
  1357.  
  1358. sub VERSIONCHECK_handler ()
  1359.   {
  1360.     # the rest of the current line should contain either ENABLE or
  1361.     # DISABLE
  1362.  
  1363.     TrimWhitespace($_) ;
  1364.  
  1365.     # check for ENABLE/DISABLE
  1366.     death ("Error: VERSIONCHECK: ENABLE/DISABLE")
  1367.       unless /^(ENABLE|DISABLE)/i ;
  1368.  
  1369.     $WantVersionChk = 1 if $1 eq 'ENABLE' ;
  1370.     $WantVersionChk = 0 if $1 eq 'DISABLE' ;
  1371.  
  1372.   }
  1373.  
  1374. sub PROTOTYPE_handler ()
  1375.   {
  1376.     my $specified ;
  1377.  
  1378.     death("Error: Only 1 PROTOTYPE definition allowed per xsub")
  1379.       if $proto_in_this_xsub ++ ;
  1380.  
  1381.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1382.       next unless /\S/;
  1383.       $specified = 1 ;
  1384.       TrimWhitespace($_) ;
  1385.       if ($_ eq 'DISABLE') {
  1386.     $ProtoThisXSUB = 0
  1387.       } elsif ($_ eq 'ENABLE') {
  1388.     $ProtoThisXSUB = 1
  1389.       } else {
  1390.     # remove any whitespace
  1391.     s/\s+//g ;
  1392.     death("Error: Invalid prototype '$_'")
  1393.       unless ValidProtoString($_) ;
  1394.     $ProtoThisXSUB = C_string($_) ;
  1395.       }
  1396.     }
  1397.  
  1398.     # If no prototype specified, then assume empty prototype ""
  1399.     $ProtoThisXSUB = 2 unless $specified ;
  1400.  
  1401.     $ProtoUsed = 1 ;
  1402.  
  1403.   }
  1404.  
  1405. sub SCOPE_handler ()
  1406.   {
  1407.     death("Error: Only 1 SCOPE declaration allowed per xsub")
  1408.       if $scope_in_this_xsub ++ ;
  1409.  
  1410.     for (;  !/^$BLOCK_re/o;  $_ = shift(@line)) {
  1411.       next unless /\S/;
  1412.       TrimWhitespace($_) ;
  1413.       if ($_ =~ /^DISABLE/i) {
  1414.     $ScopeThisXSUB = 0
  1415.       } elsif ($_ =~ /^ENABLE/i) {
  1416.     $ScopeThisXSUB = 1
  1417.       }
  1418.     }
  1419.  
  1420.   }
  1421.  
  1422. sub PROTOTYPES_handler ()
  1423.   {
  1424.     # the rest of the current line should contain either ENABLE or
  1425.     # DISABLE
  1426.  
  1427.     TrimWhitespace($_) ;
  1428.  
  1429.     # check for ENABLE/DISABLE
  1430.     death ("Error: PROTOTYPES: ENABLE/DISABLE")
  1431.       unless /^(ENABLE|DISABLE)/i ;
  1432.  
  1433.     $WantPrototypes = 1 if $1 eq 'ENABLE' ;
  1434.     $WantPrototypes = 0 if $1 eq 'DISABLE' ;
  1435.     $ProtoUsed = 1 ;
  1436.  
  1437.   }
  1438.  
  1439. sub INCLUDE_handler ()
  1440.   {
  1441.     # the rest of the current line should contain a valid filename
  1442.  
  1443.     TrimWhitespace($_) ;
  1444.  
  1445.     death("INCLUDE: filename missing")
  1446.       unless $_ ;
  1447.  
  1448.     death("INCLUDE: output pipe is illegal")
  1449.       if /^\s*\|/ ;
  1450.  
  1451.     # simple minded recursion detector
  1452.     death("INCLUDE loop detected")
  1453.       if $IncludedFiles{$_} ;
  1454.  
  1455.     ++ $IncludedFiles{$_} unless /\|\s*$/ ;
  1456.  
  1457.     # Save the current file context.
  1458.     push(@XSStack, {
  1459.             type        => 'file',
  1460.             LastLine        => $lastline,
  1461.             LastLineNo      => $lastline_no,
  1462.             Line            => \@line,
  1463.             LineNo          => \@line_no,
  1464.             Filename        => $filename,
  1465.             Filepathname    => $filepathname,
  1466.             Handle          => $FH,
  1467.            }) ;
  1468.  
  1469.     $FH = Symbol::gensym();
  1470.  
  1471.     # open the new file
  1472.     open ($FH, "$_") or death("Cannot open '$_': $!") ;
  1473.  
  1474.     print Q(<<"EOF");
  1475. #
  1476. #/* INCLUDE:  Including '$_' from '$filename' */
  1477. #
  1478. EOF
  1479.  
  1480.     $filepathname = $filename = $_ ;
  1481.  
  1482.     # Prime the pump by reading the first
  1483.     # non-blank line
  1484.  
  1485.     # skip leading blank lines
  1486.     while (<$FH>) {
  1487.       last unless /^\s*$/ ;
  1488.     }
  1489.  
  1490.     $lastline = $_ ;
  1491.     $lastline_no = $. ;
  1492.  
  1493.   }
  1494.  
  1495. sub PopFile()
  1496.   {
  1497.     return 0 unless $XSStack[-1]{type} eq 'file' ;
  1498.  
  1499.     my $data     = pop @XSStack ;
  1500.     my $ThisFile = $filename ;
  1501.     my $isPipe   = ($filename =~ /\|\s*$/) ;
  1502.  
  1503.     -- $IncludedFiles{$filename}
  1504.       unless $isPipe ;
  1505.  
  1506.     close $FH ;
  1507.  
  1508.     $FH         = $data->{Handle} ;
  1509.     # $filename is the leafname, which for some reason isused for diagnostic
  1510.     # messages, whereas $filepathname is the full pathname, and is used for
  1511.     # #line directives.
  1512.     $filename   = $data->{Filename} ;
  1513.     $filepathname = $data->{Filepathname} ;
  1514.     $lastline   = $data->{LastLine} ;
  1515.     $lastline_no = $data->{LastLineNo} ;
  1516.     @line       = @{ $data->{Line} } ;
  1517.     @line_no    = @{ $data->{LineNo} } ;
  1518.  
  1519.     if ($isPipe and $? ) {
  1520.       -- $lastline_no ;
  1521.       print STDERR "Error reading from pipe '$ThisFile': $! in $filename, line $lastline_no\n"  ;
  1522.       exit 1 ;
  1523.     }
  1524.  
  1525.     print Q(<<"EOF");
  1526. #
  1527. #/* INCLUDE: Returning to '$filename' from '$ThisFile' */
  1528. #
  1529. EOF
  1530.  
  1531.     return 1 ;
  1532.   }
  1533.  
  1534. sub ValidProtoString ($)
  1535.   {
  1536.     my($string) = @_ ;
  1537.  
  1538.     if ( $string =~ /^$proto_re+$/ ) {
  1539.       return $string ;
  1540.     }
  1541.  
  1542.     return 0 ;
  1543.   }
  1544.  
  1545. sub C_string ($)
  1546.   {
  1547.     my($string) = @_ ;
  1548.  
  1549.     $string =~ s[\\][\\\\]g ;
  1550.     $string ;
  1551.   }
  1552.  
  1553. sub ProtoString ($)
  1554.   {
  1555.     my ($type) = @_ ;
  1556.  
  1557.     $proto_letter{$type} or "\$" ;
  1558.   }
  1559.  
  1560. sub check_cpp {
  1561.   my @cpp = grep(/^\#\s*(?:if|e\w+)/, @line);
  1562.   if (@cpp) {
  1563.     my ($cpp, $cpplevel);
  1564.     for $cpp (@cpp) {
  1565.       if ($cpp =~ /^\#\s*if/) {
  1566.     $cpplevel++;
  1567.       } elsif (!$cpplevel) {
  1568.     Warn("Warning: #else/elif/endif without #if in this function");
  1569.     print STDERR "    (precede it with a blank line if the matching #if is outside the function)\n"
  1570.       if $XSStack[-1]{type} eq 'if';
  1571.     return;
  1572.       } elsif ($cpp =~ /^\#\s*endif/) {
  1573.     $cpplevel--;
  1574.       }
  1575.     }
  1576.     Warn("Warning: #if without #endif in this function") if $cpplevel;
  1577.   }
  1578. }
  1579.  
  1580.  
  1581. sub Q {
  1582.   my($text) = @_;
  1583.   $text =~ s/^#//gm;
  1584.   $text =~ s/\[\[/{/g;
  1585.   $text =~ s/\]\]/}/g;
  1586.   $text;
  1587. }
  1588.  
  1589. # Read next xsub into @line from ($lastline, <$FH>).
  1590. sub fetch_para {
  1591.   # parse paragraph
  1592.   death ("Error: Unterminated `#if/#ifdef/#ifndef'")
  1593.     if !defined $lastline && $XSStack[-1]{type} eq 'if';
  1594.   @line = ();
  1595.   @line_no = () ;
  1596.   return PopFile() if !defined $lastline;
  1597.  
  1598.   if ($lastline =~
  1599.       /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  1600.     $Module = $1;
  1601.     $Package = defined($2) ? $2 : ''; # keep -w happy
  1602.     $Prefix  = defined($3) ? $3 : ''; # keep -w happy
  1603.     $Prefix = quotemeta $Prefix ;
  1604.     ($Module_cname = $Module) =~ s/\W/_/g;
  1605.     ($Packid = $Package) =~ tr/:/_/;
  1606.     $Packprefix = $Package;
  1607.     $Packprefix .= "::" if $Packprefix ne "";
  1608.     $lastline = "";
  1609.   }
  1610.  
  1611.   for (;;) {
  1612.     # Skip embedded PODs
  1613.     while ($lastline =~ /^=/) {
  1614.       while ($lastline = <$FH>) {
  1615.     last if ($lastline =~ /^=cut\s*$/);
  1616.       }
  1617.       death ("Error: Unterminated pod") unless $lastline;
  1618.       $lastline = <$FH>;
  1619.       chomp $lastline;
  1620.       $lastline =~ s/^\s+$//;
  1621.     }
  1622.     if ($lastline !~ /^\s*#/ ||
  1623.     # CPP directives:
  1624.     #    ANSI:    if ifdef ifndef elif else endif define undef
  1625.     #        line error pragma
  1626.     #    gcc:    warning include_next
  1627.     #   obj-c:    import
  1628.     #   others:    ident (gcc notes that some cpps have this one)
  1629.     $lastline =~ /^#[ \t]*(?:(?:if|ifn?def|elif|else|endif|define|undef|pragma|error|warning|line\s+\d+|ident)\b|(?:include(?:_next)?|import)\s*["<].*[>"])/) {
  1630.       last if $lastline =~ /^\S/ && @line && $line[-1] eq "";
  1631.       push(@line, $lastline);
  1632.       push(@line_no, $lastline_no) ;
  1633.     }
  1634.  
  1635.     # Read next line and continuation lines
  1636.     last unless defined($lastline = <$FH>);
  1637.     $lastline_no = $.;
  1638.     my $tmp_line;
  1639.     $lastline .= $tmp_line
  1640.       while ($lastline =~ /\\$/ && defined($tmp_line = <$FH>));
  1641.  
  1642.     chomp $lastline;
  1643.     $lastline =~ s/^\s+$//;
  1644.   }
  1645.   pop(@line), pop(@line_no) while @line && $line[-1] eq "";
  1646.   1;
  1647. }
  1648.  
  1649. sub output_init {
  1650.   local($type, $num, $var, $init, $name_printed) = @_;
  1651.   local($arg) = "ST(" . ($num - 1) . ")";
  1652.  
  1653.   if (  $init =~ /^=/  ) {
  1654.     if ($name_printed) {
  1655.       eval qq/print " $init\\n"/;
  1656.     } else {
  1657.       eval qq/print "\\t$var $init\\n"/;
  1658.     }
  1659.     warn $@   if  $@;
  1660.   } else {
  1661.     if (  $init =~ s/^\+//  &&  $num  ) {
  1662.       &generate_init($type, $num, $var, $name_printed);
  1663.     } elsif ($name_printed) {
  1664.       print ";\n";
  1665.       $init =~ s/^;//;
  1666.     } else {
  1667.       eval qq/print "\\t$var;\\n"/;
  1668.       warn $@   if  $@;
  1669.       $init =~ s/^;//;
  1670.     }
  1671.     $deferred .= eval qq/"\\n\\t$init\\n"/;
  1672.     warn $@   if  $@;
  1673.   }
  1674. }
  1675.  
  1676. sub Warn
  1677.   {
  1678.     # work out the line number
  1679.     my $line_no = $line_no[@line_no - @line -1] ;
  1680.  
  1681.     print STDERR "@_ in $filename, line $line_no\n" ;
  1682.   }
  1683.  
  1684. sub blurt
  1685.   {
  1686.     Warn @_ ;
  1687.     $errors ++
  1688.   }
  1689.  
  1690. sub death
  1691.   {
  1692.     Warn @_ ;
  1693.     exit 1 ;
  1694.   }
  1695.  
  1696. sub generate_init {
  1697.   local($type, $num, $var) = @_;
  1698.   local($arg) = "ST(" . ($num - 1) . ")";
  1699.   local($argoff) = $num - 1;
  1700.   local($ntype);
  1701.   local($tk);
  1702.  
  1703.   $type = TidyType($type) ;
  1704.   blurt("Error: '$type' not in typemap"), return
  1705.     unless defined($type_kind{$type});
  1706.  
  1707.   ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1708.   ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1709.   $tk = $type_kind{$type};
  1710.   $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  1711.   if ($tk eq 'T_PV' and exists $lengthof{$var}) {
  1712.     print "\t$var" unless $name_printed;
  1713.     print " = ($type)SvPV($arg, STRLEN_length_of_$var);\n";
  1714.     die "default value not supported with length(NAME) supplied"
  1715.       if defined $defaults{$var};
  1716.     return;
  1717.   }
  1718.   $type =~ tr/:/_/ unless $hiertype;
  1719.   blurt("Error: No INPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
  1720.     unless defined $input_expr{$tk} ;
  1721.   $expr = $input_expr{$tk};
  1722.   if ($expr =~ /DO_ARRAY_ELEM/) {
  1723.     blurt("Error: '$subtype' not in typemap"), return
  1724.       unless defined($type_kind{$subtype});
  1725.     blurt("Error: No INPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
  1726.       unless defined $input_expr{$type_kind{$subtype}} ;
  1727.     $subexpr = $input_expr{$type_kind{$subtype}};
  1728.     $subexpr =~ s/\$type/\$subtype/g;
  1729.     $subexpr =~ s/ntype/subtype/g;
  1730.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1731.     $subexpr =~ s/\n\t/\n\t\t/g;
  1732.     $subexpr =~ s/is not of (.*\")/[arg %d] is not of $1, ix_$var + 1/g;
  1733.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  1734.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  1735.   }
  1736.   if ($expr =~ m#/\*.*scope.*\*/#i) {  # "scope" in C comments
  1737.     $ScopeThisXSUB = 1;
  1738.   }
  1739.   if (defined($defaults{$var})) {
  1740.     $expr =~ s/(\t+)/$1    /g;
  1741.     $expr =~ s/        /\t/g;
  1742.     if ($name_printed) {
  1743.       print ";\n";
  1744.     } else {
  1745.       eval qq/print "\\t$var;\\n"/;
  1746.       warn $@   if  $@;
  1747.     }
  1748.     if ($defaults{$var} eq 'NO_INIT') {
  1749.       $deferred .= eval qq/"\\n\\tif (items >= $num) {\\n$expr;\\n\\t}\\n"/;
  1750.     } else {
  1751.       $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  1752.     }
  1753.     warn $@   if  $@;
  1754.   } elsif ($ScopeThisXSUB or $expr !~ /^\s*\$var =/) {
  1755.     if ($name_printed) {
  1756.       print ";\n";
  1757.     } else {
  1758.       eval qq/print "\\t$var;\\n"/;
  1759.       warn $@   if  $@;
  1760.     }
  1761.     $deferred .= eval qq/"\\n$expr;\\n"/;
  1762.     warn $@   if  $@;
  1763.   } else {
  1764.     die "panic: do not know how to handle this branch for function pointers"
  1765.       if $name_printed;
  1766.     eval qq/print "$expr;\\n"/;
  1767.     warn $@   if  $@;
  1768.   }
  1769. }
  1770.  
  1771. sub generate_output {
  1772.   local($type, $num, $var, $do_setmagic, $do_push) = @_;
  1773.   local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  1774.   local($argoff) = $num - 1;
  1775.   local($ntype);
  1776.  
  1777.   $type = TidyType($type) ;
  1778.   if ($type =~ /^array\(([^,]*),(.*)\)/) {
  1779.     print "\t$arg = sv_newmortal();\n";
  1780.     print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
  1781.     print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
  1782.   } else {
  1783.     blurt("Error: '$type' not in typemap"), return
  1784.       unless defined($type_kind{$type});
  1785.     blurt("Error: No OUTPUT definition for type '$type', typekind '$type_kind{$type}' found"), return
  1786.       unless defined $output_expr{$type_kind{$type}} ;
  1787.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  1788.     $ntype =~ s/\(\)//g;
  1789.     ($subtype = $ntype) =~ s/(?:Array)?(?:Ptr)?$//;
  1790.     $expr = $output_expr{$type_kind{$type}};
  1791.     if ($expr =~ /DO_ARRAY_ELEM/) {
  1792.       blurt("Error: '$subtype' not in typemap"), return
  1793.     unless defined($type_kind{$subtype});
  1794.       blurt("Error: No OUTPUT definition for type '$subtype', typekind '$type_kind{$subtype}' found"), return
  1795.     unless defined $output_expr{$type_kind{$subtype}} ;
  1796.       $subexpr = $output_expr{$type_kind{$subtype}};
  1797.       $subexpr =~ s/ntype/subtype/g;
  1798.       $subexpr =~ s/\$arg/ST(ix_$var)/g;
  1799.       $subexpr =~ s/\$var/${var}[ix_$var]/g;
  1800.       $subexpr =~ s/\n\t/\n\t\t/g;
  1801.       $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  1802.       eval "print qq\a$expr\a";
  1803.       warn $@   if  $@;
  1804.       print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
  1805.     } elsif ($var eq 'RETVAL') {
  1806.       if ($expr =~ /^\t\$arg = new/) {
  1807.     # We expect that $arg has refcnt 1, so we need to
  1808.     # mortalize it.
  1809.     eval "print qq\a$expr\a";
  1810.     warn $@   if  $@;
  1811.     print "\tsv_2mortal(ST($num));\n";
  1812.     print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
  1813.       } elsif ($expr =~ /^\s*\$arg\s*=/) {
  1814.     # We expect that $arg has refcnt >=1, so we need
  1815.     # to mortalize it!
  1816.     eval "print qq\a$expr\a";
  1817.     warn $@   if  $@;
  1818.     print "\tsv_2mortal(ST(0));\n";
  1819.     print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
  1820.       } else {
  1821.     # Just hope that the entry would safely write it
  1822.     # over an already mortalized value. By
  1823.     # coincidence, something like $arg = &sv_undef
  1824.     # works too.
  1825.     print "\tST(0) = sv_newmortal();\n";
  1826.     eval "print qq\a$expr\a";
  1827.     warn $@   if  $@;
  1828.     # new mortals don't have set magic
  1829.       }
  1830.     } elsif ($do_push) {
  1831.       print "\tPUSHs(sv_newmortal());\n";
  1832.       $arg = "ST($num)";
  1833.       eval "print qq\a$expr\a";
  1834.       warn $@   if  $@;
  1835.       print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
  1836.     } elsif ($arg =~ /^ST\(\d+\)$/) {
  1837.       eval "print qq\a$expr\a";
  1838.       warn $@   if  $@;
  1839.       print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
  1840.     }
  1841.   }
  1842. }
  1843.  
  1844. sub map_type {
  1845.   my($type, $varname) = @_;
  1846.   
  1847.   # C++ has :: in types too so skip this
  1848.   $type =~ tr/:/_/ unless $hiertype;
  1849.   $type =~ s/^array\(([^,]*),(.*)\).*/$1 */s;
  1850.   if ($varname) {
  1851.     if ($varname && $type =~ / \( \s* \* (?= \s* \) ) /xg) {
  1852.       (substr $type, pos $type, 0) = " $varname ";
  1853.     } else {
  1854.       $type .= "\t$varname";
  1855.     }
  1856.   }
  1857.   $type;
  1858. }
  1859.  
  1860.  
  1861. #########################################################
  1862. package
  1863.   ExtUtils::ParseXS::CountLines;
  1864. use strict;
  1865. use vars qw($SECTION_END_MARKER);
  1866.  
  1867. sub TIEHANDLE {
  1868.   my ($class, $cfile, $fh) = @_;
  1869.   $cfile =~ s/\\/\\\\/g;
  1870.   $SECTION_END_MARKER = qq{#line --- "$cfile"};
  1871.   
  1872.   return bless {buffer => '',
  1873.         fh => $fh,
  1874.         line_no => 1,
  1875.            }, $class;
  1876. }
  1877.  
  1878. sub PRINT {
  1879.   my $self = shift;
  1880.   for (@_) {
  1881.     $self->{buffer} .= $_;
  1882.     while ($self->{buffer} =~ s/^([^\n]*\n)//) {
  1883.       my $line = $1;
  1884.       ++ $self->{line_no};
  1885.       $line =~ s|^\#line\s+---(?=\s)|#line $self->{line_no}|;
  1886.       print {$self->{fh}} $line;
  1887.     }
  1888.   }
  1889. }
  1890.  
  1891. sub PRINTF {
  1892.   my $self = shift;
  1893.   my $fmt = shift;
  1894.   $self->PRINT(sprintf($fmt, @_));
  1895. }
  1896.  
  1897. sub DESTROY {
  1898.   # Not necessary if we're careful to end with a "\n"
  1899.   my $self = shift;
  1900.   print {$self->{fh}} $self->{buffer};
  1901. }
  1902.  
  1903. sub UNTIE {
  1904.   # This sub does nothing, but is neccessary for references to be released.
  1905. }
  1906.  
  1907. sub end_marker {
  1908.   return $SECTION_END_MARKER;
  1909. }
  1910.  
  1911.  
  1912. 1;
  1913. __END__
  1914.  
  1915. =head1 NAME
  1916.  
  1917. ExtUtils::ParseXS - converts Perl XS code into C code
  1918.  
  1919. =head1 SYNOPSIS
  1920.  
  1921.   use ExtUtils::ParseXS qw(process_file);
  1922.   
  1923.   process_file( filename => 'foo.xs' );
  1924.  
  1925.   process_file( filename => 'foo.xs',
  1926.                 output => 'bar.c',
  1927.                 'C++' => 1,
  1928.                 typemap => 'path/to/typemap',
  1929.                 hiertype => 1,
  1930.                 except => 1,
  1931.                 prototypes => 1,
  1932.                 versioncheck => 1,
  1933.                 linenumbers => 1,
  1934.                 optimize => 1,
  1935.                 prototypes => 1,
  1936.               );
  1937. =head1 DESCRIPTION
  1938.  
  1939. C<ExtUtils::ParseXS> will compile XS code into C code by embedding the constructs
  1940. necessary to let C functions manipulate Perl values and creates the glue
  1941. necessary to let Perl access those functions.  The compiler uses typemaps to
  1942. determine how to map C function parameters and variables to Perl values.
  1943.  
  1944. The compiler will search for typemap files called I<typemap>.  It will use
  1945. the following search path to find default typemaps, with the rightmost
  1946. typemap taking precedence.
  1947.  
  1948.     ../../../typemap:../../typemap:../typemap:typemap
  1949.  
  1950. =head1 EXPORT
  1951.  
  1952. None by default.  C<process_file()> may be exported upon request.
  1953.  
  1954.  
  1955. =head1 FUNCTIONS
  1956.  
  1957. =over 4
  1958.  
  1959. =item process_xs()
  1960.  
  1961. This function processes an XS file and sends output to a C file.
  1962. Named parameters control how the processing is done.  The following
  1963. parameters are accepted:
  1964.  
  1965. =over 4
  1966.  
  1967. =item B<C++>
  1968.  
  1969. Adds C<extern "C"> to the C code.  Default is false.
  1970.  
  1971. =item B<hiertype>
  1972.  
  1973. Retains C<::> in type names so that C++ hierachical types can be
  1974. mapped.  Default is false.
  1975.  
  1976. =item B<except>
  1977.  
  1978. Adds exception handling stubs to the C code.  Default is false.
  1979.  
  1980. =item B<typemap>
  1981.  
  1982. Indicates that a user-supplied typemap should take precedence over the
  1983. default typemaps.  A single typemap may be specified as a string, or
  1984. multiple typemaps can be specified in an array reference, with the
  1985. last typemap having the highest precedence.
  1986.  
  1987. =item B<prototypes>
  1988.  
  1989. Generates prototype code for all xsubs.  Default is false.
  1990.  
  1991. =item B<versioncheck>
  1992.  
  1993. Makes sure at run time that the object file (derived from the C<.xs>
  1994. file) and the C<.pm> files have the same version number.  Default is
  1995. true.
  1996.  
  1997. =item B<linenumbers>
  1998.  
  1999. Adds C<#line> directives to the C output so error messages will look
  2000. like they came from the original XS file.  Default is true.
  2001.  
  2002. =item B<optimize>
  2003.  
  2004. Enables certain optimizations.  The only optimization that is currently
  2005. affected is the use of I<target>s by the output C code (see L<perlguts>).
  2006. Not optimizing may significantly slow down the generated code, but this is the way
  2007. B<xsubpp> of 5.005 and earlier operated.  Default is to optimize.
  2008.  
  2009. =item B<inout>
  2010.  
  2011. Enable recognition of C<IN>, C<OUT_LIST> and C<INOUT_LIST>
  2012. declarations.  Default is true.
  2013.  
  2014. =item B<argtypes>
  2015.  
  2016. Enable recognition of ANSI-like descriptions of function signature.
  2017. Default is true.
  2018.  
  2019. =item B<s>
  2020.  
  2021. I have no clue what this does.  Strips function prefixes?
  2022.  
  2023. =back
  2024.  
  2025. =item errors()
  2026.  
  2027. This function returns the number of [a certain kind of] errors
  2028. encountered during processing of the XS file.
  2029.  
  2030. =back
  2031.  
  2032. =head1 AUTHOR
  2033.  
  2034. Based on xsubpp code, written by Larry Wall.
  2035.  
  2036. Maintained by Ken Williams, <ken@mathforum.org>
  2037.  
  2038. =head1 COPYRIGHT
  2039.  
  2040. Copyright 2002-2003 Ken Williams.  All rights reserved.
  2041.  
  2042. This library is free software; you can redistribute it and/or
  2043. modify it under the same terms as Perl itself.
  2044.  
  2045. Based on the ExtUtils::xsubpp code by Larry Wall and the Perl 5
  2046. Porters, which was released under the same license terms.
  2047.  
  2048. =head1 SEE ALSO
  2049.  
  2050. L<perl>, ExtUtils::xsubpp, ExtUtils::MakeMaker, L<perlxs>, L<perlxstut>.
  2051.  
  2052. =cut
  2053.