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.04';
  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     print $xs_fh <<"EOBOOT";
 246 BOOT:
 247   {
 248 #ifdef dTHX
 249     dTHX;
 250 #endif
 251     HV *symbol_table = get_hv("$symbol_table", TRUE);
 252 #ifndef SYMBIAN
 253     /* When we create the 'missing' hash, it generates a 'used only once'
 254      * warning.  Therefore, turn off warnings while we do this.
 255      */
 256     HV *${c_subname}_missing;
 257     {
 258         const bool warn_tmp = PL_dowarn;
 259         PL_dowarn = 0;
 260         ${c_subname}_missing = get_hv("${symbol_table}${c_subname}_M!55!NG", TRUE);
 261         PL_dowarn = warn_tmp;
 262     }
 263 #endif
 264 EOBOOT
 265
 266     my %iterator;
 267
 268     $found->{''}
 269         = [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
 270
 271     foreach my $type (sort keys %$found) {
 272         my $struct = $type_to_struct{$type};
 273         my $type_to_value = $self->type_to_C_value($type);
 274         my $number_of_args = $type_num_args{$type};
 275         die "Can't find structure definition for type $type"
 276             unless defined $struct;
 277
 278         my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
 279         print $c_fh "struct $struct_type $struct;\n";
 280
 281         my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
 282         print $xs_fh <<"EOBOOT";
 283
 284     static const struct $struct_type $array_name\[] =
 285       {
 286 EOBOOT
 287
 288
 289         foreach my $item (@{$found->{$type}}) {
 290             my ($name, $namelen, $value, $macro)
 291                  = $self->name_len_value_macro($item);
 292
 293             my $ifdef = $self->macro_to_ifdef($macro);
 294             if (!$ifdef && $item->{invert_macro}) {
 295                 carp("Attempting to supply a default for '$name' which has no conditional macro");
 296                 next;
 297             }
 298             print $xs_fh $ifdef;
 299             if ($item->{invert_macro}) {
 300                 print $xs_fh
 301                     "        /* This is the default value: */\n" if $type;
 302                 print $xs_fh "#else\n";
 303             }
 304             print $xs_fh "        { ", join (', ', "\"$name\"", $namelen,
 305                                              &$type_to_value($value)), " },\n",
 306                                                  $self->macro_to_endif($macro);
 307         }
 308
 309
 310     # Terminate the list with a NULL
 311         print $xs_fh "        { NULL, 0", (", 0" x $number_of_args), " } };\n";
 312
 313         $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
 314
 315         print $xs_fh <<"EOBOOT";
 316         const struct $struct_type *$iterator{$type} = $array_name;
 317
 318 EOBOOT
 319     }
 320
 321     delete $found->{''};
 322
 323     my $add_symbol_subname = $c_subname . '_add_symbol';
 324     foreach my $type (sort keys %$found) {
 325         print $xs_fh $self->boottime_iterator($type, $iterator{$type},
 326                                               'symbol_table',
 327                                               $add_symbol_subname);
 328     }
 329
 330     print $xs_fh <<"EOBOOT";
 331         while (value_for_notfound->name) {
 332 EOBOOT
 333
 334     print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
 335             SV *tripwire = newSV(0);
 336
 337             sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_defined_vtbl, 0, 0);
 338             SvPV_set(tripwire, (char *)value_for_notfound->name);
 339             if(value_for_notfound->namelen >= 0) {
 340                 SvCUR_set(tripwire, value_for_notfound->namelen);
 341             } else {
 342                 SvCUR_set(tripwire, -value_for_notfound->namelen);
 343                 SvUTF8_on(tripwire);
 344             }
 345             SvPOKp_on(tripwire);
 346             SvREADONLY_on(tripwire);
 347             assert(SvLEN(tripwire) == 0);
 348
 349             $add_symbol_subname($athx symbol_table, value_for_notfound->name,
 350                                 value_for_notfound->namelen, tripwire);
 351 EXPLODE
 352
 353             /* Need to add prototypes, else parsing will vary by platform.  */
 354             SV **sv = hv_fetch(symbol_table, value_for_notfound->name,
 355                                value_for_notfound->namelen, TRUE);
 356             if (!sv) {
 357                 Perl_croak($athx
 358                            "Couldn't add key '%s' to %%$package_sprintf_safe\::",
 359                            value_for_notfound->name);
 360             }
 361             if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) {
 362                 /* Nothing was here before, so mark a prototype of ""  */
 363                 sv_setpvn(*sv, "", 0);
 364             } else if (SvPOK(*sv) && SvCUR(*sv) == 0) {
 365                 /* There is already a prototype of "" - do nothing  */
 366             } else {
 367                 /* Someone has been here before us - have to make a real
 368                    typeglob.  */
 369                 /* It turns out to be incredibly hard to deal with all the
 370                    corner cases of sub foo (); and reporting errors correctly,
 371                    so lets cheat a bit.  Start with a constant subroutine  */
 372                 CV *cv = newCONSTSUB(symbol_table, value_for_notfound->name,
 373                                      &PL_sv_yes);
 374                 /* and then turn it into a non constant declaration only.  */
 375                 SvREFCNT_dec(CvXSUBANY(cv).any_ptr);
 376                 CvCONST_off(cv);
 377                 CvXSUB(cv) = NULL;
 378                 CvXSUBANY(cv).any_ptr = NULL;
 379             }
 380 #ifndef SYMBIAN
 381             if (!hv_store(${c_subname}_missing, value_for_notfound->name,
 382                           value_for_notfound->namelen, &PL_sv_yes, 0))
 383                 Perl_croak($athx "Couldn't add key '%s' to missing_hash",
 384                            value_for_notfound->name);
 385 #endif
 386 DONT
 387
 388     print $xs_fh <<"EOBOOT";
 389
 390             ++value_for_notfound;
 391         }
 392 EOBOOT
 393
 394     foreach my $item (@$trouble) {
 395         my ($name, $namelen, $value, $macro)
 396             = $self->name_len_value_macro($item);
 397         my $ifdef = $self->macro_to_ifdef($macro);
 398         my $type = $item->{type};
 399         my $type_to_value = $self->type_to_C_value($type);
 400
 401         print $xs_fh $ifdef;
 402         if ($item->{invert_macro}) {
 403             print $xs_fh
 404                  "        /* This is the default value: */\n" if $type;
 405             print $xs_fh "#else\n";
 406         }
 407         my $generator = $type_to_sv{$type};
 408         die "Can't find generator code for type $type"
 409             unless defined $generator;
 410
 411         print $xs_fh "        {\n";
 412         # We need to use a temporary value because some really troublesome
 413         # items use C pre processor directives in their values, and in turn
 414         # these don't fit nicely in the macro-ised generator functions
 415         my $counter = 0;
 416         printf $xs_fh "            %s temp%d;\n", $_, $counter++
 417             foreach @{$type_temporary{$type}};
 418
 419         print $xs_fh "            $item->{pre}\n" if $item->{pre};
 420
 421         # And because the code in pre might be both declarations and
 422         # statements, we can't declare and assign to the temporaries in one.
 423         $counter = 0;
 424         printf $xs_fh "            temp%d = %s;\n", $counter++, $_
 425             foreach &$type_to_value($value);
 426
 427         my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
 428         printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
 429             ${c_subname}_add_symbol($athx symbol_table, "%s",
 430                                     $namelen, %s);
 431 EOBOOT
 432         print $xs_fh "        $item->{post}\n" if $item->{post};
 433         print $xs_fh "        }\n";
 434
 435         print $xs_fh $self->macro_to_endif($macro);
 436     }
 437
 438     print $xs_fh <<EOBOOT;
 439     /* As we've been creating subroutines, we better invalidate any cached
 440        methods  */
 441     ++PL_sub_generation;
 442   }
 443 EOBOOT
 444
 445     print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
 446
 447 void
 448 $xs_subname(sv)
 449     INPUT:
 450         SV *            sv;
 451     PPCODE:
 452         sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
 453                           ", used", sv);
 454         PUSHs(sv_2mortal(sv));
 455 EXPLODE
 456
 457 void
 458 $xs_subname(sv)
 459     PREINIT:
 460         STRLEN          len;
 461     INPUT:
 462         SV *            sv;
 463         const char *    s = SvPV(sv, len);
 464     PPCODE:
 465 #ifdef SYMBIAN
 466         sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv);
 467 #else
 468         HV *${c_subname}_missing = get_hv("${c_subname}_M!55!NG", FALSE);
 469         if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) {
 470             sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
 471                           ", used", sv);
 472         } else {
 473             sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
 474                           sv);
 475         }
 476 #endif
 477         PUSHs(sv_2mortal(sv));
 478 DONT
 479
 480 }
 481
 482 1;