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.08'; 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 Perl_croak($athx "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 Perl_croak(aTHX_ 310 "Your vendor has not defined $package_sprintf_safe macro %"SVf 311 " used", sv); 312 NORETURN_FUNCTION_END; 313} 314 315static MGVTBL not_defined_vtbl = { 316 Im_sorry_Dave, /* get - I'm afraid I can't do that */ 317 Im_sorry_Dave, /* set */ 318 0, /* len */ 319 0, /* clear */ 320 0, /* free */ 321 0, /* copy */ 322 0, /* dup */ 323}; 324 325EXPLODE 326 327{ 328 my $key = $symbol_table; 329 # Just seems tidier (and slightly more space efficient) not to have keys 330 # such as Fcntl:: 331 $key =~ s/::$//; 332 my $key_len = length $key; 333 334 print $c_fh <<"MISSING"; 335 336#ifndef SYMBIAN 337 338/* Store a hash of all symbols missing from the package. To avoid trampling on 339 the package namespace (uninvited) put each package's hash in our namespace. 340 To avoid creating lots of typeblogs and symbol tables for sub-packages, put 341 each package's hash into one hash in our namespace. */ 342 343static HV * 344get_missing_hash(pTHX) { 345 HV *const parent 346 = get_hv("ExtUtils::Constant::ProxySubs::Missing", GVf_MULTI); 347 /* We could make a hash of hashes directly, but this would confuse anything 348 at Perl space that looks at us, and as we're visible in Perl space, 349 best to play nice. */ 350 SV *const *const ref 351 = hv_fetch(parent, "$key", $key_len, TRUE); 352 HV *new_hv; 353 354 if (!ref) 355 return NULL; 356 357 if (SvROK(*ref)) 358 return (HV*) SvRV(*ref); 359 360 new_hv = newHV(); 361 SvUPGRADE(*ref, SVt_RV); 362 SvRV_set(*ref, (SV *)new_hv); 363 SvROK_on(*ref); 364 return new_hv; 365} 366 367#endif 368 369MISSING 370 371} 372 373 print $xs_fh <<"EOBOOT"; 374BOOT: 375 { 376#ifdef dTHX 377 dTHX; 378#endif 379 HV *symbol_table = get_hv("$symbol_table", GV_ADD); 380EOBOOT 381 if ($push) { 382 print $xs_fh <<"EOC"; 383 AV *push = get_av(\"$push\", GV_ADD); 384 HE *he; 385EOC 386 } 387 388 my %iterator; 389 390 $found->{''} 391 = [map {{%$_, type=>'', invert_macro => 1}} @$notfound]; 392 393 foreach my $type (sort keys %$found) { 394 my $struct = $type_to_struct{$type}; 395 my $type_to_value = $self->type_to_C_value($type); 396 my $number_of_args = $type_num_args{$type}; 397 die "Can't find structure definition for type $type" 398 unless defined $struct; 399 400 my $lc_type = $type ? lc($type) : 'notfound'; 401 my $struct_type = $lc_type . '_s'; 402 my $array_name = 'values_for_' . $lc_type; 403 $iterator{$type} = 'value_for_' . $lc_type; 404 # Give the notfound struct file scope. The others are scoped within the 405 # BOOT block 406 my $struct_fh = $type ? $xs_fh : $c_fh; 407 408 print $c_fh "struct $struct_type $struct;\n"; 409 410 print $struct_fh <<"EOBOOT"; 411 412 static const struct $struct_type $array_name\[] = 413 { 414EOBOOT 415 416 417 foreach my $item (@{$found->{$type}}) { 418 my ($name, $namelen, $value, $macro) 419 = $self->name_len_value_macro($item); 420 421 my $ifdef = $self->macro_to_ifdef($macro); 422 if (!$ifdef && $item->{invert_macro}) { 423 carp("Attempting to supply a default for '$name' which has no conditional macro"); 424 next; 425 } 426 if ($item->{invert_macro}) { 427 print $struct_fh $self->macro_to_ifndef($macro); 428 print $struct_fh 429 " /* This is the default value: */\n" if $type; 430 } else { 431 print $struct_fh $ifdef; 432 } 433 print $struct_fh " { ", join (', ', "\"$name\"", $namelen, 434 &$type_to_value($value)), 435 " },\n", 436 $self->macro_to_endif($macro); 437 } 438 439 # Terminate the list with a NULL 440 print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n"; 441 442 print $xs_fh <<"EOBOOT" if $type; 443 const struct $struct_type *$iterator{$type} = $array_name; 444EOBOOT 445 } 446 447 delete $found->{''}; 448 449 my $add_symbol_subname = $c_subname . '_add_symbol'; 450 foreach my $type (sort keys %$found) { 451 print $xs_fh $self->boottime_iterator($type, $iterator{$type}, 452 'symbol_table', 453 $add_symbol_subname, $push); 454 } 455 456 print $xs_fh <<"EOBOOT"; 457 if (C_ARRAY_LENGTH(values_for_notfound) > 1) { 458#ifndef SYMBIAN 459 HV *const ${c_subname}_missing = get_missing_hash(aTHX); 460#endif 461 const struct notfound_s *value_for_notfound = values_for_notfound; 462 do { 463EOBOOT 464 465 print $xs_fh $explosives ? <<"EXPLODE" : << "DONT"; 466 SV *tripwire = newSV(0); 467 468 sv_magicext(tripwire, 0, PERL_MAGIC_ext, ¬_defined_vtbl, 0, 0); 469 SvPV_set(tripwire, (char *)value_for_notfound->name); 470 if(value_for_notfound->namelen >= 0) { 471 SvCUR_set(tripwire, value_for_notfound->namelen); 472 } else { 473 SvCUR_set(tripwire, -value_for_notfound->namelen); 474 SvUTF8_on(tripwire); 475 } 476 SvPOKp_on(tripwire); 477 SvREADONLY_on(tripwire); 478 assert(SvLEN(tripwire) == 0); 479 480 $add_symbol_subname($athx symbol_table, value_for_notfound->name, 481 value_for_notfound->namelen, tripwire); 482EXPLODE 483 484 /* Need to add prototypes, else parsing will vary by platform. */ 485 HE *he = (HE*) hv_common_key_len(symbol_table, 486 value_for_notfound->name, 487 value_for_notfound->namelen, 488 HV_FETCH_LVALUE, NULL, 0); 489 SV *sv; 490#ifndef SYMBIAN 491 HEK *hek; 492#endif 493 if (!he) { 494 Perl_croak($athx 495 "Couldn't add key '%s' to %%$package_sprintf_safe\::", 496 value_for_notfound->name); 497 } 498 sv = HeVAL(he); 499 if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) { 500 /* Nothing was here before, so mark a prototype of "" */ 501 sv_setpvn(sv, "", 0); 502 } else if (SvPOK(sv) && SvCUR(sv) == 0) { 503 /* There is already a prototype of "" - do nothing */ 504 } else { 505 /* Someone has been here before us - have to make a real 506 typeglob. */ 507 /* It turns out to be incredibly hard to deal with all the 508 corner cases of sub foo (); and reporting errors correctly, 509 so lets cheat a bit. Start with a constant subroutine */ 510 CV *cv = newCONSTSUB(symbol_table, 511 ${cast_CONSTSUB}value_for_notfound->name, 512 &PL_sv_yes); 513 /* and then turn it into a non constant declaration only. */ 514 SvREFCNT_dec(CvXSUBANY(cv).any_ptr); 515 CvCONST_off(cv); 516 CvXSUB(cv) = NULL; 517 CvXSUBANY(cv).any_ptr = NULL; 518 } 519#ifndef SYMBIAN 520 hek = HeKEY_hek(he); 521 if (!hv_common(${c_subname}_missing, NULL, HEK_KEY(hek), 522 HEK_LEN(hek), HEK_FLAGS(hek), HV_FETCH_ISSTORE, 523 &PL_sv_yes, HEK_HASH(hek))) 524 Perl_croak($athx "Couldn't add key '%s' to missing_hash", 525 value_for_notfound->name); 526#endif 527DONT 528 529 print $xs_fh " av_push(push, newSVhek(hek));\n" 530 if $push; 531 532 print $xs_fh <<"EOBOOT"; 533 } while ((++value_for_notfound)->name); 534 } 535EOBOOT 536 537 foreach my $item (@$trouble) { 538 my ($name, $namelen, $value, $macro) 539 = $self->name_len_value_macro($item); 540 my $ifdef = $self->macro_to_ifdef($macro); 541 my $type = $item->{type}; 542 my $type_to_value = $self->type_to_C_value($type); 543 544 print $xs_fh $ifdef; 545 if ($item->{invert_macro}) { 546 print $xs_fh 547 " /* This is the default value: */\n" if $type; 548 print $xs_fh "#else\n"; 549 } 550 my $generator = $type_to_sv{$type}; 551 die "Can't find generator code for type $type" 552 unless defined $generator; 553 554 print $xs_fh " {\n"; 555 # We need to use a temporary value because some really troublesome 556 # items use C pre processor directives in their values, and in turn 557 # these don't fit nicely in the macro-ised generator functions 558 my $counter = 0; 559 printf $xs_fh " %s temp%d;\n", $_, $counter++ 560 foreach @{$type_temporary{$type}}; 561 562 print $xs_fh " $item->{pre}\n" if $item->{pre}; 563 564 # And because the code in pre might be both declarations and 565 # statements, we can't declare and assign to the temporaries in one. 566 $counter = 0; 567 printf $xs_fh " temp%d = %s;\n", $counter++, $_ 568 foreach &$type_to_value($value); 569 570 my @tempvarnames = map {sprintf 'temp%d', $_} 0 .. $counter - 1; 571 printf $xs_fh <<"EOBOOT", $name, &$generator(@tempvarnames); 572 ${c_subname}_add_symbol($athx symbol_table, "%s", 573 $namelen, %s); 574EOBOOT 575 print $xs_fh " $item->{post}\n" if $item->{post}; 576 print $xs_fh " }\n"; 577 578 print $xs_fh $self->macro_to_endif($macro); 579 } 580 581 if ($] >= 5.009) { 582 print $xs_fh <<EOBOOT; 583 /* As we've been creating subroutines, we better invalidate any cached 584 methods */ 585 mro_method_changed_in(symbol_table); 586 } 587EOBOOT 588 } else { 589 print $xs_fh <<EOBOOT; 590 /* As we've been creating subroutines, we better invalidate any cached 591 methods */ 592 ++PL_sub_generation; 593 } 594EOBOOT 595 } 596 597 return if !defined $xs_subname; 598 599 if ($croak_on_error || $autoload) { 600 print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA'; 601 602void 603$xs_subname(sv) 604 INPUT: 605 SV * sv; 606 PREINIT: 607 const PERL_CONTEXT *cx = caller_cx(0, NULL); 608 /* cx is NULL if we've been called from the top level. PL_curcop isn't 609 ideal, but it's much cheaper than other ways of not going SEGV. */ 610 const COP *cop = cx ? cx->blk_oldcop : PL_curcop; 611EOC 612 613void 614AUTOLOAD() 615 PROTOTYPE: DISABLE 616 PREINIT: 617 SV *sv = newSVpvn_flags(SvPVX(cv), SvCUR(cv), SVs_TEMP | SvUTF8(cv)); 618 const COP *cop = PL_curcop; 619EOA 620 print $xs_fh <<"EOC"; 621 PPCODE: 622#ifndef SYMBIAN 623 /* It's not obvious how to calculate this at C pre-processor time. 624 However, any compiler optimiser worth its salt should be able to 625 remove the dead code, and hopefully the now-obviously-unused static 626 function too. */ 627 HV *${c_subname}_missing = (C_ARRAY_LENGTH(values_for_notfound) > 1) 628 ? get_missing_hash(aTHX) : NULL; 629 if ((C_ARRAY_LENGTH(values_for_notfound) > 1) 630 ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) { 631 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf 632 ", used at %" COP_FILE_F " line %d\\n", sv, 633 COP_FILE(cop), CopLINE(cop)); 634 } else 635#endif 636 { 637 sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro at %" 638 COP_FILE_F " line %d\\n", sv, COP_FILE(cop), 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