lib/ExtUtils/xsubpp

   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;