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.01';
  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      '' => sub { '&PL_sv_yes' },
  51      SV => sub {"SvREFCNT_inc($_[0])"},
  52      );
  53
  54 %type_to_C_value =
  55     (
  56      YES => sub {},
  57      NO => sub {},
  58      '' => sub {},
  59      );
  60
  61 sub type_to_C_value {
  62     my ($self, $type) = @_;
  63     return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
  64 }
  65
  66 # TODO - figure out if there is a clean way for the type_to_sv code to
  67 # attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add
  68 # SvREFCNT_inc
  69 %type_is_a_problem =
  70     (
  71      # The documentation says *mortal SV*, but we now need a non-mortal copy.
  72      SV => 1,
  73      );
  74
  75 %type_temporary =
  76     (
  77      SV => ['SV *'],
  78      PV => ['const char *'],
  79      PVN => ['const char *', 'STRLEN'],
  80      );
  81 $type_temporary{$_} = [$_] foreach qw(IV UV NV);
  82
  83 while (my ($type, $value) = each %XS_TypeSet) {
  84     $type_num_args{$type}
  85         = defined $value ? ref $value ? scalar @$value : 1 : 0;
  86 }
  87 $type_num_args{''} = 0;
  88
  89 sub partition_names {
  90     my ($self, $default_type, @items) = @_;
  91     my (%found, @notfound, @trouble);
  92
  93     while (my $item = shift @items) {
  94         my $default = delete $item->{default};
  95         if ($default) {
  96             # If we find a default value, convert it into a regular item and
  97             # append it to the queue of items to process
  98             my $default_item = {%$item};
  99             $default_item->{invert_macro} = 1;
 100             $default_item->{pre} = delete $item->{def_pre};
 101             $default_item->{post} = delete $item->{def_post};
 102             $default_item->{type} = shift @$default;
 103             $default_item->{value} = $default;
 104             push @items, $default_item;
 105         } else {
 106             # It can be "not found" unless it's the default (invert the macro)
 107             # or the "macro" is an empty string (ie no macro)
 108             push @notfound, $item unless $item->{invert_macro}
 109                 or !$self->macro_to_ifdef($self->macro_from_name($item));
 110         }
 111
 112         if ($item->{pre} or $item->{post} or $item->{not_constant}
 113             or $type_is_a_problem{$item->{type}}) {
 114             push @trouble, $item;
 115         } else {
 116             push @{$found{$item->{type}}}, $item;
 117         }
 118     }
 119     # use Data::Dumper; print Dumper \%found;
 120     (\%found, \@notfound, \@trouble);
 121 }
 122
 123 sub boottime_iterator {
 124     my ($self, $type, $iterator, $hash, $subname) = @_;
 125     my $extractor = $type_from_struct{$type};
 126     die "Can't find extractor code for type $type"
 127         unless defined $extractor;
 128     my $generator = $type_to_sv{$type};
 129     die "Can't find generator code for type $type"
 130         unless defined $generator;
 131
 132     my $athx = $self->C_constant_prefix_param();
 133
 134     return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
 135         while ($iterator->name) {
 136             $subname($athx $hash, $iterator->name,
 137                                 $iterator->namelen, %s);
 138             ++$iterator;
 139         }
 140 EOBOOT
 141 }
 142
 143 sub name_len_value_macro {
 144     my ($self, $item) = @_;
 145     my $name = $item->{name};
 146     my $value = $item->{value};
 147     $value = $item->{name} unless defined $value;
 148
 149     my $namelen = length $name;
 150     if ($name =~ tr/\0-\377// != $namelen) {
 151         # the hash API signals UTF-8 by passing the length negated.
 152         utf8::encode($name);
 153         $namelen = -length $name;
 154     }
 155     $name = C_stringify($name);
 156
 157     my $macro = $self->macro_from_name($item);
 158     ($name, $namelen, $value, $macro);
 159 }
 160
 161 sub WriteConstants {
 162     my $self = shift;
 163     my $ARGS = shift;
 164
 165     my ($c_fh, $xs_fh, $c_subname, $xs_subname, $default_type, $package)
 166         = @{$ARGS}{qw(c_fh xs_fh c_subname xs_subname default_type package)};
 167
 168     $xs_subname ||= 'constant';
 169
 170     croak("Package name '$package' contains % characters") if $package =~ /%/;
 171
 172     # All the types we see
 173     my $what = {};
 174     # A hash to lookup items with.
 175     my $items = {};
 176
 177     my @items = $self->normalise_items ({disable_utf8_duplication => 1},
 178                                         $default_type, $what, $items, @_);
 179
 180     # Partition the values by type. Also include any defaults in here
 181     # Everything that doesn't have a default needs alternative code for
 182     # "I'm missing"
 183     # And everything that has pre or post code ends up in a private block
 184     my ($found, $notfound, $trouble)
 185         = $self->partition_names($default_type, @items);
 186
 187     my $pthx = $self->C_constant_prefix_param_defintion();
 188     my $athx = $self->C_constant_prefix_param();
 189     my $symbol_table = C_stringify($package) . '::';
 190
 191     print $c_fh $self->header(), <<"EOADD";
 192 void ${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
 193     SV **sv = hv_fetch(hash, name, namelen, TRUE);
 194     if (!sv) {
 195         Perl_croak($athx "Couldn't add key '%s' to %%%s::", name, "$package");
 196     }
 197     if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) {
 198         /* Someone has been here before us - have to make a real sub.  */
 199         newCONSTSUB(hash, name, value);
 200     } else {
 201         SvUPGRADE(*sv, SVt_RV);
 202         SvRV_set(*sv, value);
 203         SvROK_on(*sv);
 204     }
 205 }
 206
 207 static HV *${c_subname}_missing = NULL;
 208
 209 EOADD
 210
 211     print $xs_fh <<"EOBOOT";
 212 BOOT:
 213   {
 214 #ifdef dTHX
 215     dTHX;
 216 #endif
 217     HV *symbol_table = get_hv("$symbol_table", TRUE);
 218 EOBOOT
 219
 220     my %iterator;
 221
 222     $found->{''}
 223         = [map {{%$_, type=>'', invert_macro => 1}} @$notfound];
 224
 225     foreach my $type (sort keys %$found) {
 226         my $struct = $type_to_struct{$type};
 227         my $type_to_value = $self->type_to_C_value($type);
 228         my $number_of_args = $type_num_args{$type};
 229         die "Can't find structure definition for type $type"
 230             unless defined $struct;
 231
 232         my $struct_type = $type ? lc($type) . '_s' : 'notfound_s';
 233         print $c_fh "struct $struct_type $struct;\n";
 234
 235         my $array_name = 'values_for_' . ($type ? lc $type : 'notfound');
 236         print $xs_fh <<"EOBOOT";
 237
 238     static const struct $struct_type $array_name\[] =
 239       {
 240 EOBOOT
 241
 242
 243         foreach my $item (@{$found->{$type}}) {
 244             my ($name, $namelen, $value, $macro)
 245                  = $self->name_len_value_macro($item);
 246
 247             my $ifdef = $self->macro_to_ifdef($macro);
 248             if (!$ifdef && $item->{invert_macro}) {
 249                 carp("Attempting to supply a default for '$name' which has no conditional macro");
 250                 next;
 251             }
 252             print $xs_fh $ifdef;
 253             if ($item->{invert_macro}) {
 254                 print $xs_fh
 255                     "        /* This is the default value: */\n" if $type;
 256                 print $xs_fh "#else\n";
 257             }
 258             print $xs_fh "        { ", join (', ', "\"$name\"", $namelen,
 259                                              &$type_to_value($value)), " },\n",
 260                                                  $self->macro_to_endif($macro);
 261         }
 262
 263
 264     # Terminate the list with a NULL
 265         print $xs_fh "        { NULL, 0", (", 0" x $number_of_args), " } };\n";
 266
 267         $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound');
 268
 269         print $xs_fh <<"EOBOOT";
 270         const struct $struct_type *$iterator{$type} = $array_name;
 271
 272 EOBOOT
 273     }
 274
 275     delete $found->{''};
 276     foreach my $type (sort keys %$found) {
 277         print $xs_fh $self->boottime_iterator($type, $iterator{$type},
 278                                               'symbol_table',
 279                                               "${c_subname}_add_symbol");
 280     }
 281     print $xs_fh <<"EOBOOT";
 282
 283         ${c_subname}_missing = newHV();
 284         while (value_for_notfound->name) {
 285             if (!hv_store(${c_subname}_missing, value_for_notfound->name,
 286                           value_for_notfound->namelen, &PL_sv_yes, 0))
 287                 Perl_croak($athx "Couldn't add key '%s' to missing_hash",
 288                            value_for_notfound->name);
 289             ++value_for_notfound;
 290         }
 291 EOBOOT
 292
 293     foreach my $item (@$trouble) {
 294         my ($name, $namelen, $value, $macro)
 295             = $self->name_len_value_macro($item);
 296         my $ifdef = $self->macro_to_ifdef($macro);
 297         my $type = $item->{type};
 298         my $type_to_value = $self->type_to_C_value($type);
 299
 300         print $xs_fh $ifdef;
 301         if ($item->{invert_macro}) {
 302             print $xs_fh
 303                  "        /* This is the default value: */\n" if $type;
 304             print $xs_fh "#else\n";
 305         }
 306         my $generator = $type_to_sv{$type};
 307         die "Can't find generator code for type $type"
 308             unless defined $generator;
 309
 310         print $xs_fh "        {\n";
 311         # We need to use a temporary value because some really troublesome
 312         # items use C pre processor directives in their values, and in turn
 313         # these don't fit nicely in the macro-ised generator functions
 314         my $counter = 0;
 315         printf $xs_fh "            %s temp%d;\n", $_, $counter++
 316             foreach @{$type_temporary{$type}};
 317
 318         print $xs_fh "            $item->{pre}\n" if $item->{pre};
 319
 320         # And because the code in pre might be both declarations and
 321         # statements, we can't declare and assign to the temporaries in one.
 322         $counter = 0;
 323         printf $xs_fh "            temp%d = %s;\n", $counter++, $_
 324             foreach &$type_to_value($value);
 325
 326         my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1;
 327         printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames);
 328             ${c_subname}_add_symbol($athx symbol_table, "%s",
 329                                     $namelen, %s);
 330 EOBOOT
 331         print $xs_fh "        $item->{post}\n" if $item->{post};
 332         print $xs_fh "        }\n";
 333
 334         print $xs_fh $self->macro_to_endif($macro);
 335     }
 336
 337     print $xs_fh <<EOCONSTANT
 338   }
 339
 340 void
 341 $xs_subname(sv)
 342     PREINIT:
 343         STRLEN          len;
 344     INPUT:
 345         SV *            sv;
 346         const char *    s = SvPV(sv, len);
 347     PPCODE:
 348         if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -len : len)) {
 349             sv = newSVpvf("Your vendor has not defined $package macro %" SVf
 350                           ", used", sv);
 351         } else {
 352             sv = newSVpvf("%" SVf " is not a valid $package macro", sv);
 353         }
 354         PUSHs(sv_2mortal(sv));
 355 EOCONSTANT
 356 }
 357
 358 1;