macos/xsubpp.patch

   1 diff -ru :perl:lib:ExtUtils: :perl.new:lib:ExtUtils:xsubpp
   2 --- :perl:lib:ExtUtils:xsubpp   Mon Feb 19 17:07:32 2001
   3 +++ :perl.new:lib:ExtUtils:xsubpp       Mon Feb 19 15:31:31 2001
   4 @@ -173,7 +173,13 @@
   5  ($dir, $filename) = $ARGV[0] =~ m#(.*)/(.*)#
   6         or ($dir, $filename) = $ARGV[0] =~ m#(.*)\\(.*)#
   7         or ($dir, $filename) = $ARGV[0] =~ m#(.*[>\]])(.*)#
   8 +       or ($dir, $filename) = $ARGV[0] =~ m#(.*):(.*)#
   9         or ($dir, $filename) = ('.', $ARGV[0]);
  10 +
  11 +$Is_MacOS = $^O eq 'MacOS';
  12 +if ($Is_MacOS && $dir eq '.') {
  13 +     $dir = ":";
  14 +}
  15  chdir($dir);
  16  $pwd = cwd();
  17
  18 @@ -209,9 +215,21 @@
  19  foreach $typemap (@tm) {
  20      die "Can't find $typemap in $pwd\n" unless -r $typemap;
  21  }
  22 -unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  23 +if ($Is_MacOS) { my @tmp;
  24 +    foreach (qw(:::: ::: :: :)) {
  25 +       push @tmp, "$_:lib:ExtUtils:typemap";
  26 +       push @tmp, "$_:macos:lib:ExtUtils:typemap";
  27 +       push @tmp, "$_:Mac:typemap";
  28 +       push @tmp, "$_:macos:ext:Mac:typemap";
  29 +       push @tmp, "$_:typemap";
  30 +    }
  31 +    unshift @tm, @tmp, "typemap";
  32 +} else {
  33 +    unshift @tm, qw(../../../../lib/ExtUtils/typemap ../../../lib/ExtUtils/typemap
  34                  ../../lib/ExtUtils/typemap ../../../typemap ../../typemap
  35                  ../typemap typemap);
  36 +}
  37 +
  38  foreach $typemap (@tm) {
  39      next unless -e $typemap ;
  40      # skip directories, binary files etc.
  41 @@ -364,7 +382,7 @@
  42      print("#line ", $line_no[@line_no - @line -1], " \"$filename\"\n")
  43         if $WantLineNumbers && !/^\s*#\s*line\b/ && !/^#if XSubPPtmp/;
  44      for (;  defined($_) && !/^$BLOCK_re/o;  $_ = shift(@line)) {
  45 -       print "$_\n";
  46 +       XS_process("$_\n");
  47      }
  48      print "$xsubpp::counter::SECTION_END_MARKER\n" if $WantLineNumbers;
  49  }
  50 @@ -746,7 +764,85 @@
  51      $lastline_no = $. ;
  52
  53  }
  54 -
  55 +
  56 +sub XS_PUSH_handler
  57 +{
  58 +    my($type, $value, $xpush) = @_;
  59 +    if ($xpush) {
  60 +       print "\tEXTEND(sp, 1);\n";
  61 +    }
  62 +    print "\t++sp;\n";
  63 +    &generate_output($type, 0, "($value)", "*sp", 1);
  64 +    "";
  65 +}
  66 +
  67 +sub XS_OUTPUT_handler
  68 +{
  69 +    my($type, $value, $arg) = @_;
  70 +
  71 +    &generate_output($type, 0, "($value)", 0, 0, $arg);
  72 +    "";
  73 +}
  74 +
  75 +sub XS_INPUT_handler
  76 +{
  77 +    my($type, $var, $arg) = @_;
  78 +    &generate_init($type, 0, $var, 0, 0, $arg, 1);
  79 +    "";
  80 +}
  81 +
  82 +
  83 +sub XS_POP_handler
  84 +{
  85 +    my($type, $var, $pop) = @_;
  86 +    &generate_init($type, 0, $var, "TOPs", 1);
  87 +    print "\tPOPs;\n" if $pop;
  88 +    "";
  89 +}
  90 +
  91 +sub SplitArgs
  92 +{
  93 +    my(@bits,@pieces,$item);
  94 +    @bits = split /,/, $_[0];
  95 +    while (@bits) {
  96 +       $item .= "," if $item;
  97 +       $item .= shift @bits;
  98 +       if (tr/(// == tr/)//
  99 +        && tr/{// == tr/}//
 100 +        && tr/[// == tr/]//
 101 +        && !(tr/"// & 1)
 102 +        && !(tr/'// & 1)
 103 +       ) {
 104 +           push @pieces, $item;
 105 +           $item = "";
 106 +       }
 107 +    }
 108 +    @pieces;
 109 +}
 110 +
 111 +sub XS_process
 112 +{
 113 +    my($text) = @_;
 114 +
 115 +    while (length($text)) {
 116 +       if ($text =~ s/^.*\bXS_PUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
 117 +           XS_PUSH_handler($1, $2, 0);
 118 +       } elsif ($text =~ s/^.*\bXS_XPUSH\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
 119 +           XS_PUSH_handler($1, $2, 1);
 120 +       } elsif ($text =~ s/^.*\bXS_OUTPUT\((.*)\)\s*;?.*\n?//) {
 121 +           XS_OUTPUT_handler(SplitArgs($1));
 122 +       } elsif ($text =~ s/^.*\bXS_INPUT\((.*)\)\s*;?.*\n?//) {
 123 +           XS_INPUT_handler(SplitArgs($1));
 124 +       } elsif ($text =~ s/^.*\bXS_POP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
 125 +           XS_POP_handler($1, $2, 1);
 126 +       } elsif ($text =~ s/^.*\bXS_TOP\(([^,]+),\s*(.*)\)\s*;?.*\n?//) {
 127 +           XS_POP_handler($1, $2, 0);
 128 +       } elsif ($text =~ s/^(.*\n?)//) {
 129 +           print $1;
 130 +       }
 131 +    }
 132 +}
 133 +
 134  sub PopFile()
 135  {
 136      return 0 unless $XSStack[-1]{type} eq 'file' ;
 137 @@ -861,8 +957,8 @@
 138          my $podstartline = $.;
 139         do {
 140             if (/^=cut\s*$/) {
 141 -               print("/* Skipped embedded POD. */\n");
 142 -               printf("#line %d \"$filename\"\n", $. + 1)
 143 +               XS_process("/* Skipped embedded POD. */\n");
 144 +               XS_process(sprintf("#line %d \"$filename\"\n", $. + 1))
 145                   if $WantLineNumbers;
 146                 next firstmodule
 147             }
 148 @@ -880,7 +976,7 @@
 149      if ($OBJ) {
 150          s/#if(?:def\s|\s+defined)\s*(\(__cplusplus\)|__cplusplus)/#if defined(__cplusplus) && !defined(PERL_OBJECT)/;
 151      }
 152 -    print $_;
 153 +    XS_process($_);
 154  }
 155  &Exit unless defined $_;
 156
 157 @@ -949,6 +1045,185 @@
 158      1;
 159  }
 160
 161 +sub indent {
 162 +     my($line) = @_;
 163 +     my($indent) = 0;
 164 +
 165 +     for (;;) {
 166 +       if ($line =~ s/^( +)//) { $indent += length $1;         next; }
 167 +       if ($line =~ s/^\t//)   { $indent += 8 - ($indent & 7); next; }
 168 +       last;
 169 +     }
 170 +     $indent;
 171 +}
 172 +
 173 +sub handle_struct
 174 +{
 175 +    # extract return type, function name and arguments
 176 +    my($deref, $structpack) = /(\**)\s*(\S+)/;
 177 +    my($handle) = ($^O eq "MacOS") && ($deref eq "**");
 178 +    $deref =~ s/\*$/->/;
 179 +    $deref =~ s/\*/\[0\]/g;
 180 +    $deref ||= ".";
 181 +    my($structtype) = $structpack;
 182 +
 183 +    # a struct definition needs at least 2 lines
 184 +    blurt ("Error: Struct definition too short '$structpack'"), next PARAGRAPH
 185 +       unless @line ;
 186 +
 187 +    ($clean_struct_name = $structpack) =~ s/^$Prefix//;
 188 +    $Full_struct_name = "${Packid}_$clean_struct_name";
 189 +    if ($Is_VMS) { $Full_struct_name = $SymSet->addsym($Full_struct_name); }
 190 +
 191 +    # Check for duplicate function definition
 192 +    for $tmp (@XSStack) {
 193 +       next unless defined $tmp->{functions}{$Full_struct_name};
 194 +       Warn("Warning: duplicate struct definition '$clean_struct_name' detected");
 195 +       last;
 196 +    }
 197 +
 198 +    # print struct function header
 199 +    print Q<<"EOF";
 200 +#XS(XS_${Full_struct_name})
 201 +#[[
 202 +#    dXSARGS;
 203 +#    dXSI32;
 204 +#    if (items < 1 || items > 2)
 205 +#       croak("Usage: %s(STRUCT [, VALUE])", GvNAME(CvGV(cv)));
 206 +#    SP -= items;
 207 +EOF
 208 +
 209 +    # Now do a block of some sort.
 210 +
 211 +    &check_cpp;
 212 +    my($structinput, $structoutput, $structindir, $structoutdir);
 213 +    my(@field, @fieldindir, @fieldoutdir, @input, @output);
 214 +    $structindir = $structoutdir = line_directive();
 215 +    $_ = "";
 216 +    while (defined $_) {
 217 +       $_ = shift @line while /^\s*$/;
 218 +       my($fieldindir) = line_directive();
 219 +       my($fieldoutdir)= $fieldindir;
 220 +       my($indent,$fieldtype,$fieldname) =
 221 +               m|^(\s*)(\S.*\S)\s*\b(\w+)\s*;?\s*(?:/\*.*\*/)?$|;
 222 +       $indent = indent $indent;
 223 +       $fieldtype = TidyType $fieldtype;
 224 +       my($input, $output);
 225 +       my $var = "STRUCT$deref$fieldname";
 226 +       $_ = shift @line;
 227 +       while (/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) {
 228 +           if (/ALIAS\s*(.*)/) {
 229 +               $var = $1;
 230 +               $_ = shift @line;
 231 +           } elsif (/READ_ONLY/) {
 232 +               $fieldindir = line_directive();
 233 +               $input = "$_";
 234 +               $_ = shift @line;
 235 +           } elsif (/INPUT/) {
 236 +               last unless ($_ = shift @line);
 237 +               $fieldindir = line_directive();
 238 +               while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) {
 239 +                   $input .= "$_\n";
 240 +                   $_ = shift @line;
 241 +               }
 242 +           } else {
 243 +               last unless ($_ = shift @line);
 244 +               $fieldoutdir = line_directive();
 245 +               while (indent($_) > $indent && !/ALIAS|READ_ONLY|INPUT:|OUTPUT:/) {
 246 +                   $output .= "$_\n";
 247 +                   $_ = shift @line;
 248 +               }
 249 +           }
 250 +       }
 251 +       if ($fieldname eq "STRUCT") {
 252 +           $structindir = $fieldindir;
 253 +           $structoutdir= $fieldoutdir;
 254 +           $structtype  = $fieldtype;
 255 +           $arg         = "ST(0)";
 256 +           $structinput = eval "qq\a$input\a";
 257 +           $structoutput= eval "qq\a$output\a";
 258 +       } else {
 259 +           if ($input =~ /READ_ONLY/) {
 260 +               $input = "\tcroak(\"$var is read-only\");\n";
 261 +           } elsif ($input) {
 262 +               $arg = "ST(1)";
 263 +               $input = eval "qq\a$input\a";
 264 +           } else {
 265 +               $input = "\tXS_INPUT($fieldtype, $var, ST(1));";
 266 +           }
 267 +           if ($output) {
 268 +               $arg = "*sp";
 269 +               $output = "\tPUSHs(sv_newmortal());\n" . eval "qq\a$output\a";
 270 +           } else {
 271 +               $output = "\tXS_PUSH($fieldtype, $var);";
 272 +           }
 273 +           push @field, $fieldname;
 274 +           push @fieldindir, $fieldindir;
 275 +           push @fieldoutdir, $fieldoutdir;
 276 +           push @input, $input;
 277 +           push @output, $output;
 278 +       }
 279 +    }
 280 +    print Q<<"EOF";
 281 +#    [[
 282 +#      $structtype STRUCT;
 283 +EOF
 284 +    print "\tchar STRUCT_state;\n" if $handle;
 285 +    print "\n$structindir";
 286 +    XS_process($structinput || "\tXS_INPUT($structtype, STRUCT, ST(0));");
 287 +    print "\n\tSTRUCT_state = HGetState((Handle)STRUCT); HLock((Handle)STRUCT);\n" if ($handle);
 288 +    print Q<<"EOF";
 289 +#      if (items == 1) [[ /* Get field */
 290 +#          switch (ix) [[
 291 +EOF
 292 +    for (0..$#field) {
 293 +       print Q<<"EOF";
 294 +#          case $_:      /* $field[$_] */
 295 +EOF
 296 +       print $fieldoutdir[$_];
 297 +       XS_process($output[$_]);
 298 +       print Q<<"EOF";
 299 +#              break;
 300 +EOF
 301 +    }
 302 +    print Q<<"EOF";
 303 +#          ]]
 304 +#      ]] else [[         /* Set field */
 305 +#          switch (ix) [[
 306 +EOF
 307 +    for (0..$#field) {
 308 +       print Q<<"EOF";
 309 +#          case $_:      /* $field[$_] */
 310 +EOF
 311 +       print $fieldindir[$_];
 312 +       XS_process($input[$_]);
 313 +       print Q<<"EOF";
 314 +#              break;
 315 +EOF
 316 +    }
 317 +    print Q<<"EOF";
 318 +#          ]]
 319 +EOF
 320 +    print $structoutdir;
 321 +    XS_process($structoutput || "\tXS_OUTPUT($structtype, STRUCT, ST(0))\n");
 322 +    print Q<<"EOF";
 323 +#      ]]
 324 +EOF
 325 +    print "\tHSetState((Handle)STRUCT, STRUCT_state);\n" if $handle;
 326 +    print Q<<"EOF";
 327 +#    ]]
 328 +#    XSRETURN(1);
 329 +#]]
 330 +#
 331 +EOF
 332 +    for (0..$#field) {
 333 +       push(@InitFileCode, Q<<"EOF");
 334 +#        cv = newXS(\"${structpack}::$field[$_]\", XS_$Full_struct_name, file);
 335 +#        XSANY.any_i32 = $_ ;
 336 +EOF
 337 +    }
 338 +}
 339 +
 340  PARAGRAPH:
 341  while (fetch_para()) {
 342      # Print initial preprocessor statements and blank lines
 343 @@ -1040,7 +1315,11 @@
 344          next PARAGRAPH ;
 345      }
 346
 347 -
 348 +    if (s/^STRUCT\s*//) {
 349 +       handle_struct();
 350 +       next PARAGRAPH;
 351 +    }
 352 +
 353      # extract return type, function name and arguments
 354      ($ret_type) = TidyType($_);
 355      $RETVAL_no_return = 1 if $ret_type =~ s/^NO_OUTPUT\s+//;
 356 @@ -1285,7 +1564,7 @@
 357                     $processing_arg_with_types = 1;
 358                     INPUT_handler() ;
 359                 }
 360 -               print $deferred;
 361 +               XS_process($deferred);
 362
 363          process_keyword("INIT|ALIAS|ATTRS|PROTOTYPE|INTERFACE_MACRO|INTERFACE|C_ARGS") ;
 364
 365 @@ -1338,7 +1617,7 @@
 366
 367         # all OUTPUT done, so now push the return value on the stack
 368         if ($gotRETVAL && $RETVAL_code) {
 369 -           print "\t$RETVAL_code\n";
 370 +           XS_process("\t$RETVAL_code\n");
 371         } elsif ($gotRETVAL || $wantRETVAL) {
 372             my $t = $WantOptimize && $targetable{$type_kind{$ret_type}};
 373             my $var = 'RETVAL';
 374 @@ -1574,6 +1853,14 @@
 375      }
 376  }
 377
 378 +sub line_directive
 379 +{
 380 +    # work out the line number
 381 +    my $line_no = $line_no[@line_no - @line -1] ;
 382 +
 383 +    return "#line $line_no \"$filename\"\n" ;
 384 +}
 385 +
 386  sub Warn
 387  {
 388      # work out the line number
 389 @@ -1595,12 +1882,12 @@
 390  }
 391
 392  sub generate_init {
 393 -    local($type, $num, $var) = @_;
 394 -    local($arg) = "ST(" . ($num - 1) . ")";
 395 +    local($type, $num, $var, $arg, $immed) = @_;
 396      local($argoff) = $num - 1;
 397      local($ntype);
 398      local($tk);
 399
 400 +    $arg ||= "ST(" . ($num - 1) . ")";
 401      $type = TidyType($type) ;
 402      blurt("Error: '$type' not in typemap"), return
 403         unless defined($type_kind{$type});
 404 @@ -1656,17 +1943,18 @@
 405      } else {
 406             die "panic: do not know how to handle this branch for function pointers"
 407               if $name_printed;
 408 -           eval qq/print "$expr;\\n"/;
 409 +           eval qq/XS_process "$expr;\\n"/;
 410             warn $@   if  $@;
 411      }
 412  }
 413
 414  sub generate_output {
 415 -    local($type, $num, $var, $do_setmagic, $do_push) = @_;
 416 -    local($arg) = "ST(" . ($num - ($num != 0)) . ")";
 417 +    local($type, $num, $var, $do_setmagic, $do_push, $arg, $mortalize) = @_;
 418      local($argoff) = $num - 1;
 419      local($ntype);
 420
 421 +    $mortalize ||= $var eq 'RETVAL';
 422 +    $arg ||= "ST(" . ($num - ($num != 0)) . ")";
 423      $type = TidyType($type) ;
 424      if ($type =~ /^array\(([^,]*),(.*)\)/) {
 425             print "\tsv_setpvn($arg, (char *)$var, $2 * sizeof($1));\n";
 426 @@ -1695,30 +1983,30 @@
 427                 warn $@   if  $@;
 428                 print "\t\tSvSETMAGIC(ST(ix_$var));\n" if $do_setmagic;
 429             }
 430 -           elsif ($var eq 'RETVAL') {
 431 +           elsif ($mortalize) {
 432                 if ($expr =~ /^\t\$arg = new/) {
 433                     # We expect that $arg has refcnt 1, so we need to
 434                     # mortalize it.
 435                     eval "print qq\a$expr\a";
 436                     warn $@   if  $@;
 437 -                   print "\tsv_2mortal(ST($num));\n";
 438 -                   print "\tSvSETMAGIC(ST($num));\n" if $do_setmagic;
 439 +                   print "\tsv_2mortal($arg);\n";
 440 +                   print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
 441                 }
 442                 elsif ($expr =~ /^\s*\$arg\s*=/) {
 443                     # We expect that $arg has refcnt >=1, so we need
 444                     # to mortalize it!
 445                     eval "print qq\a$expr\a";
 446                     warn $@   if  $@;
 447 -                   print "\tsv_2mortal(ST(0));\n";
 448 -                   print "\tSvSETMAGIC(ST(0));\n" if $do_setmagic;
 449 +                   print "\tsv_2mortal($arg);\n";
 450 +                   print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
 451                 }
 452                 else {
 453                     # Just hope that the entry would safely write it
 454                     # over an already mortalized value. By
 455                     # coincidence, something like $arg = &sv_undef
 456                     # works too.
 457 -                   print "\tST(0) = sv_newmortal();\n";
 458 -                   eval "print qq\a$expr\a";
 459 +                   print "\t$arg = sv_newmortal();\n";
 460 +                   eval "XS_process qq\a$expr\a";
 461                     warn $@   if  $@;
 462                     # new mortals don't have set magic
 463                 }
 464 @@ -1730,8 +2018,8 @@
 465                 warn $@   if  $@;
 466                 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
 467             }
 468 -           elsif ($arg =~ /^ST\(\d+\)$/) {
 469 -               eval "print qq\a$expr\a";
 470 +           else {
 471 +               eval "XS_process qq\a$expr\a";
 472                 warn $@   if  $@;
 473                 print "\tSvSETMAGIC($arg);\n" if $do_setmagic;
 474             }