lib/ExtUtils/xsubpp

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