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.09'; 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, $push) = @_; 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 if ($push) { 137 return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); 138 while ($iterator->name) { 139 he = $subname($athx $hash, $iterator->name, 140 $iterator->namelen, %s); 141 av_push(push, newSVhek(HeKEY_hek(he))); 142 ++$iterator; 143 } 144EOBOOT 145 } else { 146 return sprintf <<"EOBOOT", &$generator(&$extractor($iterator)); 147 while ($iterator->name) { 148 $subname($athx $hash, $iterator->name, 149 $iterator->namelen, %s); 150 ++$iterator; 151 } 152EOBOOT 153 } 154} 155 156sub name_len_value_macro { 157 my ($self, $item) = @_; 158 my $name = $item->{name}; 159 my $value = $item->{value}; 160 $value = $item->{name} unless defined $value; 161 162 my $namelen = length $name; 163 if ($name =~ tr/\0-\377// != $namelen) { 164 # the hash API signals UTF-8 by passing the length negated. 165 utf8::encode($name); 166 $namelen = -length $name; 167 } 168 $name = C_stringify($name); 169 170 my $macro = $self->macro_from_item($item); 171 ($name, $namelen, $value, $macro); 172} 173 174sub WriteConstants { 175 my $self = shift; 176 my $ARGS = {@_}; 177 178 my ($c_fh, $xs_fh, $c_subname, $default_type, $package) 179 = @{$ARGS}{qw(C_FH XS_FH C_SUBNAME DEFAULT_TYPE NAME)}; 180 181 my $xs_subname 182 = exists $ARGS->{XS_SUBNAME} ? $ARGS->{XS_SUBNAME} : 'constant'; 183 184 my $options = $ARGS->{PROXYSUBS}; 185 $options = {} unless ref $options; 186 my $push = $options->{push}; 187 my $explosives = $options->{croak_on_read}; 188 my $croak_on_error = $options->{croak_on_error}; 189 my $autoload = $options->{autoload}; 190 { 191 my $exclusive = 0; 192 ++$exclusive if $explosives; 193 ++$exclusive if $croak_on_error; 194 ++$exclusive if $autoload; 195 196 # Until someone patches this (with test cases): 197 carp ("PROXYSUBS options 'autoload', 'croak_on_read' and 'croak_on_error' cannot be used together") 198 if $exclusive > 1; 199 } 200 # Strictly it requires Perl_caller_cx 201 carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later") 202 if $croak_on_error && $^V < v5.13.5; 203 # Strictly this is actually 5.8.9, but it's not well tested there 204 my $can_do_pcs = $] >= 5.009; 205 # Until someone patches this (with test cases) 206 carp ("PROXYSUBS option 'push' requires v5.10 or later") 207 if $push && !$can_do_pcs; 208 # Until someone patches this (with test cases) 209 carp ("PROXYSUBS options 'push' and 'croak_on_read' cannot be used together") 210 if $explosives && $push; 211 212 # If anyone is insane enough to suggest a package name containing % 213 my $package_sprintf_safe = $package; 214 $package_sprintf_safe =~ s/%/%%/g; 215 216 # All the types we see 217 my $what = {}; 218 # A hash to lookup items with. 219 my $items = {}; 220 221 my @items = $self->normalise_items ({disable_utf8_duplication => 1}, 222 $default_type, $what, $items, 223 @{$ARGS->{NAMES}}); 224 225 # Partition the values by type. Also include any defaults in here 226 # Everything that doesn't have a default needs alternative code for 227 # "I'm missing" 228 # And everything that has pre or post code ends up in a private block 229 my ($found, $notfound, $trouble) 230 = $self->partition_names($default_type, @items); 231 232 my $pthx = $self->C_constant_prefix_param_defintion(); 233 my $athx = $self->C_constant_prefix_param(); 234 my $symbol_table = C_stringify($package) . '::'; 235 $push = C_stringify($package . '::' . $push) if $push; 236 my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : ''; 237 238 print $c_fh $self->header(); 239 if ($autoload || $croak_on_error) { 240 print $c_fh <<'EOC'; 241 242/* This allows slightly more efficient code on !USE_ITHREADS: */ 243#ifdef USE_ITHREADS 244# define COP_FILE(c) CopFILE(c) 245# define COP_FILE_F "s" 246#else 247# define COP_FILE(c) CopFILESV(c) 248# define COP_FILE_F SVf 249#endif 250EOC 251 } 252 253 my $return_type = $push ? 'HE *' : 'void'; 254 255 print $c_fh <<"EOADD"; 256 257static $return_type 258${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) { 259EOADD 260 if (!$can_do_pcs) { 261 print $c_fh <<'EO_NOPCS'; 262 if (namelen == namelen) { 263EO_NOPCS 264 } else { 265 print $c_fh <<"EO_PCS"; 266 HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL, 267 0); 268 SV *sv; 269 270 if (!he) { 271 croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", 272 name); 273 } 274 sv = HeVAL(he); 275 if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) { 276 /* Someone has been here before us - have to make a real sub. */ 277EO_PCS 278 } 279 # This piece of code is common to both 280 print $c_fh <<"EOADD"; 281 newCONSTSUB(hash, ${cast_CONSTSUB}name, value); 282EOADD 283 if ($can_do_pcs) { 284 print $c_fh <<'EO_PCS'; 285 } else { 286 SvUPGRADE(sv, SVt_RV); 287 SvRV_set(sv, value); 288 SvROK_on(sv); 289 SvREADONLY_on(value); 290 } 291EO_PCS 292 } else { 293 print $c_fh <<'EO_NOPCS'; 294 } 295EO_NOPCS 296 } 297 print $c_fh " return he;\n" if $push; 298 print $c_fh <<'EOADD'; 299} 300 301EOADD 302 303 print $c_fh $explosives ? <<"EXPLODE" : "\n"; 304 305static int 306Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg) 307{ 308 PERL_UNUSED_ARG(mg); 309 croak("Your vendor has not defined $package_sprintf_safe macro %"SVf 310 " used", sv); 311 NORETURN_FUNCTION_END; 312} 313 314static MGVTBL not_defined_vtbl = { 315 Im_sorry_Dave, /* get - I'm afraid I can't do that */ 316 Im_sorry_Dave, /* set */ 317 0, /* len */ 318 0, /* clear */ 319 0, /* free */ 320 0, /* copy */ 321 0, /* dup */ 322}; 323 324EXPLODE 325 326{ 327 my $key = $symbol_table; 328 # Just seems tidier (and slightly more space efficient) not to have keys 329 # such as Fcntl:: 330 $key =~ s/::$//; 331 my $key_len = length $key; 332 333 print $c_fh <<"MISSING"; 334 335#ifndef SYMBIAN 336 337/* Store a hash of all symbols missing from the package. To avoid trampling on 338 the package namespace (uninvited) put each package's hash in our namespace. 339 To avoid creating lots of typeblogs and symbol tables for sub-packages, put 340 each package's hash into one hash in our namespace. */ 341 342static HV * 343get_missing_hash(pTHX) { 344 HV *const parent 345 = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI); 346 /* We could make a hash of hashes directly, but this would confuse anything 347 at Perl space that looks at us, and as we're visible in Perl space, 348 best to play nice. */ 349 SV *const *const ref 350 = hv_fetch(parent, "$key", $key_len, TRUE); 351 HV *new_hv; 352 353 if (!ref) 354 return NULL; 355 356 if (SvROK(*ref)) 357 return (HV*) SvRV(*ref); 358 359 new_hv = newHV(); 360 SvUPGRADE(*ref, SVt_RV); 361 SvRV_set(*ref, (SV *)new_hv); 362 SvROK_on(*ref); 363 return new_hv; 364} 365 366#endif 367 368MISSING 369 370} 371 372 print $xs_fh <<"EOBOOT"; 373BOOT: 374 { 375#if defined(dTHX) && !defined(PERL_NO_GET_CONTEXT) 376 dTHX; 377#endif 378 HV *symbol_table = get_hv("$symbol_table", GV_ADD); 379EOBOOT 380 if ($push) { 381 print $xs_fh <<"EOC"; 382 AV *push = get_av(\"$push\", GV_ADD); 383 HE *he; 384EOC 385 } 386 387 my %iterator; 388 389 $found->{''} 390 = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; 391 392 foreach my $type (sort keys %$found) { 393 my $struct = $type_to_struct{$type}; 394 my $type_to_value = $self->type_to_C_value($type); 395 my $number_of_args = $type_num_args{$type}; 396 die "Can't find structure definition for type $type" 397 unless defined $struct; 398 399 my $lc_type = $type ? lc($type) : 'notfound'; 400 my $struct_type = $lc_type . '_s'; 401 my $array_name = 'values_for_' . $lc_type; 402 $iterator{$type} = 'value_for_' . $lc_type; 403 # Give the notfound struct file scope. The others are scoped within the 404 # BOOT block 405 my $struct_fh = $type ? $xs_fh : $c_fh; 406 407 print $c_fh "struct $struct_type $struct;\n"; 408 409 print $struct_fh <<"EOBOOT"; 410 411 static const struct $struct_type $array_name\[] = 412 { 413EOBOOT 414 415 416 foreach my $item (@{$found->{$type}}) { 417 my ($name, $namelen, $value, $macro) 418 = $self->name_len_value_macro($item); 419 420 my $ifdef = $self->macro_to_ifdef($macro); 421 if (!$ifdef && $item->{invert_macro}) { 422 carp("Attempting to supply a default for '$name' which has no conditional macro"); 423 next; 424 } 425 if ($item->{invert_macro}) { 426 print $struct_fh $self->macro_to_ifndef($macro); 427 print $struct_fh 428 " /* This is the default value: */\n" if $type; 429 } else { 430 print $struct_fh $ifdef; 431 } 432 print $struct_fh " { ", join (', ', "\"$name\"", $namelen, 433 &$type_to_value($value)), 434 " },\n", 435 $self->macro_to_endif($macro); 436 } 437 438 # Terminate the list with a NULL 439 print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; 440 441 print $xs_fh <<"EOBOOT" if $type; 442 const struct $struct_type *$iterator{$type} = $array_name; 443EOBOOT 444 } 445 446 delete $found->{''}; 447 448 my $add_symbol_subname = $c_subname . '_add_symbol'; 449 foreach my $type (sort keys %$found) { 450 print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 451 'symbol_table', 452 $add_symbol_subname, $push); 453 } 454 455 print $xs_fh <<"EOBOOT"; 456 if (C_ARRAY_LENGTH(values_for_notfound) > 1) { 457#ifndef SYMBIAN 458 HV *const ${c_subname}_missing = get_missing_hash(aTHX); 459#endif 460 const struct notfound_s *value_for_notfound = values_for_notfound; 461 do { 462EOBOOT 463 464 print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; 465 SV *tripwire = newSV(0); 466 467 sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); 468 SvPV_set(tripwire, (char *)value_for_notfound->name); 469 if(value_for_notfound->namelen >= 0) { 470 SvCUR_set(tripwire, value_for_notfound->namelen); 471 } else { 472 SvCUR_set(tripwire, -value_for_notfound->namelen); 473 SvUTF8_on(tripwire); 474 } 475 SvPOKp_on(tripwire); 476 SvREADONLY_on(tripwire); 477 assert(SvLEN(tripwire) == 0); 478 479 $add_symbol_subname($athx symbol_table, value_for_notfound->name, 480 value_for_notfound->namelen, tripwire); 481EXPLODE 482 483 /* Need to add prototypes, else parsing will vary by platform. */ 484 HE *he = (HE*) hv_common_key_len(symbol_table, 485 value_for_notfound->name, 486 value_for_notfound->namelen, 487 HV_FETCH_LVALUE, NULL, 0); 488 SV *sv; 489#ifndef SYMBIAN 490 HEK *hek; 491#endif 492 if (!he) { 493 croak("Couldn't add key '%s' to %%$package_sprintf_safe\::", 494 value_for_notfound->name); 495 } 496 sv = HeVAL(he); 497 if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) { 498 /* Nothing was here before, so mark a prototype of "" */ 499 sv_setpvn(sv, "", 0); 500 } else if (SvPOK(sv) && SvCUR(sv) == 0) { 501 /* There is already a prototype of "" - do nothing */ 502 } else { 503 /* Someone has been here before us - have to make a real 504 typeglob. */ 505 /* It turns out to be incredibly hard to deal with all the 506 corner cases of sub foo (); and reporting errors correctly, 507 so lets cheat a bit. Start with a constant subroutine */ 508 CV *cv = newCONSTSUB(symbol_table, 509 ${cast_CONSTSUB}value_for_notfound->name, 510 &PL_sv_yes); 511 /* and then turn it into a non constant declaration only. */ 512 SvREFCNT_dec(CvXSUBANY(cv).any_ptr); 513 CvCONST_off(cv); 514 CvXSUB(cv) = NULL; 515 CvXSUBANY(cv).any_ptr = NULL; 516 } 517#ifndef SYMBIAN 518 hek = HeKEY_hek(he); 519 if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek), 520 HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE, 521 &PL_sv_yes, HEK_HASH(hek))) 522 croak("Couldn't add key '%s' to missing_hash", 523 value_for_notfound->name); 524#endif 525DONT 526 527 print $xs_fh " av_push(push, newSVhek(hek));\n" 528 if $push; 529 530 print $xs_fh <<"EOBOOT"; 531 } while ((++value_for_notfound)->name); 532 } 533EOBOOT 534 535 foreach my $item (@$trouble) { 536 my ($name, $namelen, $value, $macro) 537 = $self->name_len_value_macro($item); 538 my $ifdef = $self->macro_to_ifdef($macro); 539 my $type = $item->{type}; 540 my $type_to_value = $self->type_to_C_value($type); 541 542 print $xs_fh $ifdef; 543 if ($item->{invert_macro}) { 544 print $xs_fh 545 " /* This is the default value: */\n" if $type; 546 print $xs_fh "#else\n"; 547 } 548 my $generator = $type_to_sv{$type}; 549 die "Can't find generator code for type $type" 550 unless defined $generator; 551 552 print $xs_fh " {\n"; 553 # We need to use a temporary value because some really troublesome 554 # items use C pre processor directives in their values, and in turn 555 # these don't fit nicely in the macro-ised generator functions 556 my $counter = 0; 557 printf $xs_fh " %s temp%d;\n", $_, $counter++ 558 foreach @{$type_temporary{$type}}; 559 560 print $xs_fh " $item->{pre}\n" if $item->{pre}; 561 562 # And because the code in pre might be both declarations and 563 # statements, we can't declare and assign to the temporaries in one. 564 $counter = 0; 565 printf $xs_fh " temp%d = %s;\n", $counter++, $_ 566 foreach &$type_to_value($value); 567 568 my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; 569 printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); 570 ${c_subname}_add_symbol($athx symbol_table, "%s", 571 $namelen, %s); 572EOBOOT 573 print $xs_fh " $item->{post}\n" if $item->{post}; 574 print $xs_fh " }\n"; 575 576 print $xs_fh $self->macro_to_endif($macro); 577 } 578 579 if ($] >= 5.009) { 580 print $xs_fh <<EOBOOT; 581 /* As we've been creating subroutines, we better invalidate any cached 582 methods */ 583 mro_method_changed_in(symbol_table); 584 } 585EOBOOT 586 } else { 587 print $xs_fh <<EOBOOT; 588 /* As we've been creating subroutines, we better invalidate any cached 589 methods */ 590 ++PL_sub_generation; 591 } 592EOBOOT 593 } 594 595 return if !defined $xs_subname; 596 597 if ($croak_on_error || $autoload) { 598 print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA'; 599 600void 601$xs_subname(sv) 602 INPUT: 603 SV * sv; 604 PREINIT: 605 const PERL_CONTEXT *cx = caller_cx(0, NULL); 606 /* cx is NULL if we've been called from the top level. PL_curcop isn't 607 ideal, but it's much cheaper than other ways of not going SEGV. */ 608 const COP *cop = cx ? cx->blk_oldcop : PL_curcop; 609EOC 610 611void 612AUTOLOAD() 613 PROTOTYPE: DISABLE 614 PREINIT: 615 SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv)); 616 const COP *cop = PL_curcop; 617EOA 618 print $xs_fh <<"EOC"; 619 PPCODE: 620#ifndef SYMBIAN 621 /* It's not obvious how to calculate this at C pre-processor time. 622 However, any compiler optimiser worth its salt should be able to 623 remove the dead code, and hopefully the now-obviously-unused static 624 function too. */ 625 HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) 626 ? get_missing_hash(aTHX) : NULL; 627 if ((C_ARRAY_LENGTH(values_for_notfound) > 1) 628 ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { 629 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 630 ", used at %" COP_FILE_F " line %" UVuf "\\n", 631 sv, COP_FILE(cop), (UV)CopLINE(cop)); 632 } else 633#endif 634 { 635 sv = newSVpvf("%" SVf 636 " is not a valid $package_sprintf_safe macro at %" 637 COP_FILE_F " line %" UVuf "\\n", 638 sv, COP_FILE(cop), (UV)CopLINE(cop)); 639 } 640 croak_sv(sv_2mortal(sv)); 641EOC 642 } else { 643 print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT"; 644 645void 646$xs_subname(sv) 647 INPUT: 648 SV * sv; 649 PPCODE: 650 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 651 ", used", sv); 652 PUSHs(sv_2mortal(sv)); 653EXPLODE 654 655void 656$xs_subname(sv) 657 INPUT: 658 SV * sv; 659 PPCODE: 660#ifndef SYMBIAN 661 /* It's not obvious how to calculate this at C pre-processor time. 662 However, any compiler optimiser worth its salt should be able to 663 remove the dead code, and hopefully the now-obviously-unused static 664 function too. */ 665 HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) 666 ? get_missing_hash(aTHX) : NULL; 667 if ((C_ARRAY_LENGTH(values_for_notfound) > 1) 668 ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { 669 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 670 ", used", sv); 671 } else 672#endif 673 { 674 sv = newSVpvf("%" SVf " is not a valid $package_sprintf_safe macro", 675 sv); 676 } 677 PUSHs(sv_2mortal(sv)); 678DONT 679 } 680} 681 6821; 683