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 ($dir, $filename) = @ARGV[0] =~ m#(.*)/(.*)#
  72         or ($dir, $filename) = @ARGV[0] =~ m#(.*[>\]])(.*)#
  73         or ($dir, $filename) = ('.', $ARGV[0]);
  74 chdir($dir);
  75
  76 $typemap = shift @ARGV;
  77 foreach $typemap (@tm) {
  78     die "Can't find $typemap in $pwd\n" unless -r $typemap;
  79 }
  80 unshift @tm, qw(../../../typemap ../../typemap ../typemap typemap);
  81 foreach $typemap (@tm) {
  82     open(TYPEMAP, $typemap) || next;
  83     $mode = Typemap;
  84     $current = \$junk;
  85     while (<TYPEMAP>) {
  86         next if /^#/;
  87         if (/^INPUT\s*$/) { $mode = Input, next }
  88         if (/^OUTPUT\s*$/) { $mode = Output, next }
  89         if (/^TYPEMAP\s*$/) { $mode = Typemap, next }
  90         if ($mode eq Typemap) {
  91             chop;
  92             ($typename, $kind) = split(/\t+/, $_, 2);
  93             $type_kind{$typename} = $kind if $kind ne '';
  94         }
  95         elsif ($mode eq Input) {
  96             if (/^\s/) {
  97                 $$current .= $_;
  98             }
  99             else {
 100                 s/\s*$//;
 101                 $input_expr{$_} = '';
 102                 $current = \$input_expr{$_};
 103             }
 104         }
 105         else {
 106             if (/^\s/) {
 107                 $$current .= $_;
 108             }
 109             else {
 110                 s/\s*$//;
 111                 $output_expr{$_} = '';
 112                 $current = \$output_expr{$_};
 113             }
 114         }
 115     }
 116     close(TYPEMAP);
 117 }
 118
 119 foreach $key (keys %input_expr) {
 120     $input_expr{$key} =~ s/\n+$//;
 121 }
 122
 123 sub Q {
 124     local $text = shift;
 125     $text =~ tr/#//d;
 126     $text =~ s/\[\[/{/g;
 127     $text =~ s/\]\]/}/g;
 128     $text;
 129 }
 130
 131 open(F, $filename) || die "cannot open $filename\n";
 132
 133 while (<F>) {
 134     last if ($Module, $foo, $Package, $foo1, $Prefix) =
 135         /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/;
 136     print $_;
 137 }
 138 exit 0 if $_ eq "";
 139 $lastline = $_;
 140
 141 sub fetch_para {
 142     # parse paragraph
 143     @line = ();
 144     if ($lastline ne "") {
 145         if ($lastline =~
 146     /^MODULE\s*=\s*([\w:]+)(\s+PACKAGE\s*=\s*([\w:]+))?(\s+PREFIX\s*=\s*(\S+))?\s*$/) {
 147             $Module = $1;
 148             $foo = $2;
 149             $Package = $3;
 150             $foo1 = $4;
 151             $Prefix = $5;
 152             ($Module_cname = $Module) =~ s/\W/_/g;
 153             ($Packid = $Package) =~ s/:/_/g;
 154             $Packprefix = $Package;
 155             $Packprefix .= "::" if defined $Packprefix && $Packprefix ne "";
 156             while (<F>) {
 157                 chop;
 158                 next if /^#/ &&
 159                     !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
 160                 last if /^\S/;
 161             }
 162             push(@line, $_) if $_ ne "";
 163         }
 164         else {
 165             push(@line, $lastline);
 166         }
 167         $lastline = "";
 168         while (<F>) {
 169             next if /^#/ &&
 170                 !/^#[ \t]*(if|ifdef|ifndef|else|elif|endif|define|undef)\b/;
 171             chop;
 172             if (/^\S/ && @line && $line[-1] eq "") {
 173                 $lastline = $_;
 174                 last;
 175             }
 176             else {
 177                 push(@line, $_);
 178             }
 179         }
 180         pop(@line) while @line && $line[-1] =~ /^\s*$/;
 181     }
 182     $PPCODE = grep(/PPCODE:/, @line);
 183     scalar @line;
 184 }
 185
 186 while (&fetch_para) {
 187     # initialize info arrays
 188     undef(%args_match);
 189     undef(%var_types);
 190     undef(%var_addr);
 191     undef(%defaults);
 192     undef($class);
 193     undef($static);
 194     undef($elipsis);
 195
 196     # extract return type, function name and arguments
 197     $ret_type = shift(@line);
 198     if ($ret_type =~ /^BOOT:/) {
 199         push (@BootCode, @line, "", "") ;
 200         next ;
 201     }
 202     if ($ret_type =~ /^static\s+(.*)$/) {
 203             $static = 1;
 204             $ret_type = $1;
 205     }
 206     $func_header = shift(@line);
 207     ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
 208     if ($func_name =~ /(.*)::(.*)/) {
 209             $class = $1;
 210             $func_name = $2;
 211     }
 212     ($pname = $func_name) =~ s/^($Prefix)?/$Packprefix/;
 213     push(@Func_name, "${Packid}_$func_name");
 214     push(@Func_pname, $pname);
 215     @args = split(/\s*,\s*/, $orig_args);
 216     if (defined($class)) {
 217         if (defined($static)) {
 218             unshift(@args, "CLASS");
 219             $orig_args = "CLASS, $orig_args";
 220             $orig_args =~ s/^CLASS, $/CLASS/;
 221         }
 222         else {
 223             unshift(@args, "THIS");
 224             $orig_args = "THIS, $orig_args";
 225             $orig_args =~ s/^THIS, $/THIS/;
 226         }
 227     }
 228     $orig_args =~ s/"/\\"/g;
 229     $min_args = $num_args = @args;
 230     foreach $i (0..$num_args-1) {
 231             if ($args[$i] =~ s/\.\.\.//) {
 232                     $elipsis = 1;
 233                     $min_args--;
 234                     if ($args[i] eq '' && $i == $num_args - 1) {
 235                         pop(@args);
 236                         last;
 237                     }
 238             }
 239             if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
 240                     $min_args--;
 241                     $args[$i] = $1;
 242                     $defaults{$args[$i]} = $2;
 243                     $defaults{$args[$i]} =~ s/"/\\"/g;
 244             }
 245     }
 246     if (defined($class)) {
 247             $func_args = join(", ", @args[1..$#args]);
 248     } else {
 249             $func_args = join(", ", @args);
 250     }
 251     @args_match{@args} = 1..@args;
 252
 253     # print function header
 254     print Q<<"EOF";
 255 #XS(XS_${Packid}_$func_name)
 256 #[[
 257 #    dXSARGS;
 258 EOF
 259     if ($elipsis) {
 260         $cond = qq(items < $min_args);
 261     }
 262     elsif ($min_args == $num_args) {
 263         $cond = qq(items != $min_args);
 264     }
 265     else {
 266         $cond = qq(items < $min_args || items > $num_args);
 267     }
 268
 269     print Q<<"EOF" if $except;
 270 #    char errbuf[1024];
 271 #    *errbuf = '\0';
 272 EOF
 273
 274     print Q<<"EOF";
 275 #    if ($cond) {
 276 #       croak("Usage: $pname($orig_args)");
 277 #    }
 278 EOF
 279
 280     print Q<<"EOF" if $PPCODE;
 281 #    SP -= items;
 282 EOF
 283
 284     # Now do a block of some sort.
 285
 286     $condnum = 0;
 287     if (!@line) {
 288         @line = "CLEANUP:";
 289     }
 290     while (@line) {
 291         if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
 292             $cond = shift(@line);
 293             if ($condnum == 0) {
 294                 print "    if ($cond)\n";
 295             }
 296             elsif ($cond ne '') {
 297                 print "    else if ($cond)\n";
 298             }
 299             else {
 300                 print "    else\n";
 301             }
 302             $condnum++;
 303         }
 304
 305         if ($except) {
 306             print Q<<"EOF";
 307 #    TRY [[
 308 EOF
 309         }
 310         else {
 311             print Q<<"EOF";
 312 #    [[
 313 EOF
 314         }
 315
 316         # do initialization of input variables
 317         $thisdone = 0;
 318         $retvaldone = 0;
 319         $deferred = "";
 320         while (@line) {
 321                 $_ = shift(@line);
 322                 last if /^\s*NOT_IMPLEMENTED_YET/;
 323                 last if /^\s*(PPCODE|CODE|OUTPUT|CLEANUP|CASE)\s*:/;
 324                 # Catch common error. Much more error checking required here.
 325                 blurt("Error: no tab in $pname argument declaration '$_'\n")
 326                         unless (m/\S+\s*\t\s*\S+/);
 327                 ($var_type, $var_name, $var_init) =
 328                     /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
 329                 if ($var_name =~ /^&/) {
 330                         $var_name =~ s/^&//;
 331                         $var_addr{$var_name} = 1;
 332                 }
 333                 $thisdone |= $var_name eq "THIS";
 334                 $retvaldone |= $var_name eq "RETVAL";
 335                 $var_types{$var_name} = $var_type;
 336                 print "\t" . &map_type($var_type);
 337                 $var_num = $args_match{$var_name};
 338                 if ($var_addr{$var_name}) {
 339                         $func_args =~ s/\b($var_name)\b/&\1/;
 340                 }
 341                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
 342                         if ($var_init !~ /^\s*$/) {
 343                                 &output_init($var_type, $var_num,
 344                                     "$var_name $var_init");
 345                         } elsif ($var_num) {
 346                                 # generate initialization code
 347                                 &generate_init($var_type, $var_num, $var_name);
 348                         } else {
 349                                 print ";\n";
 350                         }
 351                 } else {
 352                         print "\t$var_name;\n";
 353                 }
 354         }
 355         if (!$thisdone && defined($class)) {
 356             if (defined($static)) {
 357                 print "\tchar *";
 358                 $var_types{"CLASS"} = "char *";
 359                 &generate_init("char *", 1, "CLASS");
 360             }
 361             else {
 362                 print "\t$class *";
 363                 $var_types{"THIS"} = "$class *";
 364                 &generate_init("$class *", 1, "THIS");
 365             }
 366         }
 367
 368         # do code
 369         if (/^\s*NOT_IMPLEMENTED_YET/) {
 370                 print "\ncroak(\"$pname: not implemented yet\");\n";
 371         } else {
 372                 if ($ret_type ne "void") {
 373                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
 374                                 if !$retvaldone;
 375                         $args_match{"RETVAL"} = 0;
 376                         $var_types{"RETVAL"} = $ret_type;
 377                 }
 378                 if (/^\s*PPCODE:/) {
 379                         print $deferred;
 380                         while (@line) {
 381                                 $_ = shift(@line);
 382                                 die "PPCODE must be last thing"
 383                                     if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 384                                 print "$_\n";
 385                         }
 386                         print "\tPUTBACK;\n\treturn;\n";
 387                 } elsif (/^\s*CODE:/) {
 388                         print $deferred;
 389                         while (@line) {
 390                                 $_ = shift(@line);
 391                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 392                                 print "$_\n";
 393                         }
 394                 } elsif ($func_name eq "DESTROY") {
 395                         print $deferred;
 396                         print "\n\t";
 397                         print "delete THIS;\n"
 398                 } else {
 399                         print $deferred;
 400                         print "\n\t";
 401                         if ($ret_type ne "void") {
 402                                 print "RETVAL = ";
 403                         }
 404                         if (defined($static)) {
 405                             if ($func_name =~ /^new/) {
 406                                 $func_name = "$class";
 407                             }
 408                             else {
 409                                 print "$class::";
 410                             }
 411                         } elsif (defined($class)) {
 412                                 print "THIS->";
 413                         }
 414                         if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
 415                                 $func_name = $2;
 416                         }
 417                         print "$func_name($func_args);\n";
 418                         &generate_output($ret_type, 0, "RETVAL")
 419                             unless $ret_type eq "void";
 420                 }
 421         }
 422
 423         # do output variables
 424         if (/^\s*OUTPUT\s*:/) {
 425                 while (@line) {
 426                         $_ = shift(@line);
 427                         last if /^\s*CLEANUP\s*:/;
 428                         s/^\s+//;
 429                         ($outarg, $outcode) = split(/\t+/);
 430                         if ($outcode) {
 431                             print "\t$outcode\n";
 432                         } else {
 433                                 die "$outarg not an argument"
 434                                     unless defined($args_match{$outarg});
 435                                 $var_num = $args_match{$outarg};
 436                                 &generate_output($var_types{$outarg}, $var_num,
 437                                     $outarg);
 438                         }
 439                 }
 440         }
 441         # do cleanup
 442         if (/^\s*CLEANUP\s*:/) {
 443             while (@line) {
 444                     $_ = shift(@line);
 445                     last if /^\s*CASE\s*:/;
 446                     print "$_\n";
 447             }
 448         }
 449         # print function trailer
 450         if ($except) {
 451             print Q<<EOF;
 452 #    ]]
 453 #    BEGHANDLERS
 454 #    CATCHALL
 455 #       sprintf(errbuf, "%s: %s\\tpropagated", Xname, Xreason);
 456 #    ENDHANDLERS
 457 EOF
 458         }
 459         else {
 460             print Q<<EOF;
 461 #    ]]
 462 EOF
 463         }
 464         if (/^\s*CASE\s*:/) {
 465             unshift(@line, $_);
 466         }
 467     }
 468
 469     print Q<<EOF if $except;
 470 #    if (errbuf[0])
 471 #       croak(errbuf);
 472 EOF
 473
 474     print Q<<EOF unless $PPCODE;
 475 #    XSRETURN(1);
 476 EOF
 477
 478     print Q<<EOF;
 479 #]]
 480 #
 481 EOF
 482 }
 483
 484 # print initialization routine
 485 print qq/extern "C"\n/ if $cplusplus;
 486 print Q<<"EOF";
 487 #XS(boot_$Module_cname)
 488 #[[
 489 #    dXSARGS;
 490 #    char* file = __FILE__;
 491 #
 492 EOF
 493
 494 for (@Func_name) {
 495     $pname = shift(@Func_pname);
 496     print "    newXS(\"$pname\", XS_$_, file);\n";
 497 }
 498
 499 if (@BootCode)
 500 {
 501     print "\n    /* Initialisation Section */\n\n" ;
 502     print grep (s/$/\n/, @BootCode) ;
 503     print "    /* End of Initialisation Section */\n\n" ;
 504 }
 505
 506 print "    ST(0) = &sv_yes;\n";
 507 print "    XSRETURN(1);\n";
 508 print "}\n";
 509
 510 sub output_init {
 511     local($type, $num, $init) = @_;
 512     local($arg) = "ST(" . ($num - 1) . ")";
 513
 514     eval qq/print " $init\\\n"/;
 515 }
 516
 517 sub blurt { warn @_; $errors++ }
 518
 519 sub generate_init {
 520     local($type, $num, $var) = @_;
 521     local($arg) = "ST(" . ($num - 1) . ")";
 522     local($argoff) = $num - 1;
 523     local($ntype);
 524     local($tk);
 525
 526     blurt("$type not in typemap"), return unless defined($type_kind{$type});
 527     ($ntype = $type) =~ s/\s*\*/Ptr/g;
 528     $subtype = $ntype;
 529     $subtype =~ s/Ptr$//;
 530     $subtype =~ s/Array$//;
 531     $tk = $type_kind{$type};
 532     $tk =~ s/OBJ$/REF/ if $func_name =~ /DESTROY$/;
 533     $type =~ s/:/_/g;
 534     $expr = $input_expr{$tk};
 535     if ($expr =~ /DO_ARRAY_ELEM/) {
 536         $subexpr = $input_expr{$type_kind{$subtype}};
 537         $subexpr =~ s/ntype/subtype/g;
 538         $subexpr =~ s/\$arg/ST(ix_$var)/g;
 539         $subexpr =~ s/\n\t/\n\t\t/g;
 540         $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
 541         $subexpr =~ s/\$var/${var}[ix_$var - $argoff]/;
 542         $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
 543     }
 544     if (defined($defaults{$var})) {
 545             $expr =~ s/(\t+)/$1    /g;
 546             $expr =~ s/        /\t/g;
 547             eval qq/print "\\t$var;\\n"/;
 548             $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
 549     } elsif ($expr !~ /^\t\$var =/) {
 550             eval qq/print "\\t$var;\\n"/;
 551             $deferred .= eval qq/"\\n$expr;\\n"/;
 552     } else {
 553             eval qq/print "$expr;\\n"/;
 554     }
 555 }
 556
 557 sub generate_output {
 558     local($type, $num, $var) = @_;
 559     local($arg) = "ST(" . ($num - ($num != 0)) . ")";
 560     local($argoff) = $num - 1;
 561     local($ntype);
 562
 563     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 564             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 565     } else {
 566             blurt("$type not in typemap"), return
 567                 unless defined($type_kind{$type});
 568             ($ntype = $type) =~ s/\s*\*/Ptr/g;
 569             $ntype =~ s/\(\)//g;
 570             $subtype = $ntype;
 571             $subtype =~ s/Ptr$//;
 572             $subtype =~ s/Array$//;
 573             $expr = $output_expr{$type_kind{$type}};
 574             if ($expr =~ /DO_ARRAY_ELEM/) {
 575                 $subexpr = $output_expr{$type_kind{$subtype}};
 576                 $subexpr =~ s/ntype/subtype/g;
 577                 $subexpr =~ s/\$arg/ST(ix_$var)/g;
 578                 $subexpr =~ s/\$var/${var}[ix_$var]/g;
 579                 $subexpr =~ s/\n\t/\n\t\t/g;
 580                 $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 581                 eval "print qq\a$expr\a";
 582             }
 583             elsif ($var eq 'RETVAL') {
 584                 if ($expr =~ /^\t\$arg = /) {
 585                     eval "print qq\a$expr\a";
 586                     print "\tsv_2mortal(ST(0));\n";
 587                 }
 588                 else {
 589                     print "\tST(0) = sv_newmortal();\n";
 590                     eval "print qq\a$expr\a";
 591                 }
 592             }
 593             elsif ($arg =~ /^ST\(\d+\)$/) {
 594                 eval "print qq\a$expr\a";
 595             }
 596             elsif ($arg =~ /^ST\(\d+\)$/) {
 597                 eval "print qq\a$expr\a";
 598             }
 599             elsif ($arg =~ /^ST\(\d+\)$/) {
 600                 eval "print qq\a$expr\a";
 601             }
 602     }
 603 }
 604
 605 sub map_type {
 606     local($type) = @_;
 607
 608     $type =~ s/:/_/g;
 609     if ($type =~ /^array\(([^,]*),(.*)\)/) {
 610             return "$1 *";
 611     } else {
 612             return $type;
 613     }
 614 }
 615
 616 exit $errors;