1b39c5158Smillertpackage ExtUtils::Constant::ProxySubs; 2b39c5158Smillert 3b39c5158Smillertuse strict; 4b39c5158Smillertuse vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv 5b39c5158Smillert %type_to_C_value %type_is_a_problem %type_num_args 6b39c5158Smillert %type_temporary); 7b39c5158Smillertuse Carp; 8b39c5158Smillertrequire ExtUtils::Constant::XS; 9b39c5158Smillertuse ExtUtils::Constant::Utils qw(C_stringify); 10b39c5158Smillertuse ExtUtils::Constant::XS qw(%XS_TypeSet); 11b39c5158Smillert 12*5759b3d2Safresh1$VERSION = '0.09'; 13b39c5158Smillert@ISA = 'ExtUtils::Constant::XS'; 14b39c5158Smillert 15b39c5158Smillert%type_to_struct = 16b39c5158Smillert ( 17b39c5158Smillert IV => '{const char *name; I32 namelen; IV value;}', 18b39c5158Smillert NV => '{const char *name; I32 namelen; NV value;}', 19b39c5158Smillert UV => '{const char *name; I32 namelen; UV value;}', 20b39c5158Smillert PV => '{const char *name; I32 namelen; const char *value;}', 21b39c5158Smillert PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}', 22b39c5158Smillert YES => '{const char *name; I32 namelen;}', 23b39c5158Smillert NO => '{const char *name; I32 namelen;}', 24b39c5158Smillert UNDEF => '{const char *name; I32 namelen;}', 25b39c5158Smillert '' => '{const char *name; I32 namelen;} ', 26b39c5158Smillert ); 27b39c5158Smillert 28b39c5158Smillert%type_from_struct = 29b39c5158Smillert ( 30b39c5158Smillert IV => sub { $_[0] . '->value' }, 31b39c5158Smillert NV => sub { $_[0] . '->value' }, 32b39c5158Smillert UV => sub { $_[0] . '->value' }, 33b39c5158Smillert PV => sub { $_[0] . '->value' }, 34b39c5158Smillert PVN => sub { $_[0] . '->value', $_[0] . '->len' }, 35b39c5158Smillert YES => sub {}, 36b39c5158Smillert NO => sub {}, 37b39c5158Smillert UNDEF => sub {}, 38b39c5158Smillert '' => sub {}, 39b39c5158Smillert ); 40b39c5158Smillert 41b39c5158Smillert%type_to_sv = 42b39c5158Smillert ( 43b39c5158Smillert IV => sub { "newSViv($_[0])" }, 44b39c5158Smillert NV => sub { "newSVnv($_[0])" }, 45b39c5158Smillert UV => sub { "newSVuv($_[0])" }, 46b39c5158Smillert PV => sub { "newSVpv($_[0], 0)" }, 47b39c5158Smillert PVN => sub { "newSVpvn($_[0], $_[1])" }, 48b39c5158Smillert YES => sub { '&PL_sv_yes' }, 49b39c5158Smillert NO => sub { '&PL_sv_no' }, 50b39c5158Smillert UNDEF => sub { '&PL_sv_undef' }, 51b39c5158Smillert '' => sub { '&PL_sv_yes' }, 52b39c5158Smillert SV => sub {"SvREFCNT_inc($_[0])"}, 53b39c5158Smillert ); 54b39c5158Smillert 55b39c5158Smillert%type_to_C_value = 56b39c5158Smillert ( 57b39c5158Smillert YES => sub {}, 58b39c5158Smillert NO => sub {}, 59b39c5158Smillert UNDEF => sub {}, 60b39c5158Smillert '' => sub {}, 61b39c5158Smillert ); 62b39c5158Smillert 63b39c5158Smillertsub type_to_C_value { 64b39c5158Smillert my ($self, $type) = @_; 65b39c5158Smillert return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_}; 66b39c5158Smillert} 67b39c5158Smillert 68b39c5158Smillert# TODO - figure out if there is a clean way for the type_to_sv code to 69b39c5158Smillert# attempt s/sv_2mortal// and if it succeeds tell type_to_sv not to add 70b39c5158Smillert# SvREFCNT_inc 71b39c5158Smillert%type_is_a_problem = 72b39c5158Smillert ( 73b39c5158Smillert # The documentation says *mortal SV*, but we now need a non-mortal copy. 74b39c5158Smillert SV => 1, 75b39c5158Smillert ); 76b39c5158Smillert 77b39c5158Smillert%type_temporary = 78b39c5158Smillert ( 79b39c5158Smillert SV => ['SV *'], 80b39c5158Smillert PV => ['const char *'], 81b39c5158Smillert PVN => ['const char *', 'STRLEN'], 82b39c5158Smillert ); 83b39c5158Smillert$type_temporary{$_} = [$_] foreach qw(IV UV NV); 84b39c5158Smillert 85b39c5158Smillertwhile (my ($type, $value) = each %XS_TypeSet) { 86b39c5158Smillert $type_num_args{$type} 87b39c5158Smillert = defined $value ? ref $value ? scalar @$value : 1 : 0; 88b39c5158Smillert} 89b39c5158Smillert$type_num_args{''} = 0; 90b39c5158Smillert 91b39c5158Smillertsub partition_names { 92b39c5158Smillert my ($self, $default_type, @items) = @_; 93b39c5158Smillert my (%found, @notfound, @trouble); 94b39c5158Smillert 95b39c5158Smillert while (my $item = shift @items) { 96b39c5158Smillert my $default = delete $item->{default}; 97b39c5158Smillert if ($default) { 98b39c5158Smillert # If we find a default value, convert it into a regular item and 99b39c5158Smillert # append it to the queue of items to process 100b39c5158Smillert my $default_item = {%$item}; 101b39c5158Smillert $default_item->{invert_macro} = 1; 102b39c5158Smillert $default_item->{pre} = delete $item->{def_pre}; 103b39c5158Smillert $default_item->{post} = delete $item->{def_post}; 104b39c5158Smillert $default_item->{type} = shift @$default; 105b39c5158Smillert $default_item->{value} = $default; 106b39c5158Smillert push @items, $default_item; 107b39c5158Smillert } else { 108b39c5158Smillert # It can be "not found" unless it's the default (invert the macro) 109b39c5158Smillert # or the "macro" is an empty string (ie no macro) 110b39c5158Smillert push @notfound, $item unless $item->{invert_macro} 111b39c5158Smillert or !$self->macro_to_ifdef($self->macro_from_item($item)); 112b39c5158Smillert } 113b39c5158Smillert 114b39c5158Smillert if ($item->{pre} or $item->{post} or $item->{not_constant} 115b39c5158Smillert or $type_is_a_problem{$item->{type}}) { 116b39c5158Smillert push @trouble, $item; 117b39c5158Smillert } else { 118b39c5158Smillert push @{$found{$item->{type}}}, $item; 119b39c5158Smillert } 120b39c5158Smillert } 121b39c5158Smillert # use Data::Dumper; print Dumper \%found; 122b39c5158Smillert (\%found, \@notfound, \@trouble); 123b39c5158Smillert} 124b39c5158Smillert 125b39c5158Smillertsub boottime_iterator { 126898184e3Ssthen my ($self, $type, $iterator, $hash, $subname, $push) = @_; 127b39c5158Smillert my $extractor = $type_from_struct{$type}; 128b39c5158Smillert die "Can't find extractor code for type $type" 129b39c5158Smillert unless defined $extractor; 130b39c5158Smillert my $generator = $type_to_sv{$type}; 131b39c5158Smillert die "Can't find generator code for type $type" 132b39c5158Smillert unless defined $generator; 133b39c5158Smillert 134b39c5158Smillert my $athx = $self->C_constant_prefix_param(); 135b39c5158Smillert 136898184e3Ssthen if ($push) { 137898184e3Ssthen return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); 138898184e3Ssthen while ($iterator->name) { 139898184e3Ssthen he = $subname($athx $hash, $iterator->name, 140898184e3Ssthen $iterator->namelen, %s); 141898184e3Ssthen av_push(push, newSVhek(HeKEY_hek(he))); 142898184e3Ssthen ++$iterator; 143898184e3Ssthen } 144898184e3SsthenEOBOOT 145898184e3Ssthen } else { 146b39c5158Smillert return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); 147b39c5158Smillert while ($iterator->name) { 148b39c5158Smillert $subname($athx $hash, $iterator->name, 149b39c5158Smillert $iterator->namelen, %s); 150b39c5158Smillert ++$iterator; 151b39c5158Smillert } 152b39c5158SmillertEOBOOT 153b39c5158Smillert } 154898184e3Ssthen} 155b39c5158Smillert 156b39c5158Smillertsub name_len_value_macro { 157b39c5158Smillert my ($self, $item) = @_; 158b39c5158Smillert my $name = $item->{name}; 159b39c5158Smillert my $value = $item->{value}; 160b39c5158Smillert $value = $item->{name} unless defined $value; 161b39c5158Smillert 162b39c5158Smillert my $namelen = length $name; 163b39c5158Smillert if ($name =~ tr/\0-\377// != $namelen) { 164b39c5158Smillert # the hash API signals UTF-8 by passing the length negated. 165b39c5158Smillert utf8::encode($name); 166b39c5158Smillert $namelen = -length $name; 167b39c5158Smillert } 168b39c5158Smillert $name = C_stringify($name); 169b39c5158Smillert 170b39c5158Smillert my $macro = $self->macro_from_item($item); 171b39c5158Smillert ($name, $namelen, $value, $macro); 172b39c5158Smillert} 173b39c5158Smillert 174b39c5158Smillertsub WriteConstants { 175b39c5158Smillert my $self = shift; 176b39c5158Smillert my $ARGS = {@_}; 177b39c5158Smillert 178898184e3Ssthen my ($c_fh, $xs_fh, $c_subname, $default_type, $package) 179898184e3Ssthen = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)}; 180898184e3Ssthen 181898184e3Ssthen my $xs_subname 182898184e3Ssthen = exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant'; 183b39c5158Smillert 184b39c5158Smillert my $options = $ARGS->{PROXYSUBS}; 185b39c5158Smillert $options = {} unless ref $options; 186898184e3Ssthen my $push = $options->{push}; 187b39c5158Smillert my $explosives = $options->{croak_on_read}; 188898184e3Ssthen my $croak_on_error = $options->{croak_on_error}; 189898184e3Ssthen my $autoload = $options->{autoload}; 190898184e3Ssthen { 191898184e3Ssthen my $exclusive = 0; 192898184e3Ssthen ++$exclusive if $explosives; 193898184e3Ssthen ++$exclusive if $croak_on_error; 194898184e3Ssthen ++$exclusive if $autoload; 195b39c5158Smillert 196898184e3Ssthen # Until someone patches this (with test cases): 197898184e3Ssthen carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together") 198898184e3Ssthen if $exclusive > 1; 199898184e3Ssthen } 200898184e3Ssthen # Strictly it requires Perl_caller_cx 201898184e3Ssthen carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later") 202898184e3Ssthen if $croak_on_error && $^V < v5.13.5; 203898184e3Ssthen # Strictly this is actually 5.8.9, but it's not well tested there 204898184e3Ssthen my $can_do_pcs = $] >= 5.009; 205898184e3Ssthen # Until someone patches this (with test cases) 206898184e3Ssthen carp ("PROXYSUBS option 'push' requires v5.10 or later") 207898184e3Ssthen if $push && !$can_do_pcs; 208898184e3Ssthen # Until someone patches this (with test cases) 209898184e3Ssthen carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together") 210898184e3Ssthen if $explosives && $push; 211b39c5158Smillert 212b39c5158Smillert # If anyone is insane enough to suggest a package name containing % 213b39c5158Smillert my $package_sprintf_safe = $package; 214b39c5158Smillert $package_sprintf_safe =~ s/%/%%/g; 215b39c5158Smillert 216b39c5158Smillert # All the types we see 217b39c5158Smillert my $what = {}; 218b39c5158Smillert # A hash to lookup items with. 219b39c5158Smillert my $items = {}; 220b39c5158Smillert 221b39c5158Smillert my @items = $self->normalise_items ({disable_utf8_duplication => 1}, 222b39c5158Smillert $default_type, $what, $items, 223b39c5158Smillert @{$ARGS->{NAMES}}); 224b39c5158Smillert 225b39c5158Smillert # Partition the values by type. Also include any defaults in here 226b39c5158Smillert # Everything that doesn't have a default needs alternative code for 227b39c5158Smillert # "I'm missing" 228b39c5158Smillert # And everything that has pre or post code ends up in a private block 229b39c5158Smillert my ($found, $notfound, $trouble) 230b39c5158Smillert = $self->partition_names($default_type, @items); 231b39c5158Smillert 232b39c5158Smillert my $pthx = $self->C_constant_prefix_param_defintion(); 233b39c5158Smillert my $athx = $self->C_constant_prefix_param(); 234b39c5158Smillert my $symbol_table = C_stringify($package) . '::'; 235898184e3Ssthen $push = C_stringify($package . '::' . $push) if $push; 236b39c5158Smillert my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; 237b39c5158Smillert 238898184e3Ssthen print $c_fh $self->header(); 239898184e3Ssthen if ($autoload || $croak_on_error) { 240898184e3Ssthen print $c_fh <<'EOC'; 241898184e3Ssthen 242898184e3Ssthen/* This allows slightly more efficient code on !USE_ITHREADS: */ 243898184e3Ssthen#ifdef USE_ITHREADS 244898184e3Ssthen# define COP_FILE(c) CopFILE(c) 245898184e3Ssthen# define COP_FILE_F "s" 246898184e3Ssthen#else 247898184e3Ssthen# define COP_FILE(c) CopFILESV(c) 248898184e3Ssthen# define COP_FILE_F SVf 249898184e3Ssthen#endif 250898184e3SsthenEOC 251898184e3Ssthen } 252898184e3Ssthen 253898184e3Ssthen my $return_type = $push ? 'HE *' : 'void'; 254898184e3Ssthen 255898184e3Ssthen print $c_fh <<"EOADD"; 256898184e3Ssthen 257898184e3Ssthenstatic $return_type 258b39c5158Smillert${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { 259b39c5158SmillertEOADD 260b39c5158Smillert if (!$can_do_pcs) { 261b39c5158Smillert print $c_fh <<'EO_NOPCS'; 262b39c5158Smillert if (namelen == namelen) { 263b39c5158SmillertEO_NOPCS 264b39c5158Smillert } else { 265b39c5158Smillert print $c_fh <<"EO_PCS"; 266898184e3Ssthen HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL, 267898184e3Ssthen 0); 268898184e3Ssthen SV *sv; 269898184e3Ssthen 270898184e3Ssthen if (!he) { 271*5759b3d2Safresh1 croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", 272b39c5158Smillert name); 273b39c5158Smillert } 274898184e3Ssthen sv = HeVAL(he); 275898184e3Ssthen if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) { 276b39c5158Smillert /* Someone has been here before us - have to make a real sub. */ 277b39c5158SmillertEO_PCS 278b39c5158Smillert } 279b39c5158Smillert # This piece of code is common to both 280b39c5158Smillert print $c_fh <<"EOADD"; 281b39c5158Smillert newCONSTSUB(hash, ${cast_CONSTSUB}name, value); 282b39c5158SmillertEOADD 283b39c5158Smillert if ($can_do_pcs) { 284b39c5158Smillert print $c_fh <<'EO_PCS'; 285b39c5158Smillert } else { 286898184e3Ssthen SvUPGRADE(sv, SVt_RV); 287898184e3Ssthen SvRV_set(sv, value); 288898184e3Ssthen SvROK_on(sv); 289b39c5158Smillert SvREADONLY_on(value); 290b39c5158Smillert } 291b39c5158SmillertEO_PCS 292b39c5158Smillert } else { 293b39c5158Smillert print $c_fh <<'EO_NOPCS'; 294b39c5158Smillert } 295b39c5158SmillertEO_NOPCS 296b39c5158Smillert } 297898184e3Ssthen print $c_fh " return he;\n" if $push; 298b39c5158Smillert print $c_fh <<'EOADD'; 299b39c5158Smillert} 300b39c5158Smillert 301b39c5158SmillertEOADD 302b39c5158Smillert 303b39c5158Smillert print $c_fh $explosives ? <<"EXPLODE" : "\n"; 304b39c5158Smillert 305b39c5158Smillertstatic int 306b39c5158SmillertIm_sorry_Dave(pTHX_ SV *sv, MAGIC *mg) 307b39c5158Smillert{ 308b39c5158Smillert PERL_UNUSED_ARG(mg); 309*5759b3d2Safresh1 croak("Your vendor has not defined $package_sprintf_safe macro %"SVf 310b39c5158Smillert " used", sv); 311b39c5158Smillert NORETURN_FUNCTION_END; 312b39c5158Smillert} 313b39c5158Smillert 314b39c5158Smillertstatic MGVTBL not_defined_vtbl = { 315b39c5158Smillert Im_sorry_Dave, /* get - I'm afraid I can't do that */ 316b39c5158Smillert Im_sorry_Dave, /* set */ 317b39c5158Smillert 0, /* len */ 318b39c5158Smillert 0, /* clear */ 319b39c5158Smillert 0, /* free */ 320b39c5158Smillert 0, /* copy */ 321b39c5158Smillert 0, /* dup */ 322b39c5158Smillert}; 323b39c5158Smillert 324b39c5158SmillertEXPLODE 325b39c5158Smillert 326b39c5158Smillert{ 327b39c5158Smillert my $key = $symbol_table; 328b39c5158Smillert # Just seems tidier (and slightly more space efficient) not to have keys 329b39c5158Smillert # such as Fcntl:: 330b39c5158Smillert $key =~ s/::$//; 331b39c5158Smillert my $key_len = length $key; 332b39c5158Smillert 333b39c5158Smillert print $c_fh <<"MISSING"; 334b39c5158Smillert 335b39c5158Smillert#ifndef SYMBIAN 336b39c5158Smillert 337b39c5158Smillert/* Store a hash of all symbols missing from the package. To avoid trampling on 338b39c5158Smillert the package namespace (uninvited) put each package's hash in our namespace. 339b39c5158Smillert To avoid creating lots of typeblogs and symbol tables for sub-packages, put 340b39c5158Smillert each package's hash into one hash in our namespace. */ 341b39c5158Smillert 342b39c5158Smillertstatic HV * 343b39c5158Smillertget_missing_hash(pTHX) { 344b39c5158Smillert HV *const parent 345b39c5158Smillert = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI); 346b39c5158Smillert /* We could make a hash of hashes directly, but this would confuse anything 347b39c5158Smillert at Perl space that looks at us, and as we're visible in Perl space, 348b39c5158Smillert best to play nice. */ 349b39c5158Smillert SV *const *const ref 350b39c5158Smillert = hv_fetch(parent, "$key", $key_len, TRUE); 351b39c5158Smillert HV *new_hv; 352b39c5158Smillert 353b39c5158Smillert if (!ref) 354b39c5158Smillert return NULL; 355b39c5158Smillert 356b39c5158Smillert if (SvROK(*ref)) 357b39c5158Smillert return (HV*) SvRV(*ref); 358b39c5158Smillert 359b39c5158Smillert new_hv = newHV(); 360b39c5158Smillert SvUPGRADE(*ref, SVt_RV); 361b39c5158Smillert SvRV_set(*ref, (SV *)new_hv); 362b39c5158Smillert SvROK_on(*ref); 363b39c5158Smillert return new_hv; 364b39c5158Smillert} 365b39c5158Smillert 366b39c5158Smillert#endif 367b39c5158Smillert 368b39c5158SmillertMISSING 369b39c5158Smillert 370b39c5158Smillert} 371b39c5158Smillert 372b39c5158Smillert print $xs_fh <<"EOBOOT"; 373b39c5158SmillertBOOT: 374b39c5158Smillert { 375*5759b3d2Safresh1#if defined(dTHX) && !defined(PERL_NO_GET_CONTEXT) 376b39c5158Smillert dTHX; 377b39c5158Smillert#endif 378b39c5158Smillert HV *symbol_table = get_hv("$symbol_table", GV_ADD); 379b39c5158SmillertEOBOOT 380898184e3Ssthen if ($push) { 381898184e3Ssthen print $xs_fh <<"EOC"; 382898184e3Ssthen AV *push = get_av(\"$push\", GV_ADD); 383898184e3Ssthen HE *he; 384898184e3SsthenEOC 385898184e3Ssthen } 386b39c5158Smillert 387b39c5158Smillert my %iterator; 388b39c5158Smillert 389b39c5158Smillert $found->{''} 390b39c5158Smillert = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; 391b39c5158Smillert 392b39c5158Smillert foreach my $type (sort keys %$found) { 393b39c5158Smillert my $struct = $type_to_struct{$type}; 394b39c5158Smillert my $type_to_value = $self->type_to_C_value($type); 395b39c5158Smillert my $number_of_args = $type_num_args{$type}; 396b39c5158Smillert die "Can't find structure definition for type $type" 397b39c5158Smillert unless defined $struct; 398b39c5158Smillert 399898184e3Ssthen my $lc_type = $type ? lc($type) : 'notfound'; 400898184e3Ssthen my $struct_type = $lc_type . '_s'; 401898184e3Ssthen my $array_name = 'values_for_' . $lc_type; 402898184e3Ssthen $iterator{$type} = 'value_for_' . $lc_type; 403898184e3Ssthen # Give the notfound struct file scope. The others are scoped within the 404898184e3Ssthen # BOOT block 405898184e3Ssthen my $struct_fh = $type ? $xs_fh : $c_fh; 406898184e3Ssthen 407b39c5158Smillert print $c_fh "struct $struct_type $struct;\n"; 408b39c5158Smillert 409898184e3Ssthen print $struct_fh <<"EOBOOT"; 410b39c5158Smillert 411b39c5158Smillert static const struct $struct_type $array_name\[] = 412b39c5158Smillert { 413b39c5158SmillertEOBOOT 414b39c5158Smillert 415b39c5158Smillert 416b39c5158Smillert foreach my $item (@{$found->{$type}}) { 417b39c5158Smillert my ($name, $namelen, $value, $macro) 418b39c5158Smillert = $self->name_len_value_macro($item); 419b39c5158Smillert 420b39c5158Smillert my $ifdef = $self->macro_to_ifdef($macro); 421b39c5158Smillert if (!$ifdef && $item->{invert_macro}) { 422b39c5158Smillert carp("Attempting to supply a default for '$name' which has no conditional macro"); 423b39c5158Smillert next; 424b39c5158Smillert } 425b39c5158Smillert if ($item->{invert_macro}) { 426898184e3Ssthen print $struct_fh $self->macro_to_ifndef($macro); 427898184e3Ssthen print $struct_fh 428b39c5158Smillert " /* This is the default value: */\n" if $type; 429898184e3Ssthen } else { 430898184e3Ssthen print $struct_fh $ifdef; 431b39c5158Smillert } 432898184e3Ssthen print $struct_fh " { ", join (', ', "\"$name\"", $namelen, 433898184e3Ssthen &$type_to_value($value)), 434898184e3Ssthen " },\n", 435b39c5158Smillert $self->macro_to_endif($macro); 436b39c5158Smillert } 437b39c5158Smillert 438b39c5158Smillert # Terminate the list with a NULL 439898184e3Ssthen print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; 440b39c5158Smillert 441898184e3Ssthen print $xs_fh <<"EOBOOT" if $type; 442b39c5158Smillert const struct $struct_type *$iterator{$type} = $array_name; 443b39c5158SmillertEOBOOT 444b39c5158Smillert } 445b39c5158Smillert 446b39c5158Smillert delete $found->{''}; 447b39c5158Smillert 448b39c5158Smillert my $add_symbol_subname = $c_subname . '_add_symbol'; 449b39c5158Smillert foreach my $type (sort keys %$found) { 450b39c5158Smillert print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 451b39c5158Smillert 'symbol_table', 452898184e3Ssthen $add_symbol_subname, $push); 453b39c5158Smillert } 454b39c5158Smillert 455b39c5158Smillert print $xs_fh <<"EOBOOT"; 456898184e3Ssthen if (C_ARRAY_LENGTH(values_for_notfound) > 1) { 457898184e3Ssthen#ifndef SYMBIAN 458898184e3Ssthen HV *const ${c_subname}_missing = get_missing_hash(aTHX); 459898184e3Ssthen#endif 460898184e3Ssthen const struct notfound_s *value_for_notfound = values_for_notfound; 461898184e3Ssthen do { 462b39c5158SmillertEOBOOT 463b39c5158Smillert 464b39c5158Smillert print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; 465b39c5158Smillert SV *tripwire = newSV(0); 466b39c5158Smillert 467b39c5158Smillert sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); 468b39c5158Smillert SvPV_set(tripwire, (char *)value_for_notfound->name); 469b39c5158Smillert if(value_for_notfound->namelen >= 0) { 470b39c5158Smillert SvCUR_set(tripwire, value_for_notfound->namelen); 471b39c5158Smillert } else { 472b39c5158Smillert SvCUR_set(tripwire, -value_for_notfound->namelen); 473b39c5158Smillert SvUTF8_on(tripwire); 474b39c5158Smillert } 475b39c5158Smillert SvPOKp_on(tripwire); 476b39c5158Smillert SvREADONLY_on(tripwire); 477b39c5158Smillert assert(SvLEN(tripwire) == 0); 478b39c5158Smillert 479b39c5158Smillert $add_symbol_subname($athx symbol_table, value_for_notfound->name, 480b39c5158Smillert value_for_notfound->namelen, tripwire); 481b39c5158SmillertEXPLODE 482b39c5158Smillert 483b39c5158Smillert /* Need to add prototypes, else parsing will vary by platform. */ 484898184e3Ssthen HE *he = (HE*) hv_common_key_len(symbol_table, 485898184e3Ssthen value_for_notfound->name, 486898184e3Ssthen value_for_notfound->namelen, 487898184e3Ssthen HV_FETCH_LVALUE, NULL, 0); 488898184e3Ssthen SV *sv; 489898184e3Ssthen#ifndef SYMBIAN 490898184e3Ssthen HEK *hek; 491898184e3Ssthen#endif 492898184e3Ssthen if (!he) { 493*5759b3d2Safresh1 croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", 494b39c5158Smillert value_for_notfound->name); 495b39c5158Smillert } 496898184e3Ssthen sv = HeVAL(he); 497898184e3Ssthen if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) { 498b39c5158Smillert /* Nothing was here before, so mark a prototype of "" */ 499898184e3Ssthen sv_setpvn(sv, "", 0); 500898184e3Ssthen } else if (SvPOK(sv) && SvCUR(sv) == 0) { 501b39c5158Smillert /* There is already a prototype of "" - do nothing */ 502b39c5158Smillert } else { 503b39c5158Smillert /* Someone has been here before us - have to make a real 504b39c5158Smillert typeglob. */ 505b39c5158Smillert /* It turns out to be incredibly hard to deal with all the 506b39c5158Smillert corner cases of sub foo (); and reporting errors correctly, 507b39c5158Smillert so lets cheat a bit. Start with a constant subroutine */ 508b39c5158Smillert CV *cv = newCONSTSUB(symbol_table, 509b39c5158Smillert ${cast_CONSTSUB}value_for_notfound->name, 510b39c5158Smillert &PL_sv_yes); 511b39c5158Smillert /* and then turn it into a non constant declaration only. */ 512b39c5158Smillert SvREFCNT_dec(CvXSUBANY(cv).any_ptr); 513b39c5158Smillert CvCONST_off(cv); 514b39c5158Smillert CvXSUB(cv) = NULL; 515b39c5158Smillert CvXSUBANY(cv).any_ptr = NULL; 516b39c5158Smillert } 517b39c5158Smillert#ifndef SYMBIAN 518898184e3Ssthen hek = HeKEY_hek(he); 519898184e3Ssthen if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek), 520898184e3Ssthen HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE, 521898184e3Ssthen &PL_sv_yes, HEK_HASH(hek))) 522*5759b3d2Safresh1 croak("Couldn't add key '%s' to missing_hash", 523b39c5158Smillert value_for_notfound->name); 524b39c5158Smillert#endif 525b39c5158SmillertDONT 526b39c5158Smillert 527898184e3Ssthen print $xs_fh " av_push(push, newSVhek(hek));\n" 528898184e3Ssthen if $push; 529b39c5158Smillert 530898184e3Ssthen print $xs_fh <<"EOBOOT"; 531898184e3Ssthen } while ((++value_for_notfound)->name); 532b39c5158Smillert } 533b39c5158SmillertEOBOOT 534b39c5158Smillert 535b39c5158Smillert foreach my $item (@$trouble) { 536b39c5158Smillert my ($name, $namelen, $value, $macro) 537b39c5158Smillert = $self->name_len_value_macro($item); 538b39c5158Smillert my $ifdef = $self->macro_to_ifdef($macro); 539b39c5158Smillert my $type = $item->{type}; 540b39c5158Smillert my $type_to_value = $self->type_to_C_value($type); 541b39c5158Smillert 542b39c5158Smillert print $xs_fh $ifdef; 543b39c5158Smillert if ($item->{invert_macro}) { 544b39c5158Smillert print $xs_fh 545b39c5158Smillert " /* This is the default value: */\n" if $type; 546b39c5158Smillert print $xs_fh "#else\n"; 547b39c5158Smillert } 548b39c5158Smillert my $generator = $type_to_sv{$type}; 549b39c5158Smillert die "Can't find generator code for type $type" 550b39c5158Smillert unless defined $generator; 551b39c5158Smillert 552b39c5158Smillert print $xs_fh " {\n"; 553b39c5158Smillert # We need to use a temporary value because some really troublesome 554b39c5158Smillert # items use C pre processor directives in their values, and in turn 555b39c5158Smillert # these don't fit nicely in the macro-ised generator functions 556b39c5158Smillert my $counter = 0; 557b39c5158Smillert printf $xs_fh " %s temp%d;\n", $_, $counter++ 558b39c5158Smillert foreach @{$type_temporary{$type}}; 559b39c5158Smillert 560b39c5158Smillert print $xs_fh " $item->{pre}\n" if $item->{pre}; 561b39c5158Smillert 562b39c5158Smillert # And because the code in pre might be both declarations and 563b39c5158Smillert # statements, we can't declare and assign to the temporaries in one. 564b39c5158Smillert $counter = 0; 565b39c5158Smillert printf $xs_fh " temp%d = %s;\n", $counter++, $_ 566b39c5158Smillert foreach &$type_to_value($value); 567b39c5158Smillert 568b39c5158Smillert my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; 569b39c5158Smillert printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); 570b39c5158Smillert ${c_subname}_add_symbol($athx symbol_table, "%s", 571b39c5158Smillert $namelen, %s); 572b39c5158SmillertEOBOOT 573b39c5158Smillert print $xs_fh " $item->{post}\n" if $item->{post}; 574b39c5158Smillert print $xs_fh " }\n"; 575b39c5158Smillert 576b39c5158Smillert print $xs_fh $self->macro_to_endif($macro); 577b39c5158Smillert } 578b39c5158Smillert 579898184e3Ssthen if ($] >= 5.009) { 580898184e3Ssthen print $xs_fh <<EOBOOT; 581898184e3Ssthen /* As we've been creating subroutines, we better invalidate any cached 582898184e3Ssthen methods */ 583898184e3Ssthen mro_method_changed_in(symbol_table); 584898184e3Ssthen } 585898184e3SsthenEOBOOT 586898184e3Ssthen } else { 587b39c5158Smillert print $xs_fh <<EOBOOT; 588b39c5158Smillert /* As we've been creating subroutines, we better invalidate any cached 589b39c5158Smillert methods */ 590b39c5158Smillert ++PL_sub_generation; 591b39c5158Smillert } 592b39c5158SmillertEOBOOT 593898184e3Ssthen } 594b39c5158Smillert 595898184e3Ssthen return if !defined $xs_subname; 596898184e3Ssthen 597898184e3Ssthen if ($croak_on_error || $autoload) { 598898184e3Ssthen print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA'; 599898184e3Ssthen 600898184e3Ssthenvoid 601898184e3Ssthen$xs_subname(sv) 602898184e3Ssthen INPUT: 603898184e3Ssthen SV * sv; 604898184e3Ssthen PREINIT: 605898184e3Ssthen const PERL_CONTEXT *cx = caller_cx(0, NULL); 606898184e3Ssthen /* cx is NULL if we've been called from the top level. PL_curcop isn't 607898184e3Ssthen ideal, but it's much cheaper than other ways of not going SEGV. */ 608898184e3Ssthen const COP *cop = cx ? cx->blk_oldcop : PL_curcop; 609898184e3SsthenEOC 610898184e3Ssthen 611898184e3Ssthenvoid 612898184e3SsthenAUTOLOAD() 613898184e3Ssthen PROTOTYPE: DISABLE 614898184e3Ssthen PREINIT: 615898184e3Ssthen SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv)); 616898184e3Ssthen const COP *cop = PL_curcop; 617898184e3SsthenEOA 618898184e3Ssthen print $xs_fh <<"EOC"; 619898184e3Ssthen PPCODE: 620898184e3Ssthen#ifndef SYMBIAN 621898184e3Ssthen /* It's not obvious how to calculate this at C pre-processor time. 622898184e3Ssthen However, any compiler optimiser worth its salt should be able to 623898184e3Ssthen remove the dead code, and hopefully the now-obviously-unused static 624898184e3Ssthen function too. */ 625898184e3Ssthen HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) 626898184e3Ssthen ? get_missing_hash(aTHX) : NULL; 627898184e3Ssthen if ((C_ARRAY_LENGTH(values_for_notfound) > 1) 628898184e3Ssthen ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { 629898184e3Ssthen sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 630*5759b3d2Safresh1 ", used at %" COP_FILE_F " line %" UVuf "\\n", 631*5759b3d2Safresh1 sv, COP_FILE(cop), (UV)CopLINE(cop)); 632898184e3Ssthen } else 633898184e3Ssthen#endif 634898184e3Ssthen { 635*5759b3d2Safresh1 sv = newSVpvf("%" SVf 636*5759b3d2Safresh1 " is not a valid $package_sprintf_safe macro at %" 637*5759b3d2Safresh1 COP_FILE_F " line %" UVuf "\\n", 638*5759b3d2Safresh1 sv, COP_FILE(cop), (UV)CopLINE(cop)); 639898184e3Ssthen } 640898184e3Ssthen croak_sv(sv_2mortal(sv)); 641898184e3SsthenEOC 642898184e3Ssthen } else { 643b39c5158Smillert print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT"; 644b39c5158Smillert 645b39c5158Smillertvoid 646b39c5158Smillert$xs_subname(sv) 647b39c5158Smillert INPUT: 648b39c5158Smillert SV * sv; 649b39c5158Smillert PPCODE: 650b39c5158Smillert sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 651b39c5158Smillert ", used", sv); 652b39c5158Smillert PUSHs(sv_2mortal(sv)); 653b39c5158SmillertEXPLODE 654b39c5158Smillert 655b39c5158Smillertvoid 656b39c5158Smillert$xs_subname(sv) 657b39c5158Smillert INPUT: 658b39c5158Smillert SV * sv; 659b39c5158Smillert PPCODE: 660898184e3Ssthen#ifndef SYMBIAN 661898184e3Ssthen /* It's not obvious how to calculate this at C pre-processor time. 662898184e3Ssthen However, any compiler optimiser worth its salt should be able to 663898184e3Ssthen remove the dead code, and hopefully the now-obviously-unused static 664898184e3Ssthen function too. */ 665898184e3Ssthen HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) 666898184e3Ssthen ? get_missing_hash(aTHX) : NULL; 667898184e3Ssthen if ((C_ARRAY_LENGTH(values_for_notfound) > 1) 668898184e3Ssthen ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { 669b39c5158Smillert sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 670b39c5158Smillert ", used", sv); 671898184e3Ssthen } else 672898184e3Ssthen#endif 673898184e3Ssthen { 674b39c5158Smillert sv = newSVpvf("%" SVf " is not a valid $package_sprintf_safe macro", 675b39c5158Smillert sv); 676b39c5158Smillert } 677b39c5158Smillert PUSHs(sv_2mortal(sv)); 678b39c5158SmillertDONT 679898184e3Ssthen } 680b39c5158Smillert} 681b39c5158Smillert 682b39c5158Smillert1; 683