1package ExtUtils::Constant::ProxySubs; 2 3use strict; 4use 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); 7use Carp; 8require ExtUtils::Constant::XS; 9use ExtUtils::Constant::Utils qw(C_stringify); 10use ExtUtils::Constant::XS qw(%XS_TypeSet); 11 12$VERSION = '0.06'; 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 63sub 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 85while (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 91sub 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 125sub 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 } 142EOBOOT 143} 144 145sub 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 163sub 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 my $can_do_pcs = $] >= 5.009; 201 my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; 202 203 print $c_fh $self->header(), <<"EOADD"; 204static void 205${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { 206EOADD 207 if (!$can_do_pcs) { 208 print $c_fh <<'EO_NOPCS'; 209 if (namelen == namelen) { 210EO_NOPCS 211 } else { 212 print $c_fh <<"EO_PCS"; 213 SV **sv = hv_fetch(hash, name, namelen, TRUE); 214 if (!sv) { 215 Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::", 216 name); 217 } 218 if (SvOK(*sv) || SvTYPE(*sv) == SVt_PVGV) { 219 /* Someone has been here before us - have to make a real sub. */ 220EO_PCS 221 } 222 # This piece of code is common to both 223 print $c_fh <<"EOADD"; 224 newCONSTSUB(hash, ${cast_CONSTSUB}name, value); 225EOADD 226 if ($can_do_pcs) { 227 print $c_fh <<'EO_PCS'; 228 } else { 229 SvUPGRADE(*sv, SVt_RV); 230 SvRV_set(*sv, value); 231 SvROK_on(*sv); 232 SvREADONLY_on(value); 233 } 234EO_PCS 235 } else { 236 print $c_fh <<'EO_NOPCS'; 237 } 238EO_NOPCS 239 } 240 print $c_fh <<'EOADD'; 241} 242 243EOADD 244 245 print $c_fh $explosives ? <<"EXPLODE" : "\n"; 246 247static int 248Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg) 249{ 250 PERL_UNUSED_ARG(mg); 251 Perl_croak(aTHX_ 252 "Your vendor has not defined $package_sprintf_safe macro %"SVf 253 " used", sv); 254 NORETURN_FUNCTION_END; 255} 256 257static MGVTBL not_defined_vtbl = { 258 Im_sorry_Dave, /* get - I'm afraid I can't do that */ 259 Im_sorry_Dave, /* set */ 260 0, /* len */ 261 0, /* clear */ 262 0, /* free */ 263 0, /* copy */ 264 0, /* dup */ 265}; 266 267EXPLODE 268 269{ 270 my $key = $symbol_table; 271 # Just seems tidier (and slightly more space efficient) not to have keys 272 # such as Fcntl:: 273 $key =~ s/::$//; 274 my $key_len = length $key; 275 276 print $c_fh <<"MISSING"; 277 278#ifndef SYMBIAN 279 280/* Store a hash of all symbols missing from the package. To avoid trampling on 281 the package namespace (uninvited) put each package's hash in our namespace. 282 To avoid creating lots of typeblogs and symbol tables for sub-packages, put 283 each package's hash into one hash in our namespace. */ 284 285static HV * 286get_missing_hash(pTHX) { 287 HV *const parent 288 = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI); 289 /* We could make a hash of hashes directly, but this would confuse anything 290 at Perl space that looks at us, and as we're visible in Perl space, 291 best to play nice. */ 292 SV *const *const ref 293 = hv_fetch(parent, "$key", $key_len, TRUE); 294 HV *new_hv; 295 296 if (!ref) 297 return NULL; 298 299 if (SvROK(*ref)) 300 return (HV*) SvRV(*ref); 301 302 new_hv = newHV(); 303 SvUPGRADE(*ref, SVt_RV); 304 SvRV_set(*ref, (SV *)new_hv); 305 SvROK_on(*ref); 306 return new_hv; 307} 308 309#endif 310 311MISSING 312 313} 314 315 print $xs_fh <<"EOBOOT"; 316BOOT: 317 { 318#ifdef dTHX 319 dTHX; 320#endif 321 HV *symbol_table = get_hv("$symbol_table", GV_ADD); 322#ifndef SYMBIAN 323 HV *${c_subname}_missing; 324#endif 325EOBOOT 326 327 my %iterator; 328 329 $found->{''} 330 = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; 331 332 foreach my $type (sort keys %$found) { 333 my $struct = $type_to_struct{$type}; 334 my $type_to_value = $self->type_to_C_value($type); 335 my $number_of_args = $type_num_args{$type}; 336 die "Can't find structure definition for type $type" 337 unless defined $struct; 338 339 my $struct_type = $type ? lc($type) . '_s' : 'notfound_s'; 340 print $c_fh "struct $struct_type $struct;\n"; 341 342 my $array_name = 'values_for_' . ($type ? lc $type : 'notfound'); 343 print $xs_fh <<"EOBOOT"; 344 345 static const struct $struct_type $array_name\[] = 346 { 347EOBOOT 348 349 350 foreach my $item (@{$found->{$type}}) { 351 my ($name, $namelen, $value, $macro) 352 = $self->name_len_value_macro($item); 353 354 my $ifdef = $self->macro_to_ifdef($macro); 355 if (!$ifdef && $item->{invert_macro}) { 356 carp("Attempting to supply a default for '$name' which has no conditional macro"); 357 next; 358 } 359 print $xs_fh $ifdef; 360 if ($item->{invert_macro}) { 361 print $xs_fh 362 " /* This is the default value: */\n" if $type; 363 print $xs_fh "#else\n"; 364 } 365 print $xs_fh " { ", join (', ', "\"$name\"", $namelen, 366 &$type_to_value($value)), " },\n", 367 $self->macro_to_endif($macro); 368 } 369 370 371 # Terminate the list with a NULL 372 print $xs_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; 373 374 $iterator{$type} = "value_for_" . ($type ? lc $type : 'notfound'); 375 376 print $xs_fh <<"EOBOOT"; 377 const struct $struct_type *$iterator{$type} = $array_name; 378EOBOOT 379 } 380 381 delete $found->{''}; 382 383 print $xs_fh <<"EOBOOT"; 384#ifndef SYMBIAN 385 ${c_subname}_missing = get_missing_hash(aTHX); 386#endif 387EOBOOT 388 389 my $add_symbol_subname = $c_subname . '_add_symbol'; 390 foreach my $type (sort keys %$found) { 391 print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 392 'symbol_table', 393 $add_symbol_subname); 394 } 395 396 print $xs_fh <<"EOBOOT"; 397 while (value_for_notfound->name) { 398EOBOOT 399 400 print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; 401 SV *tripwire = newSV(0); 402 403 sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); 404 SvPV_set(tripwire, (char *)value_for_notfound->name); 405 if(value_for_notfound->namelen >= 0) { 406 SvCUR_set(tripwire, value_for_notfound->namelen); 407 } else { 408 SvCUR_set(tripwire, -value_for_notfound->namelen); 409 SvUTF8_on(tripwire); 410 } 411 SvPOKp_on(tripwire); 412 SvREADONLY_on(tripwire); 413 assert(SvLEN(tripwire) == 0); 414 415 $add_symbol_subname($athx symbol_table, value_for_notfound->name, 416 value_for_notfound->namelen, tripwire); 417EXPLODE 418 419 /* Need to add prototypes, else parsing will vary by platform. */ 420 SV **sv = hv_fetch(symbol_table, value_for_notfound->name, 421 value_for_notfound->namelen, TRUE); 422 if (!sv) { 423 Perl_croak($athx 424 "Couldn't add key '%s' to %%$package_sprintf_safe\::", 425 value_for_notfound->name); 426 } 427 if (!SvOK(*sv) && SvTYPE(*sv) != SVt_PVGV) { 428 /* Nothing was here before, so mark a prototype of "" */ 429 sv_setpvn(*sv, "", 0); 430 } else if (SvPOK(*sv) && SvCUR(*sv) == 0) { 431 /* There is already a prototype of "" - do nothing */ 432 } else { 433 /* Someone has been here before us - have to make a real 434 typeglob. */ 435 /* It turns out to be incredibly hard to deal with all the 436 corner cases of sub foo (); and reporting errors correctly, 437 so lets cheat a bit. Start with a constant subroutine */ 438 CV *cv = newCONSTSUB(symbol_table, 439 ${cast_CONSTSUB}value_for_notfound->name, 440 &PL_sv_yes); 441 /* and then turn it into a non constant declaration only. */ 442 SvREFCNT_dec(CvXSUBANY(cv).any_ptr); 443 CvCONST_off(cv); 444 CvXSUB(cv) = NULL; 445 CvXSUBANY(cv).any_ptr = NULL; 446 } 447#ifndef SYMBIAN 448 if (!hv_store(${c_subname}_missing, value_for_notfound->name, 449 value_for_notfound->namelen, &PL_sv_yes, 0)) 450 Perl_croak($athx "Couldn't add key '%s' to missing_hash", 451 value_for_notfound->name); 452#endif 453DONT 454 455 print $xs_fh <<"EOBOOT"; 456 457 ++value_for_notfound; 458 } 459EOBOOT 460 461 foreach my $item (@$trouble) { 462 my ($name, $namelen, $value, $macro) 463 = $self->name_len_value_macro($item); 464 my $ifdef = $self->macro_to_ifdef($macro); 465 my $type = $item->{type}; 466 my $type_to_value = $self->type_to_C_value($type); 467 468 print $xs_fh $ifdef; 469 if ($item->{invert_macro}) { 470 print $xs_fh 471 " /* This is the default value: */\n" if $type; 472 print $xs_fh "#else\n"; 473 } 474 my $generator = $type_to_sv{$type}; 475 die "Can't find generator code for type $type" 476 unless defined $generator; 477 478 print $xs_fh " {\n"; 479 # We need to use a temporary value because some really troublesome 480 # items use C pre processor directives in their values, and in turn 481 # these don't fit nicely in the macro-ised generator functions 482 my $counter = 0; 483 printf $xs_fh " %s temp%d;\n", $_, $counter++ 484 foreach @{$type_temporary{$type}}; 485 486 print $xs_fh " $item->{pre}\n" if $item->{pre}; 487 488 # And because the code in pre might be both declarations and 489 # statements, we can't declare and assign to the temporaries in one. 490 $counter = 0; 491 printf $xs_fh " temp%d = %s;\n", $counter++, $_ 492 foreach &$type_to_value($value); 493 494 my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; 495 printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); 496 ${c_subname}_add_symbol($athx symbol_table, "%s", 497 $namelen, %s); 498EOBOOT 499 print $xs_fh " $item->{post}\n" if $item->{post}; 500 print $xs_fh " }\n"; 501 502 print $xs_fh $self->macro_to_endif($macro); 503 } 504 505 print $xs_fh <<EOBOOT; 506 /* As we've been creating subroutines, we better invalidate any cached 507 methods */ 508 ++PL_sub_generation; 509 } 510EOBOOT 511 512 print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT"; 513 514void 515$xs_subname(sv) 516 INPUT: 517 SV * sv; 518 PPCODE: 519 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 520 ", used", sv); 521 PUSHs(sv_2mortal(sv)); 522EXPLODE 523 524void 525$xs_subname(sv) 526 PREINIT: 527 STRLEN len; 528 INPUT: 529 SV * sv; 530 const char * s = SvPV(sv, len); 531 PPCODE: 532#ifdef SYMBIAN 533 sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", sv); 534#else 535 HV *${c_subname}_missing = get_missing_hash(aTHX); 536 if (hv_exists(${c_subname}_missing, s, SvUTF8(sv) ? -(I32)len : (I32)len)) { 537 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 538 ", used", sv); 539 } else { 540 sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro", 541 sv); 542 } 543#endif 544 PUSHs(sv_2mortal(sv)); 545DONT 546 547} 548 5491; 550