[Summary view] [Print] [Text view]

   1  package ExtUtils::Constant::ProxySubs;
   2  
   3  use strict;
   4  use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
   5          %type_to_C_value %type_is_a_problem %type_num_args
   6          %type_temporary);
   7  use Carp;
   8  require ExtUtils::Constant::XS;
   9  use ExtUtils::Constant::Utils qw(C_stringify);
  10  use ExtUtils::Constant::XS qw(%XS_TypeSet);
  11  
  12  $VERSION = '0.05';
  13  @ISA = 'ExtUtils::Constant::XS';
  14  
  15  %type_to_struct =
  16      (
  17       IV => '{const char *name; I32 namelen; IV value;}',
  18       NV => '{const char *name; I32 namelen; NV value;}',
  19       UV => '{const char *name; I32 namelen; UV value;}',
  20       PV => '{const char *name; I32 namelen; const char *value;}',
  21       PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}',
  22       YES => '{const char *name; I32 namelen;}',
  23       NO => '{const char *name; I32 namelen;}',
  24       UNDEF => '{const char *name; I32 namelen;}',
  25       '' => '{const char *name; I32 namelen;} ',
  26       );
  27  
  28  %type_from_struct =
  29      (
  30       IV => sub { $_[0] . '->value' },
  31       NV => sub { $_[0] . '->value' },
  32       UV => sub { $_[0] . '->value' },
  33       PV => sub { $_[0] . '->value' },
  34       PVN => sub { $_[0] . '->value', $_[0] . '->len' },
  35       YES => sub {},
  36       NO => sub {},
  37       UNDEF => sub {},
  38       '' => sub {},
  39      );
  40  
  41  %type_to_sv = 
  42      (
  43       IV => sub { "newSViv($_[0])" },
  44       NV => sub { "newSVnv($_[0])" },
  45       UV => sub { "newSVuv($_[0])" },
  46       PV => sub { "newSVpv($_[0], 0)" },
  47       PVN => sub { "newSVpvn($_[0], $_[1])" },
  48       YES => sub { '&PL_sv_yes' },
  49       NO => sub { '&PL_sv_no' },
  50       UNDEF => sub { '&PL_sv_undef' },
  51       '' => sub { '&PL_sv_yes' },
  52       SV => sub {"SvREFCNT_inc($_[0])"},
  53       );
  54  
  55  %type_to_C_value = 
  56      (
  57       YES => sub {},
  58       NO => sub {},
  59       UNDEF => sub {},
  60       '' => sub {},
  61       );
  62  
  63  sub type_to_C_value {
  64      my ($self, $type) = @_;
  65      return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
  66  }
  67  
  68  # TODO - figure out if there is a clean way for the type_to_sv code to
  69  # attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
  70  # SvREFCNT_inc
  71  %type_is_a_problem =
  72      (
  73       # The documentation says *mortal SV*, but we now need a non-mortal copy.
  74       SV => 1,
  75       );
  76  
  77  %type_temporary =
  78      (
  79       SV => ['SV *'],
  80       PV => ['const char *'],
  81       PVN => ['const char *', 'STRLEN'],
  82       );
  83  $type_temporary{$_} = [$_] foreach qw(IV UV NV);
  84       
  85  while (my ($type, $value) = each %XS_TypeSet) {
  86      $type_num_args{$type}
  87      = defined $value ? ref $value ? scalar @$value : 1 : 0;
  88  }
  89  $type_num_args{''} = 0;
  90  
  91  sub partition_names {
  92      my ($self, $default_type, @items) = @_;
  93      my (%found, @notfound, @trouble);
  94  
  95      while (my $item = shift @items) {
  96      my $default = delete $item->{default};
  97      if ($default) {
  98          # If we find a default value, convert it into a regular item and
  99          # append it to the queue of items to process
 100          my $default_item = {%$item};
 101          $default_item->{invert_macro} = 1;
 102          $default_item->{pre} = delete $item->{def_pre};
 103          $default_item->{post} = delete $item->{def_post};
 104          $default_item->{type} = shift @$default;
 105          $default_item->{value} = $default;
 106          push @items, $default_item;
 107      } else {
 108          # It can be "not found" unless it's the default (invert the macro)
 109          # or the "macro" is an empty string (ie no macro)
 110          push @notfound, $item unless $item->{invert_macro}
 111          or !$self->macro_to_ifdef($self->macro_from_item($item));
 112      }
 113  
 114      if ($item->{pre} or $item->{post} or $item->{not_constant}
 115          or $type_is_a_problem{$item->{type}}) {
 116          push @trouble, $item;
 117      } else {
 118          push @{$found{$item->{type}}}, $item;
 119      }
 120      }
 121      # use Data::Dumper; print Dumper \%found;
 122      (\%found, \@notfound, \@trouble);
 123  }
 124  
 125  sub boottime_iterator {
 126      my ($self, $type, $iterator, $hash, $subname) = @_;
 127      my $extractor = $type_from_struct{$type};
 128      die "Can't find extractor code for type $type"
 129      unless defined $extractor;
 130      my $generator = $type_to_sv{$type};
 131      die "Can't find generator code for type $type"
 132      unless defined $generator;
 133  
 134      my $athx = $self->C_constant_prefix_param();
 135  
 136      return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
 137          while ($iterator->name) {
 138          $subname($athx $hash, $iterator->name,
 139                  $iterator->namelen, %s);
 140          ++$iterator;
 141      }
 142  EOBOOT
 143  }
 144  
 145  sub name_len_value_macro {
 146      my ($self, $item) = @_;
 147      my $name = $item->{name};
 148      my $value = $item->{value};
 149      $value = $item->{name} unless defined $value;
 150  
 151      my $namelen = length $name;
 152      if ($name =~ tr/\0-\377// != $namelen) {
 153      # the hash API signals UTF-8 by passing the length negated.
 154      utf8::encode($name);
 155      $namelen = -length $name;
 156      }
 157      $name = C_stringify($name);
 158  
 159      my $macro = $self->macro_from_item($item);
 160      ($name, $namelen, $value, $macro);
 161  }
 162  
 163  sub WriteConstants {
 164      my $self = shift;
 165      my $ARGS = {@_};
 166  
 167      my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
 168      = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME XS_SUBNAME DEFAULT_TYPE NAME)};
 169  
 170      my $options = $ARGS->{PROXYSUBS};
 171      $options = {} unless ref $options;
 172      my $explosives = $options->{croak_on_read};
 173  
 174      $xs_subname ||= 'constant';
 175  
 176      # If anyone is insane enough to suggest a package name containing %
 177      my $package_sprintf_safe = $package;
 178      $package_sprintf_safe =~ s/%/%%/g;
 179  
 180      # All the types we see
 181      my $what = {};
 182      # A hash to lookup items with.
 183      my $items = {};
 184  
 185      my @items = $self->normalise_items ({disable_utf8_duplication => 1},
 186                      $default_type, $what, $items,
 187                      @{$ARGS->{NAMES}});
 188  
 189      # Partition the values by type. Also include any defaults in here
 190      # Everything that doesn't have a default needs alternative code for
 191      # "I'm missing"
 192      # And everything that has pre or post code ends up in a private block
 193      my ($found, $notfound, $trouble)
 194      = $self->partition_names($default_type, @items);
 195  
 196      my $pthx = $self->C_constant_prefix_param_defintion();
 197      my $athx = $self->C_constant_prefix_param();
 198      my $symbol_table = C_stringify($package) . '::';
 199  
 200      print $c_fh $self->header(), <<"EOADD";
 201  static void
 202  $c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
 203      SV **sv = hv_fetch(hash, name, namelen, TRUE);
 204      if (!sv) {
 205          Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
 206             name);
 207      }
 208      if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) {
 209      /* Someone has been here before us - have to make a real sub.  */
 210      newCONSTSUB(hash, name, value);
 211      } else {
 212      SvUPGRADE(*sv, SVt_RV);
 213      SvRV_set(*sv, value);
 214      SvROK_on(*sv);
 215      SvREADONLY_on(value);
 216      }
 217  }
 218  
 219  EOADD
 220  
 221      print $c_fh $explosives ? <<"EXPLODE" : "\n";
 222  
 223  static int
 224  Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
 225  {
 226      PERL_UNUSED_ARG(mg);
 227      Perl_croak(aTHX_
 228             "Your vendor has not defined $package_sprintf_safe macro %"SVf
 229             " used", sv);
 230      NORETURN_FUNCTION_END;
 231  }
 232  
 233  static MGVTBL not_defined_vtbl = {
 234   Im_sorry_Dave, /* get - I'm afraid I can't do that */
 235   Im_sorry_Dave, /* set */
 236   0, /* len */
 237   0, /* clear */
 238   0, /* free */
 239   0, /* copy */
 240   0, /* dup */
 241  };
 242  
 243  EXPLODE
 244  
 245  {
 246      my $key = $symbol_table;
 247      # Just seems tidier (and slightly more space efficient) not to have keys
 248      # such as Fcntl::
 249      $key =~ s/::$//;
 250      my $key_len = length $key;
 251  
 252      print $c_fh <<"MISSING";
 253  
 254  #ifndef SYMBIAN
 255  
 256  /* Store a hash of all symbols missing from the package. To avoid trampling on
 257     the package namespace (uninvited) put each package's hash in our namespace.
 258     To avoid creating lots of typeblogs and symbol tables for sub-packages, put
 259     each package's hash into one hash in our namespace.  */
 260  
 261  static HV *
 262  get_missing_hash(pTHX) {
 263      HV *const parent
 264      = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI);
 265      /* We could make a hash of hashes directly, but this would confuse anything
 266      at Perl space that looks at us, and as we're visible in Perl space,
 267      best to play nice. */
 268      SV *const *const ref
 269      = hv_fetch(parent, "$key", $key_len, TRUE);
 270      HV *new_hv;
 271  
 272      if (!ref)
 273      return NULL;
 274  
 275      if (SvROK(*ref))
 276      return (HV*) SvRV(*ref);
 277  
 278      new_hv = newHV();
 279      SvUPGRADE(*ref, SVt_RV);
 280      SvRV_set(*ref, (SV *)new_hv);
 281      SvROK_on(*ref);
 282      return new_hv;
 283  }
 284  
 285  #endif
 286  
 287  MISSING
 288  
 289  }
 290  
 291      print $xs_fh <<"EOBOOT";
 292  BOOT:
 293    {
 294  #ifdef dTHX
 295      dTHX;
 296  #endif
 297      HV *symbol_table = get_hv("$symbol_table", TRUE);
 298  #ifndef SYMBIAN
 299      HV *$c_subname}_missing;
 300  #endif
 301  EOBOOT
 302  
 303      my %iterator;
 304  
 305      $found->{''}
 306          = [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
 307  
 308      foreach my $type (sort keys %$found) {
 309      my $struct = $type_to_struct{$type};
 310      my $type_to_value = $self->type_to_C_value($type);
 311      my $number_of_args = $type_num_args{$type};
 312      die "Can't find structure definition for type $type"
 313          unless defined $struct;
 314  
 315      my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
 316      print $c_fh "struct $struct_type $struct;\n";
 317  
 318      my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
 319      print $xs_fh <<"EOBOOT";
 320  
 321      static const struct $struct_type $array_name\[] =
 322        {
 323  EOBOOT
 324  
 325  
 326      foreach my $item (@{$found->{$type}}) {
 327              my ($name, $namelen, $value, $macro)
 328                   = $self->name_len_value_macro($item);
 329  
 330          my $ifdef = $self->macro_to_ifdef($macro);
 331          if (!$ifdef && $item->{invert_macro}) {
 332          carp("Attempting to supply a default for '$name' which has no conditional macro");
 333          next;
 334          }
 335          print $xs_fh $ifdef;
 336          if ($item->{invert_macro}) {
 337          print $xs_fh
 338              "        /* This is the default value: */\n" if $type;
 339          print $xs_fh "#else\n";
 340          }
 341          print $xs_fh "        { ", join (', ', "\"$name\"", $namelen,
 342                           &$type_to_value($value)), " },\n",
 343                           $self->macro_to_endif($macro);
 344      }
 345  
 346  
 347      # Terminate the list with a NULL
 348      print $xs_fh "        { NULL, 0", (", 0" x $number_of_args), " } };\n";
 349  
 350      $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
 351  
 352      print $xs_fh <<"EOBOOT";
 353      const struct $struct_type *$iterator{$type} = $array_name;
 354  EOBOOT
 355      }
 356  
 357      delete $found->{''};
 358  
 359      print $xs_fh <<"EOBOOT";
 360  #ifndef SYMBIAN
 361      $c_subname}_missing = get_missing_hash(aTHX);
 362  #endif
 363  EOBOOT
 364  
 365      my $add_symbol_subname = $c_subname . '_add_symbol';
 366      foreach my $type (sort keys %$found) {
 367      print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 
 368                            'symbol_table',
 369                            $add_symbol_subname);
 370      }
 371  
 372      print $xs_fh <<"EOBOOT";
 373      while (value_for_notfound->name) {
 374  EOBOOT
 375  
 376      print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
 377          SV *tripwire = newSV(0);
 378          
 379          sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_defined_vtbl, 0, 0);
 380          SvPV_set(tripwire, (char *)value_for_notfound->name);
 381          if(value_for_notfound->namelen >= 0) {
 382          SvCUR_set(tripwire, value_for_notfound->namelen);
 383          } else {
 384          SvCUR_set(tripwire, -value_for_notfound->namelen);
 385          SvUTF8_on(tripwire);
 386          }
 387          SvPOKp_on(tripwire);
 388          SvREADONLY_on(tripwire);
 389          assert(SvLEN(tripwire) == 0);
 390  
 391          $add_symbol_subname($athx symbol_table, value_for_notfound->name,
 392                  value_for_notfound->namelen, tripwire);
 393  EXPLODE
 394  
 395          /* Need to add prototypes, else parsing will vary by platform.  */
 396          SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
 397                     value_for_notfound->namelen, TRUE);
 398          if (!sv) {
 399          Perl_croak($athx
 400                 "Couldn't add key '%s' to %%$package_sprintf_safe\::",
 401                 value_for_notfound->name);
 402          }
 403          if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) {
 404          /* Nothing was here before, so mark a prototype of ""  */
 405          sv_setpvn(*sv, "", 0);
 406          } else if (SvPOK(*sv) && SvCUR(*sv) == 0) {
 407          /* There is already a prototype of "" - do nothing  */
 408          } else {
 409          /* Someone has been here before us - have to make a real
 410             typeglob.  */
 411          /* It turns out to be incredibly hard to deal with all the
 412             corner cases of sub foo (); and reporting errors correctly,
 413             so lets cheat a bit.  Start with a constant subroutine  */
 414          CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name,
 415                       &PL_sv_yes);
 416          /* and then turn it into a non constant declaration only.  */
 417          SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
 418          CvCONST_off(cv);
 419          CvXSUB(cv) = NULL;
 420          CvXSUBANY(cv).any_ptr = NULL;
 421          }
 422  #ifndef SYMBIAN
 423          if (!hv_store($c_subname}_missing, value_for_notfound->name,
 424                value_for_notfound->namelen, &PL_sv_yes, 0))
 425          Perl_croak($athx "Couldn't add key '%s' to missing_hash",
 426                 value_for_notfound->name);
 427  #endif
 428  DONT
 429  
 430      print $xs_fh <<"EOBOOT";
 431  
 432          ++value_for_notfound;
 433      }
 434  EOBOOT
 435  
 436      foreach my $item (@$trouble) {
 437          my ($name, $namelen, $value, $macro)
 438          = $self->name_len_value_macro($item);
 439          my $ifdef = $self->macro_to_ifdef($macro);
 440          my $type = $item->{type};
 441      my $type_to_value = $self->type_to_C_value($type);
 442  
 443          print $xs_fh $ifdef;
 444      if ($item->{invert_macro}) {
 445          print $xs_fh
 446           "        /* This is the default value: */\n" if $type;
 447          print $xs_fh "#else\n";
 448      }
 449      my $generator = $type_to_sv{$type};
 450      die "Can't find generator code for type $type"
 451          unless defined $generator;
 452  
 453      print $xs_fh "        {\n";
 454      # We need to use a temporary value because some really troublesome
 455      # items use C pre processor directives in their values, and in turn
 456      # these don't fit nicely in the macro-ised generator functions
 457      my $counter = 0;
 458      printf $xs_fh "            %s temp%d;\n", $_, $counter++
 459          foreach @{$type_temporary{$type}};
 460  
 461      print $xs_fh "            $item->{pre}\n" if $item->{pre};
 462  
 463      # And because the code in pre might be both declarations and
 464      # statements, we can't declare and assign to the temporaries in one.
 465      $counter = 0;
 466      printf $xs_fh "            temp%d = %s;\n", $counter++, $_
 467          foreach &$type_to_value($value);
 468  
 469      my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
 470      printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
 471          $c_subname}_add_symbol($athx symbol_table, "%s",
 472                      $namelen, %s);
 473  EOBOOT
 474      print $xs_fh "        $item->{post}\n" if $item->{post};
 475      print $xs_fh "        }\n";
 476  
 477          print $xs_fh $self->macro_to_endif($macro);
 478      }
 479  
 480      print $xs_fh <<EOBOOT;
 481      /* As we've been creating subroutines, we better invalidate any cached
 482         methods  */
 483      ++PL_sub_generation;
 484    }
 485  EOBOOT
 486  
 487      print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
 488  
 489  void
 490  $xs_subname(sv)
 491      INPUT:
 492      SV *        sv;
 493      PPCODE:
 494      sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
 495                ", used", sv);
 496          PUSHs(sv_2mortal(sv));
 497  EXPLODE
 498  
 499  void
 500  $xs_subname(sv)
 501      PREINIT:
 502      STRLEN        len;
 503      INPUT:
 504      SV *        sv;
 505          const char *    s = SvPV(sv, len);
 506      PPCODE:
 507  #ifdef SYMBIAN
 508      sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
 509  #else
 510      HV *$c_subname}_missing = get_missing_hash(aTHX);
 511      if (hv_exists($c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
 512          sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
 513                ", used", sv);
 514      } else {
 515          sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
 516                sv);
 517      }
 518  #endif
 519      PUSHs(sv_2mortal(sv));
 520  DONT
 521  
 522  }
 523  
 524  1;