xref: /openbsd-src/gnu/usr.bin/perl/cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm (revision 5759b3d249badf144a6240f7eec4dcf9df003e6b)
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, &not_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