ext/xsubpp.bak

   1 #!/usr/bin/perl
   2 # $Header$
   3
   4 $usage = "Usage: xsubpp [-a] [-s] [-c] typemap file.xs\n";
   5 die $usage unless (@ARGV >= 2 && @ARGV <= 6);
   6
   7 SWITCH: while ($ARGV[0] =~ /^-/) {
   8     $flag = shift @ARGV;
   9     $aflag = 1, next SWITCH if $flag =~ /^-a$/;
  10     $spat = $1, next SWITCH if $flag =~ /^-s(.*)$/;
  11     $cflag = 1, next SWITCH if $flag =~ /^-c$/;
  12     $eflag = 1, next SWITCH if $flag =~ /^-e$/;
  13     die $usage;
  14 }
  15
  16 $typemap = shift @ARGV;
  17 open(TYPEMAP, $typemap) || die "cannot open $typemap\n";
  18 while (<TYPEMAP>) {
  19         next if /^\s*$/ || /^#/;
  20         chop;
  21         ($typename, $kind) = split(/\t+/, $_, 2);
  22         $type_kind{$typename} = $kind;
  23 }
  24 close(TYPEMAP);
  25
  26 %input_expr = (JUNK, split(/\n(T_\w*)\s*\n/, <<'T_END'));
  27
  28 T_INT
  29         $var = (int)SvIVn($arg)
  30 T_ENUM
  31         $var = ($type)SvIVn($arg)
  32 T_U_INT
  33         $var = (unsigned int)SvIVn($arg)
  34 T_SHORT
  35         $var = (short)SvIVn($arg)
  36 T_U_SHORT
  37         $var = (unsigned short)SvIVn($arg)
  38 T_LONG
  39         $var = (long)SvIVn($arg)
  40 T_U_LONG
  41         $var = (unsigned long)SvIVn($arg)
  42 T_CHAR
  43         $var = (char)*SvPVn($arg,na)
  44 T_U_CHAR
  45         $var = (unsigned char)SvIVn($arg)
  46 T_FLOAT
  47         $var = (float)SvNVn($arg)
  48 T_DOUBLE
  49         $var = SvNVn($arg)
  50 T_STRING
  51         $var = SvPVn($arg,na)
  52 T_PTR
  53         $var = ($type)(unsigned long)SvNVn($arg)
  54 T_PTRREF
  55         if (SvTYPE($arg) == SVt_REF)
  56             $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
  57         else
  58             croak(\"$var is not a reference\")
  59 T_PTROBJ
  60         if (sv_isa($arg, \"${ntype}\"))
  61             $var = ($type)(unsigned long)SvNVn((SV*)SvANY($arg));
  62         else
  63             croak(\"$var is not of type ${ntype}\")
  64 T_PTRDESC
  65         if (sv_isa($arg, \"${ntype}\")) {
  66             ${type}_desc = (\U${type}_DESC\E*)(unsigned long)SvNVn((SV*)SvANY($arg));
  67             $var = ${type}_desc->ptr;
  68         }
  69         else
  70             croak(\"$var is not of type ${ntype}\")
  71 T_REFREF
  72         if (SvTYPE($arg) == SVt_REF)
  73             $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
  74         else
  75             croak(\"$var is not a reference\")
  76 T_REFOBJ
  77         if (sv_isa($arg, \"${ntype}\"))
  78             $var = *($type)(unsigned long)SvNVn((SV*)SvANY($arg));
  79         else
  80             croak(\"$var is not of type ${ntype}\")
  81 T_OPAQUE
  82         $var NOT IMPLEMENTED
  83 T_OPAQUEPTR
  84         $var = ($type)SvPVn($arg,na)
  85 T_PACKED
  86         $var = XS_unpack_$ntype($arg)
  87 T_PACKEDARRAY
  88         $var = XS_unpack_$ntype($arg)
  89 T_CALLBACK
  90         $var = make_perl_cb_$type($arg)
  91 T_ARRAY
  92         $var = $ntype(items -= $argoff);
  93         U32 ix_$var = $argoff;
  94         while (items--) {
  95             DO_ARRAY_ELEM;
  96         }
  97 T_DATUM
  98         $var.dptr = SvPVn($arg, $var.dsize);
  99 T_GDATUM
 100         UNIMPLEMENTED
 101 T_PLACEHOLDER
 102 T_END
 103
 104 $* = 1; %output_expr = (JUNK, split(/^(T_\w*)\s*\n/, <<'T_END')); $* = 0;
 105 T_INT
 106         sv_setiv($arg, (I32)$var);
 107 T_ENUM
 108         sv_setiv($arg, (I32)$var);
 109 T_U_INT
 110         sv_setiv($arg, (I32)$var);
 111 T_SHORT
 112         sv_setiv($arg, (I32)$var);
 113 T_U_SHORT
 114         sv_setiv($arg, (I32)$var);
 115 T_LONG
 116         sv_setiv($arg, (I32)$var);
 117 T_U_LONG
 118         sv_setiv($arg, (I32)$var);
 119 T_CHAR
 120         sv_setpvn($arg, (char *)&$var, 1);
 121 T_U_CHAR
 122         sv_setiv($arg, (I32)$var);
 123 T_FLOAT
 124         sv_setnv($arg, (double)$var);
 125 T_DOUBLE
 126         sv_setnv($arg, $var);
 127 T_STRING
 128         sv_setpv($arg, $var);
 129 T_PTR
 130         sv_setnv($arg, (double)(unsigned long)$var);
 131 T_PTRREF
 132         sv_setptrref($arg, $var);
 133 T_PTROBJ
 134         sv_setptrobj($arg, $var, \"${ntype}\");
 135 T_PTRDESC
 136         sv_setptrobj($arg, (void*)new\U${type}_DESC\E($var), \"${ntype}\");
 137 T_REFREF
 138         sv_setrefref($arg, \"${ntype}\", XS_service_$ntype,
 139                     ($var ? (void*)new $ntype($var) : 0));
 140 T_REFOBJ
 141         NOT IMPLEMENTED
 142 T_OPAQUE
 143         sv_setpvn($arg, (char *)&$var, sizeof($var));
 144 T_OPAQUEPTR
 145         sv_setpvn($arg, (char *)$var, sizeof(*$var)), XFree((char *)$var);
 146 T_PACKED
 147         XS_pack_$ntype($arg, $var);
 148 T_PACKEDARRAY
 149         XS_pack_$ntype($arg, $var, count_$ntype);
 150 T_DATAUNIT
 151         sv_setpvn($arg, $var.chp(), $var.size());
 152 T_CALLBACK
 153         sv_setpvn($arg, $var.context.value().chp(),
 154                 $var.context.value().size());
 155 T_ARRAY
 156         ST_EXTEND($var.size);
 157         for (U32 ix_$var = 0; ix_$var < $var.size; ix_$var++) {
 158                 ST(ix_$var) = sv_mortalcopy(&sv_undef);
 159         DO_ARRAY_ELEM
 160         }
 161         sp += $var.size - 1;
 162 T_DATUM
 163         sv_setpvn($arg, $var.dptr, $var.dsize);
 164 T_GDATUM
 165         sv_usepvn($arg, $var.dptr, $var.dsize);
 166 T_END
 167
 168 $uvfile = shift @ARGV;
 169 open(F, $uvfile) || die "cannot open $uvfile\n";
 170
 171 if ($eflag) {
 172         print qq|#include "cfm/basic.h"\n|;
 173 }
 174
 175 while (<F>) {
 176         last if ($Module, $foo, $Package, $foo1, $Prefix) =
 177                 /^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/;
 178         print $_;
 179 }
 180 $Pack = $Package;
 181 $Package .= "::" if defined $Package && $Package ne "";
 182 $/ = "";
 183
 184 while (<F>) {
 185         # parse paragraph
 186         chop;
 187         next if /^\s*$/;
 188         next if /^(#.*\n?)+$/;
 189         if (/^MODULE\s*=\s*(\w+)(\s+PACKAGE\s*=\s*(\w+))?(\s+PREFIX\s*=\s*(.+))?$/) {
 190                 $Module = $1;
 191                 $foo = $2;
 192                 $Package = $3;
 193                 $Pack = $Package;
 194                 $foo1 = $4;
 195                 $Prefix = $5;
 196                 $Package .= "::" if defined $Package && $Package ne "";
 197                 next;
 198         }
 199         split(/[\t ]*\n/);
 200
 201         # initialize info arrays
 202         undef(%args_match);
 203         undef(%var_types);
 204         undef(%var_addr);
 205         undef(%defaults);
 206         undef($class);
 207         undef($static);
 208         undef($elipsis);
 209
 210         # extract return type, function name and arguments
 211         $ret_type = shift(@_);
 212         if ($ret_type =~ /^static\s+(.*)$/) {
 213                 $static = 1;
 214                 $ret_type = $1;
 215         }
 216         $func_header = shift(@_);
 217         ($func_name, $orig_args) =  $func_header =~ /^([\w:]+)\s*\((.*)\)$/;
 218         if ($func_name =~ /(.*)::(.*)/) {
 219                 $class = $1;
 220                 $func_name = $2;
 221         }
 222         ($pname = $func_name) =~ s/^($Prefix)?/$Package/;
 223         push(@Func_name, "${Pack}_$func_name");
 224         push(@Func_pname, $pname);
 225         @args = split(/\s*,\s*/, $orig_args);
 226         if (defined($class) && !defined($static)) {
 227                 unshift(@args, "THIS");
 228                 $orig_args = "THIS, $orig_args";
 229                 $orig_args =~ s/^THIS, $/THIS/;
 230         }
 231         $orig_args =~ s/"/\\"/g;
 232         $min_args = $num_args = @args;
 233         foreach $i (0..$num_args-1) {
 234                 if ($args[$i] =~ s/\.\.\.//) {
 235                         $elipsis = 1;
 236                         $min_args--;
 237                         if ($args[i] eq '' && $i == $num_args - 1) {
 238                             pop(@args);
 239                             last;
 240                         }
 241                 }
 242                 if ($args[$i] =~ /([^=]*\S)\s*=\s*(.*)/) {
 243                         $min_args--;
 244                         $args[$i] = $1;
 245                         $defaults{$args[$i]} = $2;
 246                         $defaults{$args[$i]} =~ s/"/\\"/g;
 247                 }
 248         }
 249         if (defined($class) && !defined($static)) {
 250                 $func_args = join(", ", @args[1..$#args]);
 251         } else {
 252                 $func_args = join(", ", @args);
 253         }
 254         @args_match{@args} = 1..@args;
 255
 256         # print function header
 257         print <<"EOF" if $aflag;
 258 static int
 259 XS_${Pack}_$func_name(int, int sp, int items)
 260 EOF
 261         print <<"EOF" if !$aflag;
 262 static int
 263 XS_${Pack}_$func_name(ix, sp, items)
 264 register int ix;
 265 register int sp;
 266 register int items;
 267 EOF
 268         print <<"EOF" if $elipsis;
 269 {
 270     if (items < $min_args) {
 271         croak("Usage: $pname($orig_args)");
 272     }
 273 EOF
 274         print <<"EOF" if !$elipsis;
 275 {
 276     if (items < $min_args || items > $num_args) {
 277         croak("Usage: $pname($orig_args)");
 278     }
 279 EOF
 280
 281 # Now do a block of some sort.
 282
 283 $condnum = 0;
 284 if (!@_) {
 285     @_ = "CLEANUP:";
 286 }
 287 while (@_) {
 288         if ($_[0] =~ s/^\s*CASE\s*:\s*//) {
 289                 $cond = shift(@_);
 290                 if ($condnum == 0) {
 291                     print "    if ($cond)\n";
 292                 }
 293                 elsif ($cond ne '') {
 294                     print "    else if ($cond)\n";
 295                 }
 296                 else {
 297                     print "    else\n";
 298                 }
 299                 $condnum++;
 300         }
 301
 302         print           <<"EOF" if $eflag;
 303     TRY {
 304 EOF
 305         print           <<"EOF" if !$eflag;
 306     {
 307 EOF
 308
 309         # do initialization of input variables
 310         $thisdone = 0;
 311         $retvaldone = 0;
 312         $deferred = "";
 313         while ($_ = shift(@_)) {
 314                 last if /^\s*NOT_IMPLEMENTED_YET/;
 315                 last if /^\s*(CODE|OUTPUT|CLEANUP|CASE)\s*:/;
 316                 ($var_type, $var_name, $var_init) =
 317                     /\s*([^\t]+)\s*([^\s=]+)\s*(=.*)?/;
 318                 if ($var_name =~ /^&/) {
 319                         $var_name =~ s/^&//;
 320                         $var_addr{$var_name} = 1;
 321                 }
 322                 $thisdone |= $var_name eq "THIS";
 323                 $retvaldone |= $var_name eq "RETVAL";
 324                 $var_types{$var_name} = $var_type;
 325                 print "\t" . &map_type($var_type);
 326                 $var_num = $args_match{$var_name};
 327                 if ($var_addr{$var_name}) {
 328                         $func_args =~ s/\b($var_name)\b/&\1/;
 329                 }
 330                 if ($var_init !~ /^=\s*NO_INIT\s*$/) {
 331                         if ($var_init !~ /^\s*$/) {
 332                                 &output_init($var_type, $var_num,
 333                                     "$var_name $var_init");
 334                         } elsif ($var_num) {
 335                                 # generate initialization code
 336                                 &generate_init($var_type, $var_num, $var_name);
 337                         } else {
 338                                 print ";\n";
 339                         }
 340                 } else {
 341                         print "\t$var_name;\n";
 342                 }
 343         }
 344         if (!$thisdone && defined($class) && !defined($static)) {
 345                 print "\t$class *";
 346                 $var_types{"THIS"} = "$class *";
 347                 &generate_init("$class *", 1, "THIS");
 348         }
 349
 350         # do code
 351         if (/^\s*NOT_IMPLEMENTED_YET/) {
 352                 print "\ncroak(\"$pname: not implemented yet\");\n";
 353         } else {
 354                 if ($ret_type ne "void") {
 355                         print "\t" . &map_type($ret_type) . "\tRETVAL;\n"
 356                                 if !$retvaldone;
 357                         $args_match{"RETVAL"} = 0;
 358                         $var_types{"RETVAL"} = $ret_type;
 359                 }
 360                 print $deferred;
 361                 if (/^\s*CODE:/) {
 362                         while ($_ = shift(@_)) {
 363                                 last if /^\s*(OUTPUT|CLEANUP|CASE)\s*:/;
 364                                 print "$_\n";
 365                         }
 366                 } else {
 367                         print "\n\t";
 368                         if ($ret_type ne "void") {
 369                                 print "RETVAL = ";
 370                         }
 371                         if (defined($static)) {
 372                                 print "$class::";
 373                         } elsif (defined($class)) {
 374                                 print "THIS->";
 375                         }
 376                         if (defined($spat) && $func_name =~ /^($spat)(.*)$/) {
 377                                 $func_name = $2;
 378                         }
 379                         print "$func_name($func_args);\n";
 380                         &generate_output($ret_type, 0, "RETVAL")
 381                             unless $ret_type eq "void";
 382                 }
 383         }
 384
 385         # do output variables
 386         if (/^\s*OUTPUT\s*:/) {
 387                 while ($_ = shift(@_)) {
 388                         last if /^\s*CLEANUP\s*:/;
 389                         s/^\s+//;
 390                         ($outarg, $outcode) = split(/\t+/);
 391                         if ($outcode) {
 392                         print "\t$outcode\n";
 393                         } else {
 394                                 die "$outarg not an argument"
 395                                     unless defined($args_match{$outarg});
 396                                 $var_num = $args_match{$outarg};
 397                                 &generate_output($var_types{$outarg}, $var_num,
 398                                     $outarg);
 399                         }
 400                 }
 401         }
 402         # do cleanup
 403         if (/^\s*CLEANUP\s*:/) {
 404             while ($_ = shift(@_)) {
 405                     last if /^\s*CASE\s*:/;
 406                     print "$_\n";
 407             }
 408         }
 409         # print function trailer
 410         print <<EOF if $eflag;
 411     }
 412     BEGHANDLERS
 413     CATCHALL
 414         croak("%s: %s\\tpropagated", Xname, Xreason);
 415     ENDHANDLERS
 416 EOF
 417         print <<EOF if !$eflag;
 418     }
 419 EOF
 420         if (/^\s*CASE\s*:/) {
 421             unshift(@_, $_);
 422         }
 423 }
 424         print <<EOF;
 425     return sp;
 426 }
 427
 428 EOF
 429 }
 430
 431 # print initialization routine
 432 print qq/extern "C"\n/ if $cflag;
 433 print <<"EOF";
 434 int init_$Module(ix,sp,items)
 435 int ix;
 436 int sp;
 437 int items;
 438 {
 439     char* file = __FILE__;
 440
 441 EOF
 442
 443 for (@Func_name) {
 444         $pname = shift(@Func_pname);
 445         print "    newXSUB(\"$pname\", 0, XS_$_, file);\n";
 446 }
 447 print "}\n";
 448
 449 sub output_init {
 450         local($type, $num, $init) = @_;
 451         local($arg) = "ST($num)";
 452
 453         eval qq/print " $init\\\n"/;
 454 }
 455
 456 sub generate_init {
 457         local($type, $num, $var) = @_;
 458         local($arg) = "ST($num)";
 459         local($argoff) = $num - 1;
 460         local($ntype);
 461
 462         die "$type not in typemap" if !defined($type_kind{$type});
 463         ($ntype = $type) =~ s/\s*\*/Ptr/g;
 464         $subtype = $ntype;
 465         $subtype =~ s/Ptr$//;
 466         $subtype =~ s/Array$//;
 467         $expr = $input_expr{$type_kind{$type}};
 468         if ($expr =~ /DO_ARRAY_ELEM/) {
 469             $subexpr = $input_expr{$type_kind{$subtype}};
 470             $subexpr =~ s/ntype/subtype/g;
 471             $subexpr =~ s/\$arg/ST(ix_$var)/g;
 472             $subexpr =~ s/\n\t/\n\t\t/g;
 473             $subexpr =~ s/is not of (.*")/[arg %d] is not of $1, ix_$var + 1/g;
 474             $subexpr =~ s/\$var/$var[ix_$var - $argoff]/;
 475             $expr =~ s/DO_ARRAY_ELEM/$subexpr/;
 476         }
 477         if (defined($defaults{$var})) {
 478                 $expr =~ s/(\t+)/$1    /g;
 479                 $expr =~ s/        /\t/g;
 480                 eval qq/print "\\t$var;\\n"/;
 481                 $deferred .= eval qq/"\\n\\tif (items < $num)\\n\\t    $var = $defaults{$var};\\n\\telse {\\n$expr;\\n\\t}\\n"/;
 482         } elsif ($expr !~ /^\t\$var =/) {
 483                 eval qq/print "\\t$var;\\n"/;
 484                 $deferred .= eval qq/"\\n$expr;\\n"/;
 485         } else {
 486                 eval qq/print "$expr;\\n"/;
 487         }
 488 }
 489
 490 sub generate_output {
 491         local($type, $num, $var) = @_;
 492         local($arg) = "ST($num)";
 493         local($argoff) = $num - 1;
 494         local($ntype);
 495
 496         if ($type =~ /^array\(([^,]*),(.*)\)/) {
 497                 print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1)), XFree((char *)$var);\n";
 498         } else {
 499                 die "$type not in typemap" if !defined($type_kind{$type});
 500                 ($ntype = $type) =~ s/\s*\*/Ptr/g;
 501                 $ntype =~ s/\(\)//g;
 502                 $subtype = $ntype;
 503                 $subtype =~ s/Ptr$//;
 504                 $subtype =~ s/Array$//;
 505                 $expr = $output_expr{$type_kind{$type}};
 506                 if ($expr =~ /DO_ARRAY_ELEM/) {
 507                     $subexpr = $output_expr{$type_kind{$subtype}};
 508                     $subexpr =~ s/ntype/subtype/g;
 509                     $subexpr =~ s/\$arg/ST(ix_$var)/g;
 510                     $subexpr =~ s/\$var/${var}[ix_$var]/g;
 511                     $subexpr =~ s/\n\t/\n\t\t/g;
 512                     $expr =~ s/DO_ARRAY_ELEM\n/$subexpr/;
 513                 }
 514                 elsif ($arg eq 'ST(0)') {
 515                     print "\tST(0) = sv_mortalcopy(&sv_undef);\n";
 516                 }
 517                 eval "print qq\f$expr\f";
 518         }
 519 }
 520
 521 sub map_type {
 522         local($type) = @_;
 523
 524         if ($type =~ /^array\(([^,]*),(.*)\)/) {
 525                 return "$1 *";
 526         } else {
 527                 return $type;
 528         }
 529 }