lib/ExtUtils/Constant/ProxySubs.pm

   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;