home *** CD-ROM | disk | FTP | other *** search
/ The Datafile PD-CD 3 / PDCD_3.iso / languages / perl_5 / !Perl / Lib / ExtUtils / pm / xsubpp < prev   
Encoding:
Text File  |  1995-03-06  |  14.5 KB  |  630 lines
  1. #!./miniperl
  2.  
  3. =head1 NAME
  4.  
  5. xsubpp - compiler to convert Perl XS code into C code
  6.  
  7. =head1 SYNOPSIS
  8.  
  9. B<xsubpp> [B<-C++>] [B<-except>] [B<-typemap typemap>] file.xs
  10.  
  11. =head1 DESCRIPTION
  12.  
  13. I<xsubpp> will compile XS code into C code by embedding the constructs
  14. necessary to let C functions manipulate Perl values and creates the glue
  15. necessary to let Perl access those functions.  The compiler uses typemaps to
  16. determine how to map C function parameters and variables to Perl values.
  17.  
  18. The compiler will search for typemap files called I<typemap>.  It will use
  19. the following search path to find default typemaps, with the rightmost
  20. typemap taking precedence.
  21.  
  22.     ../../../typemap:../../typemap:../typemap:typemap
  23.  
  24. =head1 OPTIONS
  25.  
  26. =over 5
  27.  
  28. =item B<-C++>
  29.  
  30. Adds ``extern "C"'' to the C code.
  31.  
  32.  
  33. =item B<-except>
  34.  
  35. Adds exception handling stubs to the C code.
  36.  
  37. =item B<-typemap typemap>
  38.  
  39. Indicates that a user-supplied typemap should take precedence over the
  40. default typemaps.  This option may be used multiple times, with the last
  41. typemap having the highest precedence.
  42.  
  43. =back
  44.  
  45. =head1 ENVIRONMENT
  46.  
  47. No environment variables are used.
  48.  
  49. =head1 AUTHOR
  50.  
  51. Larry Wall
  52.  
  53. =head1 SEE ALSO
  54.  
  55. perl(1)
  56.  
  57. =cut
  58.  
  59. $usage = "Usage: xsubpp [-C++] [-except] [-typemap typemap] file.xs\n";
  60.  
  61. SWITCH: while ($ARGV[0] =~ s/^-//) {
  62.     $flag = shift @ARGV;
  63.     $spat = shift,    next SWITCH    if $flag eq 's';
  64.     $cplusplus = 1,    next SWITCH    if $flag eq 'C++';
  65.     $except = 1,    next SWITCH    if $flag eq 'except';
  66.     push(@tm,shift),    next SWITCH    if $flag eq 'typemap';
  67.     die $usage;
  68. }
  69. @ARGV == 1 or die $usage;
  70. chop($pwd = `pwd`);
  71. # Check for error message from VMS
  72. if ($pwd =~ /unrecognized command verb/) { $Is_VMS = 1; $pwd = $ENV{DEFAULT} }
  73. ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
  74.     or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
  75.     or ($dir, $filename) = ('.', $ARGV[0]);
  76. chdir($dir);
  77.  
  78. $typemap = shift @ARGV;
  79. foreach $typemap (@tm) {
  80.     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  81. }
  82. unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  83.                 ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  84.                 ../typemap typemap);
  85. foreach $typemap (@tm) {
  86.     open(TYPEMAP, $typemap) || next;
  87.     $mode = Typemap;
  88.     $current = \$junk;
  89.     while (<TYPEMAP>) {
  90.     next if /^#/;
  91.     if (/^INPUT\s*$/) { $mode = Input, next }
  92.     if (/^OUTPUT\s*$/) { $mode = Output, next }
  93.     if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
  94.     if ($mode eq Typemap) {
  95.         chop;
  96.         ($typename, $kind) = split(/\t+/, $_, 2);
  97.         $type_kind{$typename} = $kind if $kind ne '';
  98.     }
  99.     elsif ($mode eq Input) {
  100.         if (/^\s/) {
  101.         $$current .= $_;
  102.         }
  103.         else {
  104.         s/\s*$//;
  105.         $input_expr{$_} = '';
  106.         $current = \$input_expr{$_};
  107.         }
  108.     }
  109.     else {
  110.         if (/^\s/) {
  111.         $$current .= $_;
  112.         }
  113.         else {
  114.         s/\s*$//;
  115.         $output_expr{$_} = '';
  116.         $current = \$output_expr{$_};
  117.         }
  118.     }
  119.     }
  120.     close(TYPEMAP);
  121. }
  122.  
  123. foreach $key (keys %input_expr) {
  124.     $input_expr{$key} =~ s/\n+$//;
  125. }
  126.  
  127. sub Q {
  128.     local $text = shift;
  129.     $text =~ tr/#//d;
  130.     $text =~ s/\[\[/{/g;
  131.     $text =~ s/\]\]/}/g;
  132.     $text;
  133. }
  134.  
  135. open(F, $filename) || die "cannot open $filename\n";
  136.  
  137. while (<F>) {
  138.     last if ($Module, $foo, $Package, $foo1, $Prefix) =
  139.     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
  140.     print $_;
  141. }
  142. exit 0 if $_ eq "";
  143. $lastline = $_;
  144.  
  145. sub fetch_para {
  146.     # parse paragraph
  147.     @line = ();
  148.     if ($lastline ne "") {
  149.     if ($lastline =~
  150.     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
  151.         $Module = $1;
  152.         $foo = $2;
  153.         $Package = $3;
  154.         $foo1 = $4;
  155.         $Prefix = $5;
  156.         ($Module_cname = $Module) =~ s/\W/_/g;
  157.         ($Packid = $Package) =~ s/:/_/g;
  158.         $Packprefix = $Package;
  159.         $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
  160.         while (<F>) {
  161.         chop;
  162.         next if /^#/ &&
  163.             !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
  164.         last if /^\S/;
  165.         }
  166.         push(@line, $_) if $_ ne "";
  167.     }
  168.     else {
  169.         push(@line, $lastline);
  170.     }
  171.     $lastline = "";
  172.     while (<F>) {
  173.         next if /^#/ &&
  174.         !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
  175.         chop;
  176.         if (/^\S/ && @line && $line[-1] eq "") {
  177.         $lastline = $_;
  178.         last;
  179.         }
  180.         else {
  181.         push(@line, $_);
  182.         }
  183.     }
  184.     pop(@line) while @line && $line[-1] =~ /^\s*$/;
  185.     }
  186.     $PPCODE = grep(/PPCODE:/, @line);
  187.     scalar @line;
  188. }
  189.  
  190. while (&fetch_para) {
  191.     # initialize info arrays
  192.     undef(%args_match);
  193.     undef(%var_types);
  194.     undef(%var_addr);
  195.     undef(%defaults);
  196.     undef($class);
  197.     undef($static);
  198.     undef($elipsis);
  199.  
  200.     # extract return type, function name and arguments
  201.     $ret_type = shift(@line);
  202.     if ($ret_type =~ /^BOOT:/) {
  203.         push (@BootCode, @line, "", "") ;
  204.         next ;
  205.     }
  206.     if ($ret_type =~ /^static\s+(.*)$/) {
  207.         $static = 1;
  208.         $ret_type = $1;
  209.     }
  210.     $func_header = shift(@line);
  211.     ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
  212.     if ($func_name =~ /(.*)::(.*)/) {
  213.         $class = $1;
  214.         $func_name = $2;
  215.     }
  216.     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
  217.     push(@Func_name, "${Packid}_$func_name");
  218.     push(@Func_pname, $pname);
  219.     @args = split(/\s*,\s*/, $orig_args);
  220.     if (defined($class)) {
  221.     if (defined($static)) {
  222.         unshift(@args, "CLASS");
  223.         $orig_args = "CLASS, $orig_args";
  224.         $orig_args =~ s/^CLASS, $/CLASS/;
  225.     }
  226.     else {
  227.         unshift(@args, "THIS");
  228.         $orig_args = "THIS, $orig_args";
  229.         $orig_args =~ s/^THIS, $/THIS/;
  230.     }
  231.     }
  232.     $orig_args =~ s/"/\\"/g;
  233.     $min_args = $num_args = @args;
  234.     foreach $i (0..$num_args-1) {
  235.         if ($args[$i] =~ s/\.\.\.//) {
  236.             $elipsis = 1;
  237.             $min_args--;
  238.             if ($args[i] eq '' && $i == $num_args - 1) {
  239.             pop(@args);
  240.             last;
  241.             }
  242.         }
  243.         if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
  244.             $min_args--;
  245.             $args[$i] = $1;
  246.             $defaults{$args[$i]} = $2;
  247.             $defaults{$args[$i]} =~ s/"/\\"/g;
  248.         }
  249.     }
  250.     if (defined($class)) {
  251.         $func_args = join(", ", @args[1..$#args]);
  252.     } else {
  253.         $func_args = join(", ", @args);
  254.     }
  255.     @args_match{@args} = 1..@args;
  256.  
  257.     # print function header
  258.     print Q<<"EOF";
  259. #XS(XS_${Packid}_$func_name)
  260. #[[
  261. #    dXSARGS;
  262. EOF
  263.     if ($elipsis) {
  264.     $cond = qq(items < $min_args);
  265.     }
  266.     elsif ($min_args == $num_args) {
  267.     $cond = qq(items != $min_args);
  268.     }
  269.     else {
  270.     $cond = qq(items < $min_args || items > $num_args);
  271.     }
  272.  
  273.     print Q<<"EOF" if $except;
  274. #    char errbuf[1024];
  275. #    *errbuf = '\0';
  276. EOF
  277.  
  278.     print Q<<"EOF";
  279. #    if ($cond) {
  280. #    croak("Usage: $pname($orig_args)");
  281. #    }
  282. EOF
  283.  
  284.     print Q<<"EOF" if $PPCODE;
  285. #    SP -= items;
  286. EOF
  287.  
  288.     # Now do a block of some sort.
  289.  
  290.     $condnum = 0;
  291.     if (!@line) {
  292.     @line = "CLEANUP:";
  293.     }
  294.     while (@line) {
  295.     if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
  296.         $cond = shift(@line);
  297.         if ($condnum == 0) {
  298.         print "    if ($cond)\n";
  299.         }
  300.         elsif ($cond ne '') {
  301.         print "    else if ($cond)\n";
  302.         }
  303.         else {
  304.         print "    else\n";
  305.         }
  306.         $condnum++;
  307.     }
  308.  
  309.     if ($except) {
  310.         print Q<<"EOF";
  311. #    TRY [[
  312. EOF
  313.     }
  314.     else {
  315.         print Q<<"EOF";
  316. #    [[
  317. EOF
  318.     }
  319.  
  320.     # do initialization of input variables
  321.     $thisdone = 0;
  322.     $retvaldone = 0;
  323.     $deferred = "";
  324.     while (@line) {
  325.         $_ = shift(@line);
  326.         last if /^\s*NOT_IMPLEMENTED_YET/;
  327.         last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
  328.         ($var_type, $var_name, $var_init) =
  329.             /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
  330.         # Catch common errors. More error checking required here.
  331.         blurt("Error: no tab in $pname argument declaration '$_'\n")
  332.             unless (m/\S+\s*\t\s*\S+/);
  333.         # catch C style argument declaration (this could be made alowable syntax)
  334.         warn("Warning: ignored semicolon in $pname argument declaration '$_'\n")
  335.             if ($var_name =~ s/;//g); # eg SV *<tab>name;
  336.         # catch many errors similar to: SV<tab>* name
  337.         blurt("Error: invalid $pname argument name '$var_name' (type '$var_type')\n")
  338.             unless ($var_name =~ m/^&?\w+$/);
  339.         if ($var_name =~ /^&/) {
  340.             $var_name =~ s/^&//;
  341.             $var_addr{$var_name} = 1;
  342.         }
  343.         $thisdone |= $var_name eq "THIS";
  344.         $retvaldone |= $var_name eq "RETVAL";
  345.         $var_types{$var_name} = $var_type;
  346.         print "\t" . &map_type($var_type);
  347.         $var_num = $args_match{$var_name};
  348.         if ($var_addr{$var_name}) {
  349.             $func_args =~ s/\b($var_name)\b/&\1/;
  350.         }
  351.         if ($var_init !~ /^=\s*NO_INIT\s*$/) {
  352.             if ($var_init !~ /^\s*$/) {
  353.                 &output_init($var_type, $var_num,
  354.                     "$var_name $var_init");
  355.             } elsif ($var_num) {
  356.                 # generate initialization code
  357.                 &generate_init($var_type, $var_num, $var_name);
  358.             } else {
  359.                 print ";\n";
  360.             }
  361.         } else {
  362.             print "\t$var_name;\n";
  363.         }
  364.     }
  365.     if (!$thisdone && defined($class)) {
  366.         if (defined($static)) {
  367.         print "\tchar *";
  368.         $var_types{"CLASS"} = "char *";
  369.         &generate_init("char *", 1, "CLASS");
  370.         }
  371.         else {
  372.         print "\t$class *";
  373.         $var_types{"THIS"} = "$class *";
  374.         &generate_init("$class *", 1, "THIS");
  375.         }
  376.     }
  377.  
  378.     # do code
  379.     if (/^\s*NOT_IMPLEMENTED_YET/) {
  380.         print "\ncroak(\"$pname: not implemented yet\");\n";
  381.     } else {
  382.         if ($ret_type ne "void") {
  383.             print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
  384.                 if !$retvaldone;
  385.             $args_match{"RETVAL"} = 0;
  386.             $var_types{"RETVAL"} = $ret_type;
  387.         }
  388.         if (/^\s*PPCODE:/) {
  389.             print $deferred;
  390.             while (@line) {
  391.                 $_ = shift(@line);
  392.                 die "PPCODE must be last thing"
  393.                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  394.                 print "$_\n";
  395.             }
  396.             print "\tPUTBACK;\n\treturn;\n";
  397.         } elsif (/^\s*CODE:/) {
  398.             print $deferred;
  399.             while (@line) {
  400.                 $_ = shift(@line);
  401.                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
  402.                 print "$_\n";
  403.             }
  404.         } elsif ($func_name eq "DESTROY") {
  405.             print $deferred;
  406.             print "\n\t";
  407.             print "delete THIS;\n"
  408.         } else {
  409.             print $deferred;
  410.             print "\n\t";
  411.             if ($ret_type ne "void") {
  412.                 print "RETVAL = ";
  413.             }
  414.             if (defined($static)) {
  415.                 if ($func_name =~ /^new/) {
  416.                 $func_name = "$class";
  417.                 }
  418.                 else {
  419.                 print "$class::";
  420.                 }
  421.             } elsif (defined($class)) {
  422.                 print "THIS->";
  423.             }
  424.             if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
  425.                 $func_name = $2;
  426.             }
  427.             print "$func_name($func_args);\n";
  428.             &generate_output($ret_type, 0, "RETVAL")
  429.                 unless $ret_type eq "void";
  430.         }
  431.     }
  432.  
  433.     # do output variables
  434.     if (/^\s*OUTPUT\s*:/) {
  435.         while (@line) {
  436.             $_ = shift(@line);
  437.             last if /^\s*CLEANUP\s*:/;
  438.             s/^\s+//;
  439.             ($outarg, $outcode) = split(/\t+/);
  440.             if ($outcode) {
  441.                 print "\t$outcode\n";
  442.             } else {
  443.                 die "$outarg not an argument"
  444.                     unless defined($args_match{$outarg});
  445.                 $var_num = $args_match{$outarg};
  446.                 &generate_output($var_types{$outarg}, $var_num,
  447.                     $outarg); 
  448.             }
  449.         }
  450.     }
  451.     # do cleanup
  452.     if (/^\s*CLEANUP\s*:/) {
  453.         while (@line) {
  454.             $_ = shift(@line);
  455.             last if /^\s*CASE\s*:/;
  456.             print "$_\n";
  457.         }
  458.     }
  459.     # print function trailer
  460.     if ($except) {
  461.         print Q<<EOF;
  462. #    ]]
  463. #    BEGHANDLERS
  464. #    CATCHALL
  465. #    sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
  466. #    ENDHANDLERS
  467. EOF
  468.     }
  469.     else {
  470.         print Q<<EOF;
  471. #    ]]
  472. EOF
  473.     }
  474.     if (/^\s*CASE\s*:/) {
  475.         unshift(@line, $_);
  476.     }
  477.     }
  478.  
  479.     print Q<<EOF if $except;
  480. #    if (errbuf[0])
  481. #    croak(errbuf);
  482. EOF
  483.  
  484.     print Q<<EOF unless $PPCODE;
  485. #    XSRETURN(1);
  486. EOF
  487.  
  488.     print Q<<EOF;
  489. #]]
  490. #
  491. EOF
  492. }
  493.  
  494. # print initialization routine
  495. print qq/extern "C"\n/ if $cplusplus;
  496. print Q<<"EOF";
  497. #XS(boot_$Module_cname)
  498. #[[
  499. #    dXSARGS;
  500. #    char* file = __FILE__;
  501. #
  502. EOF
  503.  
  504. for (@Func_name) {
  505.     $pname = shift(@Func_pname);
  506.     print "    newXS(\"$pname\", XS_$_, file);\n";
  507. }
  508.  
  509. if (@BootCode)
  510. {
  511.     print "\n    /* Initialisation Section */\n\n" ;
  512.     print grep (s/$/\n/, @BootCode) ;
  513.     print "    /* End of Initialisation Section */\n\n" ;
  514. }
  515.  
  516. print "    ST(0) = &sv_yes;\n";
  517. print "    XSRETURN(1);\n";
  518. print "}\n";
  519.  
  520. sub output_init {
  521.     local($type, $num, $init) = @_;
  522.     local($arg) = "ST(" . ($num - 1) . ")";
  523.  
  524.     eval qq/print " $init\\\n"/;
  525. }
  526.  
  527. sub blurt { warn @_; $errors++ }
  528.  
  529. sub generate_init {
  530.     local($type, $num, $var) = @_;
  531.     local($arg) = "ST(" . ($num - 1) . ")";
  532.     local($argoff) = $num - 1;
  533.     local($ntype);
  534.     local($tk);
  535.  
  536.     blurt("'$type' not in typemap"), return unless defined($type_kind{$type});
  537.     ($ntype = $type) =~ s/\s*\*/Ptr/g;
  538.     $subtype = $ntype;
  539.     $subtype =~ s/Ptr$//;
  540.     $subtype =~ s/Array$//;
  541.     $tk = $type_kind{$type};
  542.     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
  543.     $type =~ s/:/_/g;
  544.     $expr = $input_expr{$tk};
  545.     if ($expr =~ /DO_ARRAY_ELEM/) {
  546.     $subexpr = $input_expr{$type_kind{$subtype}};
  547.     $subexpr =~ s/ntype/subtype/g;
  548.     $subexpr =~ s/\$arg/ST(ix_$var)/g;
  549.     $subexpr =~ s/\n\t/\n\t\t/g;
  550.     $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
  551.     $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
  552.     $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
  553.     }
  554.     if (defined($defaults{$var})) {
  555.         $expr =~ s/(\t+)/$1    /g;
  556.         $expr =~ s/        /\t/g;
  557.         eval qq/print "\\t$var;\\n"/;
  558.         $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
  559.     } elsif ($expr !~ /^\t\$var =/) {
  560.         eval qq/print "\\t$var;\\n"/;
  561.         $deferred .= eval qq/"\\n$expr;\\n"/;
  562.     } else {
  563.         eval qq/print "$expr;\\n"/;
  564.     }
  565. }
  566.  
  567. sub generate_output {
  568.     local($type, $num, $var) = @_;
  569.     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
  570.     local($argoff) = $num - 1;
  571.     local($ntype);
  572.  
  573.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  574.         print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
  575.     } else {
  576.         blurt("'$type' not in typemap"), return
  577.         unless defined($type_kind{$type});
  578.         ($ntype = $type) =~ s/\s*\*/Ptr/g;
  579.         $ntype =~ s/\(\)//g;
  580.         $subtype = $ntype;
  581.         $subtype =~ s/Ptr$//;
  582.         $subtype =~ s/Array$//;
  583.         $expr = $output_expr{$type_kind{$type}};
  584.         if ($expr =~ /DO_ARRAY_ELEM/) {
  585.         $subexpr = $output_expr{$type_kind{$subtype}};
  586.         $subexpr =~ s/ntype/subtype/g;
  587.         $subexpr =~ s/\$arg/ST(ix_$var)/g;
  588.         $subexpr =~ s/\$var/${var}[ix_$var]/g;
  589.         $subexpr =~ s/\n\t/\n\t\t/g;
  590.         $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
  591.         eval "print qq\a$expr\a";
  592.         }
  593.         elsif ($var eq 'RETVAL') {
  594.         if ($expr =~ /^\t\$arg = /) {
  595.             eval "print qq\a$expr\a";
  596.             print "\tsv_2mortal(ST(0));\n";
  597.         }
  598.         else {
  599.             print "\tST(0) = sv_newmortal();\n";
  600.             eval "print qq\a$expr\a";
  601.         }
  602.         }
  603.         elsif ($arg =~ /^ST\(\d+\)$/) {
  604.         eval "print qq\a$expr\a";
  605.         }
  606.         elsif ($arg =~ /^ST\(\d+\)$/) {
  607.         eval "print qq\a$expr\a";
  608.         }
  609.         elsif ($arg =~ /^ST\(\d+\)$/) {
  610.         eval "print qq\a$expr\a";
  611.         }
  612.     }
  613. }
  614.  
  615. sub map_type {
  616.     local($type) = @_;
  617.  
  618.     $type =~ s/:/_/g;
  619.     if ($type =~ /^array\(([^,]*),(.*)\)/) {
  620.         return "$1 *";
  621.     } else {
  622.         return $type;
  623.     }
  624. }
  625.  
  626. # If this is VMS, the exit status has meaning to the shell, so we
  627. # use a predictable value (SS$_Abort) rather than an arbitrary
  628. # number.
  629. exit $Is_VMS ? 44 : $errors;
  630.