This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
For PROXYSUBS, tables may sometimes have no entries.
[perl5.git] / cpan / ExtUtils-Constant / lib / ExtUtils / Constant / ProxySubs.pm
CommitLineData
6d7fb585
NC
1package ExtUtils::Constant::ProxySubs;
2
3use strict;
64bb7586 4use vars qw($VERSION @ISA %type_to_struct %type_from_struct %type_to_sv
6800c0cf
NC
5 %type_to_C_value %type_is_a_problem %type_num_args
6 %type_temporary);
6d7fb585
NC
7use Carp;
8require ExtUtils::Constant::XS;
9use ExtUtils::Constant::Utils qw(C_stringify);
10use ExtUtils::Constant::XS qw(%XS_TypeSet);
11
04777d29 12$VERSION = '0.08';
6d7fb585
NC
13@ISA = 'ExtUtils::Constant::XS';
14
15%type_to_struct =
16 (
17 IV => '{const char *name; I32 namelen; IV value;}',
64bb7586
NC
18 NV => '{const char *name; I32 namelen; NV value;}',
19 UV => '{const char *name; I32 namelen; UV value;}',
49657794 20 PV => '{const char *name; I32 namelen; const char *value;}',
6f226cd7 21 PVN => '{const char *name; I32 namelen; const char *value; STRLEN len;}',
64bb7586
NC
22 YES => '{const char *name; I32 namelen;}',
23 NO => '{const char *name; I32 namelen;}',
6f226cd7 24 UNDEF => '{const char *name; I32 namelen;}',
6d7fb585
NC
25 '' => '{const char *name; I32 namelen;} ',
26 );
27
64bb7586
NC
28%type_from_struct =
29 (
30 IV => sub { $_[0] . '->value' },
31 NV => sub { $_[0] . '->value' },
32 UV => sub { $_[0] . '->value' },
49657794 33 PV => sub { $_[0] . '->value' },
6f226cd7 34 PVN => sub { $_[0] . '->value', $_[0] . '->len' },
64bb7586
NC
35 YES => sub {},
36 NO => sub {},
6f226cd7 37 UNDEF => sub {},
64bb7586
NC
38 '' => sub {},
39 );
40
6d7fb585
NC
41%type_to_sv =
42 (
64bb7586
NC
43 IV => sub { "newSViv($_[0])" },
44 NV => sub { "newSVnv($_[0])" },
45 UV => sub { "newSVuv($_[0])" },
49657794 46 PV => sub { "newSVpv($_[0], 0)" },
6f226cd7 47 PVN => sub { "newSVpvn($_[0], $_[1])" },
64bb7586
NC
48 YES => sub { '&PL_sv_yes' },
49 NO => sub { '&PL_sv_no' },
0fcb9a02 50 UNDEF => sub { '&PL_sv_undef' },
6d7fb585 51 '' => sub { '&PL_sv_yes' },
2ebbb0c3 52 SV => sub {"SvREFCNT_inc($_[0])"},
6d7fb585
NC
53 );
54
55%type_to_C_value =
56 (
64bb7586
NC
57 YES => sub {},
58 NO => sub {},
0fcb9a02 59 UNDEF => sub {},
6d7fb585
NC
60 '' => sub {},
61 );
62
64bb7586
NC
63sub type_to_C_value {
64 my ($self, $type) = @_;
65 return $type_to_C_value{$type} || sub {return map {ref $_ ? @$_ : $_} @_};
66}
67
49657794
NC
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
6d7fb585
NC
71%type_is_a_problem =
72 (
2ebbb0c3 73 # The documentation says *mortal SV*, but we now need a non-mortal copy.
6d7fb585
NC
74 SV => 1,
75 );
76
49657794
NC
77%type_temporary =
78 (
6f226cd7
NC
79 SV => ['SV *'],
80 PV => ['const char *'],
81 PVN => ['const char *', 'STRLEN'],
49657794 82 );
6f226cd7 83$type_temporary{$_} = [$_] foreach qw(IV UV NV);
6800c0cf 84
6d7fb585 85while (my ($type, $value) = each %XS_TypeSet) {
64bb7586
NC
86 $type_num_args{$type}
87 = defined $value ? ref $value ? scalar @$value : 1 : 0;
6d7fb585
NC
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}
0fcb9a02 111 or !$self->macro_to_ifdef($self->macro_from_item($item));
6d7fb585
NC
112 }
113
64bb7586
NC
114 if ($item->{pre} or $item->{post} or $item->{not_constant}
115 or $type_is_a_problem{$item->{type}}) {
6d7fb585
NC
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 {
1c8d11ca 126 my ($self, $type, $iterator, $hash, $subname, $push) = @_;
64bb7586
NC
127 my $extractor = $type_from_struct{$type};
128 die "Can't find extractor code for type $type"
129 unless defined $extractor;
6d7fb585
NC
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
1c8d11ca
NC
136 if ($push) {
137 return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
ea37b99e 138 while ($iterator->name) {
1c8d11ca
NC
139 he = $subname($athx $hash, $iterator->name,
140 $iterator->namelen, %s);
141 av_push(push, newSVhek(HeKEY_hek(he)));
ea37b99e
JD
142 ++$iterator;
143 }
1c8d11ca
NC
144EOBOOT
145 } else {
146 return sprintf <<"EOBOOT", &$generator(&$extractor($iterator));
ea37b99e 147 while ($iterator->name) {
6d7fb585
NC
148 $subname($athx $hash, $iterator->name,
149 $iterator->namelen, %s);
ea37b99e
JD
150 ++$iterator;
151 }
6d7fb585 152EOBOOT
1c8d11ca 153 }
6d7fb585
NC
154}
155
64bb7586
NC
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
0fcb9a02 170 my $macro = $self->macro_from_item($item);
64bb7586
NC
171 ($name, $namelen, $value, $macro);
172}
173
6d7fb585
NC
174sub WriteConstants {
175 my $self = shift;
6b43b341 176 my $ARGS = {@_};
6d7fb585 177
cfe26641
NC
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';
6b43b341
NC
183
184 my $options = $ARGS->{PROXYSUBS};
185 $options = {} unless ref $options;
1c8d11ca 186 my $push = $options->{push};
6b43b341 187 my $explosives = $options->{croak_on_read};
04777d29 188 my $croak_on_error = $options->{croak_on_error};
c565ab54
NC
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 }
04777d29 200 # Strictly it requires Perl_caller_cx
1c8d11ca 201 carp ("PROXYSUBS option 'croak_on_error' requires v5.13.5 or later")
04777d29 202 if $croak_on_error && $^V < v5.13.5;
1c8d11ca
NC
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;
6d7fb585 211
fa6eee5a
NC
212 # If anyone is insane enough to suggest a package name containing %
213 my $package_sprintf_safe = $package;
214 $package_sprintf_safe =~ s/%/%%/g;
6d7fb585
NC
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},
6b43b341
NC
222 $default_type, $what, $items,
223 @{$ARGS->{NAMES}});
6d7fb585
NC
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
6d7fb585
NC
232 my $pthx = $self->C_constant_prefix_param_defintion();
233 my $athx = $self->C_constant_prefix_param();
234 my $symbol_table = C_stringify($package) . '::';
1c8d11ca 235 $push = C_stringify($package . '::' . $push) if $push;
54cea8cc
NC
236 my $cast_CONSTSUB = $] < 5.010 ? '(char *)' : '';
237
6736a914
NC
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
1c8d11ca
NC
253 my $return_type = $push ? 'HE *' : 'void';
254
6736a914
NC
255 print $c_fh <<"EOADD";
256
1c8d11ca 257static $return_type
9fb41657 258${c_subname}_add_symbol($pthx HV *hash, const char *name, I32 namelen, SV *value) {
54cea8cc
NC
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";
1c8d11ca
NC
266 HE *he = (HE*) hv_common_key_len(hash, name, namelen, HV_FETCH_LVALUE, NULL,
267 0);
268 SV *sv;
269
270 if (!he) {
fa6eee5a
NC
271 Perl_croak($athx "Couldn't add key '%s' to %%$package_sprintf_safe\::",
272 name);
0998eade 273 }
1c8d11ca
NC
274 sv = HeVAL(he);
275 if (SvOK(sv) || SvTYPE(sv) == SVt_PVGV) {
0998eade 276 /* Someone has been here before us - have to make a real sub. */
54cea8cc
NC
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';
0998eade 285 } else {
1c8d11ca
NC
286 SvUPGRADE(sv, SVt_RV);
287 SvRV_set(sv, value);
288 SvROK_on(sv);
abe8a887 289 SvREADONLY_on(value);
6d7fb585 290 }
54cea8cc
NC
291EO_PCS
292 } else {
293 print $c_fh <<'EO_NOPCS';
294 }
295EO_NOPCS
296 }
1c8d11ca 297 print $c_fh " return he;\n" if $push;
54cea8cc 298 print $c_fh <<'EOADD';
6d7fb585
NC
299}
300
6b43b341
NC
301EOADD
302
67a86ef3 303 print $c_fh $explosives ? <<"EXPLODE" : "\n";
6b43b341
NC
304
305static int
306Im_sorry_Dave(pTHX_ SV *sv, MAGIC *mg)
307{
308 PERL_UNUSED_ARG(mg);
fa6eee5a
NC
309 Perl_croak(aTHX_
310 "Your vendor has not defined $package_sprintf_safe macro %"SVf
311 " used", sv);
6b43b341
NC
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
26eb7f2f
NC
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
6d7fb585
NC
373 print $xs_fh <<"EOBOOT";
374BOOT:
375 {
376#ifdef dTHX
377 dTHX;
378#endif
8253c7d6 379 HV *symbol_table = get_hv("$symbol_table", GV_ADD);
6d7fb585 380EOBOOT
1c8d11ca
NC
381 if ($push) {
382 print $xs_fh <<"EOC";
383 AV *push = get_av(\"$push\", GV_ADD);
384 HE *he;
385EOC
386 }
6d7fb585
NC
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};
64bb7586 395 my $type_to_value = $self->type_to_C_value($type);
6d7fb585
NC
396 my $number_of_args = $type_num_args{$type};
397 die "Can't find structure definition for type $type"
398 unless defined $struct;
399
543340fb
NC
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;
214f5750
NC
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;
543340fb 407
6d7fb585
NC
408 print $c_fh "struct $struct_type $struct;\n";
409
214f5750 410 print $struct_fh <<"EOBOOT";
6d7fb585
NC
411
412 static const struct $struct_type $array_name\[] =
413 {
414EOBOOT
415
416
417 foreach my $item (@{$found->{$type}}) {
64bb7586
NC
418 my ($name, $namelen, $value, $macro)
419 = $self->name_len_value_macro($item);
6d7fb585 420
6d7fb585
NC
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 }
6d7fb585 426 if ($item->{invert_macro}) {
214f5750
NC
427 print $struct_fh $self->macro_to_ifndef($macro);
428 print $struct_fh
ad39d6d2
NC
429 " /* This is the default value: */\n" if $type;
430 } else {
214f5750 431 print $struct_fh $ifdef;
6d7fb585 432 }
214f5750
NC
433 print $struct_fh " { ", join (', ', "\"$name\"", $namelen,
434 &$type_to_value($value)),
435 " },\n",
6d7fb585
NC
436 $self->macro_to_endif($macro);
437 }
438
6d7fb585 439 # Terminate the list with a NULL
214f5750 440 print $struct_fh " { NULL, 0", (", 0" x $number_of_args), " } };\n";
6d7fb585 441
4639bd9c 442 print $xs_fh <<"EOBOOT" if $type;
6d7fb585 443 const struct $struct_type *$iterator{$type} = $array_name;
6d7fb585
NC
444EOBOOT
445 }
446
447 delete $found->{''};
6b43b341
NC
448
449 my $add_symbol_subname = $c_subname . '_add_symbol';
6d7fb585
NC
450 foreach my $type (sort keys %$found) {
451 print $xs_fh $self->boottime_iterator($type, $iterator{$type},
452 'symbol_table',
1c8d11ca 453 $add_symbol_subname, $push);
6d7fb585 454 }
6b43b341
NC
455
456 print $xs_fh <<"EOBOOT";
4639bd9c
NC
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 {
6b43b341
NC
463EOBOOT
464
465 print $xs_fh $explosives ? <<"EXPLODE" : << "DONT";
4639bd9c
NC
466 SV *tripwire = newSV(0);
467
468 sv_magicext(tripwire, 0, PERL_MAGIC_ext, &not_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);
6b43b341
NC
482EXPLODE
483
4639bd9c 484 /* Need to add prototypes, else parsing will vary by platform. */
010434d4
NC
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) {
4639bd9c
NC
494 Perl_croak($athx
495 "Couldn't add key '%s' to %%$package_sprintf_safe\::",
496 value_for_notfound->name);
497 }
010434d4
NC
498 sv = HeVAL(he);
499 if (!SvOK(sv) && SvTYPE(sv) != SVt_PVGV) {
4639bd9c 500 /* Nothing was here before, so mark a prototype of "" */
010434d4
NC
501 sv_setpvn(sv, "", 0);
502 } else if (SvPOK(sv) && SvCUR(sv) == 0) {
4639bd9c
NC
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 }
53d44271 519#ifndef SYMBIAN
010434d4
NC
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)))
4639bd9c
NC
524 Perl_croak($athx "Couldn't add key '%s' to missing_hash",
525 value_for_notfound->name);
53d44271 526#endif
6b43b341
NC
527DONT
528
1c8d11ca
NC
529 print $xs_fh " av_push(push, newSVhek(hek));\n"
530 if $push;
531
6b43b341 532 print $xs_fh <<"EOBOOT";
4639bd9c 533 } while ((++value_for_notfound)->name);
6d7fb585 534 }
6d7fb585
NC
535EOBOOT
536
64bb7586
NC
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
6f226cd7 554 print $xs_fh " {\n";
6800c0cf
NC
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
6f226cd7
NC
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);
2ebbb0c3
NC
572 ${c_subname}_add_symbol($athx symbol_table, "%s",
573 $namelen, %s);
64bb7586 574EOBOOT
2ebbb0c3
NC
575 print $xs_fh " $item->{post}\n" if $item->{post};
576 print $xs_fh " }\n";
64bb7586
NC
577
578 print $xs_fh $self->macro_to_endif($macro);
579 }
580
fb34c6ab
NC
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;
e1234d8e
NC
590 /* As we've been creating subroutines, we better invalidate any cached
591 methods */
592 ++PL_sub_generation;
64bb7586 593 }
6b43b341 594EOBOOT
fb34c6ab 595 }
6b43b341 596
cfe26641
NC
597 return if !defined $xs_subname;
598
c565ab54
NC
599 if ($croak_on_error || $autoload) {
600 print $xs_fh $croak_on_error ? <<"EOC" : <<'EOA';
04777d29
NC
601
602void
603$xs_subname(sv)
c565ab54
NC
604 INPUT:
605 SV * sv;
04777d29
NC
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;
c565ab54
NC
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";
04777d29
NC
621 PPCODE:
622#ifndef SYMBIAN
a0074a59
NC
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) {
04777d29 631 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
6736a914
NC
632 ", used at %" COP_FILE_F " line %d\\n", sv,
633 COP_FILE(cop), CopLINE(cop));
04777d29
NC
634 } else
635#endif
636 {
6736a914
NC
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));
04777d29
NC
639 }
640 croak_sv(sv_2mortal(sv));
641EOC
642 } else {
643 print $xs_fh $explosives ? <<"EXPLODE" : <<"DONT";
6b43b341
NC
644
645void
646$xs_subname(sv)
647 INPUT:
648 SV * sv;
649 PPCODE:
fa6eee5a 650 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
6b43b341
NC
651 ", used", sv);
652 PUSHs(sv_2mortal(sv));
653EXPLODE
6d7fb585
NC
654
655void
656$xs_subname(sv)
6d7fb585
NC
657 INPUT:
658 SV * sv;
6d7fb585 659 PPCODE:
0eedeed4 660#ifndef SYMBIAN
a0074a59
NC
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)
19b96a2b 668 ? hv_exists_ent(${c_subname}_missing, sv, 0) : 0) {
fa6eee5a 669 sv = newSVpvf("Your vendor has not defined $package_sprintf_safe macro %" SVf
6d7fb585 670 ", used", sv);
0eedeed4
NC
671 } else
672#endif
673 {
fa6eee5a
NC
674 sv = newSVpvf("%"SVf" is not a valid $package_sprintf_safe macro",
675 sv);
6d7fb585 676 }
53d44271 677 PUSHs(sv_2mortal(sv));
6b43b341 678DONT
04777d29 679 }
6d7fb585
NC
680}
681
6821;