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