Commit | Line | Data |
---|---|---|
8b09643d NC |
1 | #!/usr/bin/perl -w |
2 | # | |
3 | # Regenerate (overwriting only if changed): | |
4 | # | |
16bc0f48 | 5 | # mg_names.inc |
130e6ef5 | 6 | # mg_raw.h |
8b09643d | 7 | # mg_vtable.h |
1083e5c1 | 8 | # pod/perlguts.pod |
8b09643d | 9 | # |
1083e5c1 FC |
10 | # from information stored in this file. pod/perlguts.pod is not completely |
11 | # regenerated. Only the magic table is replaced; the other parts remain | |
12 | # untouched. | |
8b09643d NC |
13 | # |
14 | # Accepts the standard regen_lib -q and -v args. | |
15 | # | |
16 | # This script is normally invoked from regen.pl. | |
e558f276 DM |
17 | # |
18 | # Its output files contain: | |
19 | # | |
20 | # mg_names.inc | |
21 | # included by dump.c - the textual representation for each magic type. | |
22 | # Contains a list of | |
23 | # | |
24 | # { PERL_MAGIC_foo, "foo(f)" } | |
25 | # | |
26 | # pairs. | |
27 | # | |
28 | # | |
29 | # mg_raw.h | |
30 | # processed by generate_uudmap.c into mg_data.h which eventually | |
31 | # populates PL_magic_vtables[]. | |
32 | # | |
33 | # Contains a list of: | |
34 | # | |
35 | # { 'f', "want_vtbl_foo | FLAGS", "description for comments" } | |
36 | # | |
37 | # triplets. FLAGS can be: | |
38 | # PERL_MAGIC_READONLY_ACCEPTABLE | |
39 | # ok set this type of magic on an SvREADONLY() SV | |
40 | # PERL_MAGIC_VALUE_MAGIC | |
41 | # this is value magic (pos, taint etc) | |
42 | # rather than container magic (%ENV, $1 etc) | |
43 | # | |
44 | # | |
45 | # mg_vtable.h | |
46 | # This contains five kinds of entries: | |
47 | # | |
48 | # #define PERL_MAGIC_arylen '#' | |
49 | # .... | |
50 | # | |
51 | # enum { /* pass one of these to get_vtbl */ | |
52 | # want_vtbl_arylen, | |
53 | # ... | |
54 | # } | |
55 | # | |
56 | # PL_magic_vtable_names[] = { | |
57 | # "arylen", | |
58 | # ... | |
59 | # } | |
60 | # | |
61 | # PL_magic_vtables[] = { | |
62 | # /* per-magic sets of vtable function pointers */ | |
63 | # { get, set, len, clear, free, copy, dup, local }, | |
64 | # } | |
65 | # | |
66 | # define PL_vtbl_arylen PL_magic_vtables[want_vtbl_arylen] | |
67 | # .... | |
68 | # | |
69 | # | |
70 | # | |
71 | # pod/perlguts.pod | |
72 | # updates the list of magic types between | |
73 | # =for mg_vtable.pl begin | |
74 | # ... | |
75 | # =for mg_vtable.pl end | |
76 | ||
8b09643d NC |
77 | |
78 | use strict; | |
79 | require 5.004; | |
80 | ||
81 | BEGIN { | |
82 | # Get function prototypes | |
3d7c117d | 83 | require './regen/regen_lib.pl'; |
8b09643d NC |
84 | } |
85 | ||
e558f276 DM |
86 | # ===================================================================== |
87 | # | |
88 | # START OF CONFIGURATION DATA | |
89 | ||
90 | ||
91 | # %mg | |
92 | # | |
93 | # This hash is mainly concerned with populating all the other stuff | |
94 | # ancillary to the vtable. | |
95 | # | |
96 | # The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata | |
97 | # | |
98 | # The keys of the value hash are: | |
99 | # char | |
100 | # the magic's char identifier | |
101 | # | |
102 | # desc | |
103 | # a description which appears in code comments in generated files | |
104 | # | |
105 | # readonly_acceptable | |
106 | # If true, set PERL_MAGIC_READONLY_ACCEPTABLE flag; | |
107 | # SvREADONLY() svs are allowed to have this magic added to them | |
108 | # | |
109 | # unknown_to_sv_magic | |
110 | # if true, this isn't one of the standard magic types which | |
111 | # Perl_sv_magic() knows how to deal with | |
112 | # | |
113 | # value_magic | |
114 | # If true, set PERL_MAGIC_VALUE_MAGIC flag; | |
115 | # this kind of magic is value (pos, taint etc) rather than | |
116 | # container magic (%ENV, $1 etc) | |
117 | # | |
118 | # vtable | |
119 | # name of the vtable lookup enum, e.g. 'foo' creates want_vtbl_foo | |
120 | ||
23cfd2fc | 121 | my %mg = |
6f83ef0e | 122 | ( |
9cce4f9a | 123 | sv => { char => "\0", vtable => 'sv', readonly_acceptable => 1, |
9824c081 | 124 | desc => 'Special scalar variable' }, |
bd6e6c12 FC |
125 | # overload, or type "A" magic, used to be here. Hence overloaded is |
126 | # often called AMAGIC internally, even though it does not use "A" | |
127 | # magic any more. | |
6f83ef0e | 128 | overload_table => { char => 'c', vtable => 'ovrld', |
9824c081 | 129 | desc => 'Holds overload table (AMT) on stash' }, |
e0a73de4 | 130 | bm => { char => 'B', vtable => 'regexp', value_magic => 1, |
9824c081 MS |
131 | readonly_acceptable => 1, |
132 | desc => 'Boyer-Moore (fast string search)' }, | |
6f83ef0e | 133 | regdata => { char => 'D', vtable => 'regdata', |
9824c081 | 134 | desc => "Regex match position data\n(\@+ and \@- vars)" }, |
6f83ef0e | 135 | regdatum => { char => 'd', vtable => 'regdatum', |
9824c081 | 136 | desc => 'Regex match position data element' }, |
6f83ef0e NC |
137 | env => { char => 'E', vtable => 'env', desc => '%ENV hash' }, |
138 | envelem => { char => 'e', vtable => 'envelem', | |
9824c081 | 139 | desc => '%ENV hash element' }, |
eccba044 | 140 | fm => { char => 'f', vtable => 'regexp', value_magic => 1, |
9824c081 | 141 | readonly_acceptable => 1, desc => "Formline ('compiled' format)" }, |
e0a73de4 | 142 | regex_global => { char => 'g', vtable => 'mglob', value_magic => 1, |
9824c081 | 143 | readonly_acceptable => 1, desc => 'm//g target' }, |
6f83ef0e NC |
144 | hints => { char => 'H', vtable => 'hints', desc => '%^H hash' }, |
145 | hintselem => { char => 'h', vtable => 'hintselem', | |
9824c081 | 146 | desc => '%^H hash element' }, |
6f83ef0e NC |
147 | isa => { char => 'I', vtable => 'isa', desc => '@ISA array' }, |
148 | isaelem => { char => 'i', vtable => 'isaelem', | |
9824c081 | 149 | desc => '@ISA array element' }, |
e0a73de4 | 150 | nkeys => { char => 'k', vtable => 'nkeys', value_magic => 1, |
9824c081 | 151 | desc => 'scalar(keys()) lvalue' }, |
f34d1562 | 152 | dbfile => { char => 'L', |
9824c081 | 153 | desc => 'Debugger %_<filename' }, |
f34d1562 | 154 | dbline => { char => 'l', vtable => 'dbline', |
9824c081 | 155 | desc => 'Debugger %_<filename element' }, |
6f83ef0e | 156 | shared => { char => 'N', desc => 'Shared between threads', |
9824c081 | 157 | unknown_to_sv_magic => 1 }, |
6f83ef0e | 158 | shared_scalar => { char => 'n', desc => 'Shared between threads', |
9824c081 | 159 | unknown_to_sv_magic => 1 }, |
e0a73de4 | 160 | collxfrm => { char => 'o', vtable => 'collxfrm', value_magic => 1, |
9824c081 | 161 | desc => 'Locale transformation' }, |
e0a73de4 | 162 | tied => { char => 'P', vtable => 'pack', |
9824c081 MS |
163 | value_magic => 1, # treat as value, so 'local @tied' isn't tied |
164 | desc => 'Tied array or hash' }, | |
6f83ef0e | 165 | tiedelem => { char => 'p', vtable => 'packelem', |
9824c081 | 166 | desc => 'Tied array or hash element' }, |
6f83ef0e | 167 | tiedscalar => { char => 'q', vtable => 'packelem', |
9824c081 | 168 | desc => 'Tied scalar or handle' }, |
e0a73de4 | 169 | qr => { char => 'r', vtable => 'regexp', value_magic => 1, |
9824c081 | 170 | readonly_acceptable => 1, desc => 'Precompiled qr// regex' }, |
55f5e765 LT |
171 | sig => { char => 'S', vtable => 'sig', |
172 | desc => '%SIG hash' }, | |
6f83ef0e | 173 | sigelem => { char => 's', vtable => 'sigelem', |
9824c081 | 174 | desc => '%SIG hash element' }, |
e0a73de4 | 175 | taint => { char => 't', vtable => 'taint', value_magic => 1, |
9824c081 | 176 | desc => 'Taintedness' }, |
6f83ef0e | 177 | uvar => { char => 'U', vtable => 'uvar', |
9824c081 | 178 | desc => 'Available for use by extensions' }, |
6f83ef0e | 179 | uvar_elem => { char => 'u', desc => 'Reserved for use by extensions', |
9824c081 | 180 | unknown_to_sv_magic => 1 }, |
e0a73de4 | 181 | vec => { char => 'v', vtable => 'vec', value_magic => 1, |
9824c081 | 182 | desc => 'vec() lvalue' }, |
4499db73 | 183 | vstring => { char => 'V', value_magic => 1, |
9824c081 | 184 | desc => 'SV was vstring literal' }, |
e0a73de4 | 185 | utf8 => { char => 'w', vtable => 'utf8', value_magic => 1, |
9824c081 | 186 | desc => 'Cached UTF-8 information' }, |
e0a73de4 | 187 | substr => { char => 'x', vtable => 'substr', value_magic => 1, |
9824c081 | 188 | desc => 'substr() lvalue' }, |
e0a73de4 | 189 | defelem => { char => 'y', vtable => 'defelem', value_magic => 1, |
9824c081 | 190 | desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" }, |
1f1dcfb5 | 191 | nonelem => { char => 'Y', vtable => 'nonelem', value_magic => 1, |
9824c081 | 192 | desc => "Array element that does not exist" }, |
e0a73de4 | 193 | arylen => { char => '#', vtable => 'arylen', value_magic => 1, |
9824c081 | 194 | desc => 'Array length ($#ary)' }, |
e0a73de4 | 195 | pos => { char => '.', vtable => 'pos', value_magic => 1, |
9824c081 | 196 | desc => 'pos() lvalue' }, |
e0a73de4 | 197 | backref => { char => '<', vtable => 'backref', value_magic => 1, |
9824c081 | 198 | readonly_acceptable => 1, desc => 'For weak ref data' }, |
e0a73de4 | 199 | symtab => { char => ':', value_magic => 1, |
9824c081 | 200 | desc => 'Extra data for symbol tables' }, |
e0a73de4 | 201 | rhash => { char => '%', value_magic => 1, |
9824c081 | 202 | desc => 'Extra data for restricted hashes' }, |
e0a73de4 | 203 | arylen_p => { char => '@', value_magic => 1, |
9824c081 | 204 | desc => 'To move arylen out of XPVAV' }, |
1d5686ec | 205 | ext => { char => '~', desc => 'Available for use by extensions', |
9824c081 | 206 | readonly_acceptable => 1 }, |
09fb282d | 207 | checkcall => { char => ']', value_magic => 1, vtable => 'checkcall', |
9824c081 | 208 | desc => 'Inlining/mutation of call to this CV'}, |
a6d69523 | 209 | debugvar => { char => '*', desc => '$DB::single, signal, trace vars', |
9824c081 | 210 | vtable => 'debugvar' }, |
9cce4f9a | 211 | lvref => { char => '\\', vtable => 'lvref', |
9824c081 | 212 | desc => "Lvalue reference constructor" }, |
6f83ef0e NC |
213 | ); |
214 | ||
e558f276 DM |
215 | |
216 | # %sig | |
217 | # | |
218 | # This hash is mainly concerned with populating the vtable. | |
219 | # (despite the name it has nothing to do with signals!) | |
220 | # | |
0a1f728a | 221 | # These have a subtly different "namespace" from the magic types. |
e558f276 DM |
222 | # |
223 | # The key is the name, e.g. 'regdata' for PERL_MAGIC_regdata | |
224 | # The keys of the value hash are: | |
225 | # | |
226 | # alias | |
227 | # for each entry in the anon array, add | |
228 | # add "#define want_vtbl_$_ want_vtbl_$name" | |
229 | # | |
230 | # cond | |
231 | # prefix the vtable with the specified entry (e.g. '#ifdef FOO') | |
232 | # and suffix it with '#else { 0, 0, 0, 0, 0, 0, 0, 0 } #endif' | |
233 | # | |
234 | # const | |
235 | # special-case cast a 'get' function whose signature expects | |
236 | # a pointer to constant magic, so that it can be added to a vtable | |
237 | # which expects pointers to functions without the 'const'. | |
238 | # | |
239 | # get | |
240 | # set | |
241 | # len | |
242 | # clear | |
243 | # free | |
244 | # copy | |
245 | # dup | |
246 | # local | |
247 | # For each specified method, add a vtable function pointer | |
248 | # of the form "Perl_magic_$sig{foo}{get}" etc | |
249 | ||
23cfd2fc | 250 | my %sig = |
8b09643d | 251 | ( |
9bb29b68 | 252 | 'sv' => {get => 'get', set => 'set'}, |
8b09643d NC |
253 | 'env' => {set => 'set_all_env', clear => 'clear_all_env'}, |
254 | 'envelem' => {set => 'setenv', clear => 'clearenv'}, | |
55f5e765 | 255 | 'sig' => { set => 'setsigall' }, |
8b09643d | 256 | 'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig', |
9824c081 | 257 | cond => '#ifndef PERL_MICRO'}, |
8b09643d NC |
258 | 'pack' => {len => 'sizepack', clear => 'wipepack'}, |
259 | 'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'}, | |
260 | 'dbline' => {set => 'setdbline'}, | |
261 | 'isa' => {set => 'setisa', clear => 'clearisa'}, | |
262 | 'isaelem' => {set => 'setisa'}, | |
263 | 'arylen' => {get => 'getarylen', set => 'setarylen', const => 1}, | |
83f29afa | 264 | 'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'}, |
02a48966 DM |
265 | 'mglob' => {set => 'setmglob', |
266 | free => 'freemglob' }, | |
8b09643d NC |
267 | 'nkeys' => {get => 'getnkeys', set => 'setnkeys'}, |
268 | 'taint' => {get => 'gettaint', set => 'settaint'}, | |
269 | 'substr' => {get => 'getsubstr', set => 'setsubstr'}, | |
270 | 'vec' => {get => 'getvec', set => 'setvec'}, | |
271 | 'pos' => {get => 'getpos', set => 'setpos'}, | |
8b09643d NC |
272 | 'uvar' => {get => 'getuvar', set => 'setuvar'}, |
273 | 'defelem' => {get => 'getdefelem', set => 'setdefelem'}, | |
1f1dcfb5 | 274 | 'nonelem' => {set => 'setnonelem'}, |
b2e9fc6f | 275 | 'regexp' => {set => 'setregexp', alias => [qw(bm fm)]}, |
8b09643d NC |
276 | 'regdata' => {len => 'regdata_cnt'}, |
277 | 'regdatum' => {get => 'regdatum_get', set => 'regdatum_set'}, | |
8b09643d NC |
278 | 'backref' => {free => 'killbackrefs'}, |
279 | 'ovrld' => {free => 'freeovrld'}, | |
032a4919 DM |
280 | 'utf8' => {set => 'setutf8', |
281 | free => 'freeutf8' }, | |
8b09643d | 282 | 'collxfrm' => {set => 'setcollxfrm', |
a457b73c | 283 | free => 'freecollxfrm', |
9824c081 | 284 | cond => '#ifdef USE_LOCALE_COLLATE'}, |
8b09643d NC |
285 | 'hintselem' => {set => 'sethint', clear => 'clearhint'}, |
286 | 'hints' => {clear => 'clearhints'}, | |
09fb282d | 287 | 'checkcall' => {copy => 'copycallchecker'}, |
a6d69523 | 288 | 'debugvar' => { set => 'setdebugvar', get => 'getdebugvar' }, |
9cce4f9a | 289 | 'lvref' => {set => 'setlvref'}, |
8b09643d NC |
290 | ); |
291 | ||
e558f276 DM |
292 | |
293 | # END OF CONFIGURATION DATA | |
294 | # | |
295 | # ===================================================================== | |
296 | ||
297 | ||
298 | ||
52f49505 | 299 | my ($vt, $raw, $names) = map { |
6f83ef0e | 300 | open_new($_, '>', |
9824c081 | 301 | { by => 'regen/mg_vtable.pl', file => $_, style => '*' }); |
16bc0f48 | 302 | } 'mg_vtable.h', 'mg_raw.h', 'mg_names.inc'; |
f1f5ddd7 | 303 | my $guts = open_new("pod/perlguts.pod", ">"); |
6f83ef0e | 304 | |
abf9aa7a NC |
305 | print $vt <<'EOH'; |
306 | /* These constants should be used in preference to raw characters | |
307 | * when using magic. Note that some perl guts still assume | |
308 | * certain character properties of these constants, namely that | |
309 | * isUPPER() and toLOWER() may do useful mappings. | |
310 | */ | |
311 | ||
312 | EOH | |
313 | ||
6f83ef0e NC |
314 | # Of course, it would be *much* easier if we could output this table directly |
315 | # here and now. However, for our sins, we try to support EBCDIC, which wouldn't | |
316 | # be *so* bad, except that there are (at least) 3 EBCDIC charset variants, and | |
317 | # they don't agree on the code point for '~'. Which we use. Great. | |
318 | # So we have to get the local build runtime to sort our table in character order | |
319 | # (And of course, just to be helpful, in POSIX BC '~' is \xFF, so we can't even | |
320 | # simplify the C code by assuming that the last element of the array is | |
321 | # predictable) | |
322 | ||
e558f276 DM |
323 | # Process %mg |
324 | ||
6f83ef0e | 325 | { |
e972d315 NC |
326 | my $longest = 0; |
327 | foreach (keys %mg) { | |
9824c081 | 328 | $longest = length $_ if length $_ > $longest; |
e972d315 NC |
329 | } |
330 | ||
52f49505 NC |
331 | my $longest_p1 = $longest + 1; |
332 | ||
23cfd2fc NC |
333 | my %mg_order; |
334 | while (my ($name, $data) = each %mg) { | |
9824c081 MS |
335 | my $byte = $data->{char}; |
336 | if ($byte =~ /[[:print:]]/) { | |
337 | $data->{r_char} = $byte; # readable char | |
338 | ($data->{c_char} = $byte) =~ s/([\\"])/\\$1/g; # for C strings | |
339 | } | |
340 | else { | |
341 | $data->{c_char} = $data->{r_char} = '\\'.ord $byte; | |
342 | } | |
343 | $mg_order{(uc $byte) . $byte} = $name; | |
23cfd2fc | 344 | } |
e558f276 | 345 | |
63e77aaf | 346 | my @rows; |
f2f5335a | 347 | my @names; |
23cfd2fc | 348 | foreach (sort keys %mg_order) { |
9824c081 | 349 | my $name = $mg_order{$_}; |
f2f5335a | 350 | push @names, $name; |
9824c081 MS |
351 | my $data = $mg{$name}; |
352 | my $i = ord $data->{char}; | |
e558f276 DM |
353 | |
354 | # add entry to mg_raw.h | |
355 | ||
9824c081 MS |
356 | unless ($data->{unknown_to_sv_magic}) { |
357 | my $value = $data->{vtable} | |
358 | ? "want_vtbl_$data->{vtable}" : 'magic_vtable_max'; | |
359 | $value .= ' | PERL_MAGIC_READONLY_ACCEPTABLE' | |
360 | if $data->{readonly_acceptable}; | |
361 | $value .= ' | PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic}; | |
362 | my $comment = "/* $name '$data->{r_char}' $data->{desc} */"; | |
363 | $comment =~ s/([\\"])/\\$1/g; | |
364 | $comment =~ tr/\n/ /; | |
365 | print $raw qq{ { '$data->{c_char}', "$value",\n "$comment" },\n}; | |
366 | } | |
abf9aa7a | 367 | |
e558f276 DM |
368 | # add #define PERL_MAGIC_foo entry to vt_table.h |
369 | ||
9824c081 MS |
370 | my $comment = $data->{desc}; |
371 | my $leader = ' ' x ($longest + 27); | |
372 | $comment =~ s/\n/\n$leader/s; | |
373 | printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n", | |
374 | $name, $data->{c_char}, $comment; | |
52f49505 | 375 | |
e558f276 DM |
376 | # add entry to mg_names.inc |
377 | ||
9824c081 MS |
378 | my $char = $data->{r_char}; |
379 | $char =~ s/([\\"])/\\$1/g; | |
380 | printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n], | |
381 | "$name,", $name, $char; | |
63e77aaf | 382 | |
e558f276 DM |
383 | # construct perlguts.pod entry |
384 | ||
9824c081 MS |
385 | push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{r_char},$name), |
386 | $data->{vtable} ? "vtbl_$data->{vtable}" : '(none)', | |
387 | $data->{desc}]; | |
63e77aaf | 388 | } |
e558f276 DM |
389 | |
390 | # output @rows to perlguts.pod | |
391 | ||
f1f5ddd7 | 392 | select +(select($guts), do { |
9824c081 MS |
393 | my @header = ('(old-style char and macro)', 'MGVTBL', 'Type of magic'); |
394 | my @widths = (0, 0); | |
395 | foreach my $row (@rows) { | |
396 | for (0, 1) { | |
397 | $widths[$_] = length $row->[$_] | |
398 | if length $row->[$_] > $widths[$_]; | |
399 | } | |
400 | } | |
401 | my $indent = ' '; | |
402 | my $format | |
403 | = sprintf "$indent%%-%ds%%-%ds%%s\n", $widths[0] + 1, $widths[1] + 1; | |
404 | my $desc_wrap = | |
405 | 79 - 7 - (length $indent) - $widths[0] - $widths[1] - 2; | |
406 | ||
407 | open my $oldguts, "<", "pod/perlguts.pod" | |
408 | or die "$0 cannot open pod/perlguts.pod for reading: $!"; | |
409 | while (<$oldguts>) { | |
410 | print; | |
411 | last if /^=for mg_vtable.pl begin/ | |
412 | } | |
413 | ||
414 | print "\n", $indent . "mg_type\n"; | |
415 | printf $format, @header; | |
416 | printf $format, map {'-' x length $_} @header; | |
417 | foreach (@rows) { | |
418 | my ($type, $vtbl, $desc) = @$_; | |
419 | $desc =~ tr/\n/ /; | |
420 | my @cont; | |
421 | if (length $desc > $desc_wrap) { | |
422 | # If it's too long, first split on '(', if there. | |
423 | # [Which, if there, is always short enough, currently. | |
424 | # Make this more robust if that changes] | |
425 | ($desc, @cont) = split /(?=\()/, $desc; | |
426 | if (!@cont) { | |
427 | ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g | |
428 | } | |
429 | } | |
430 | printf $format, $type, $vtbl, $desc; | |
431 | printf $format, '', '', $_ foreach @cont; | |
432 | } | |
433 | print "\n\n"; | |
f2f5335a | 434 | |
eb0444cb KW |
435 | my $first = 1; |
436 | for my $magic (sort @names) { | |
437 | if ($first) { | |
438 | $first = 0; | |
439 | print "=for apidoc AmnhU||PERL_MAGIC_$magic\n"; | |
440 | } | |
441 | else { | |
442 | print "=for apidoc_item ||PERL_MAGIC_$magic\n"; | |
443 | } | |
ed48408e | 444 | } |
f2f5335a | 445 | print "\n"; |
f1f5ddd7 | 446 | |
9824c081 MS |
447 | while (<$oldguts>) { |
448 | last if /^=for mg_vtable.pl end/; | |
449 | } | |
450 | do { print } while <$oldguts>; | |
f1f5ddd7 | 451 | })[0]; |
6f83ef0e | 452 | } |
8b09643d | 453 | |
e558f276 DM |
454 | |
455 | # Process %sig - everything goes to mg_vtable.h | |
456 | ||
23cfd2fc | 457 | my @names = sort keys %sig; |
ca298f7d | 458 | { |
2d1f1fe5 NC |
459 | my $want = join ",\n ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max'; |
460 | my $names = join qq{",\n "}, @names; | |
461 | ||
6f83ef0e | 462 | print $vt <<"EOH"; |
abf9aa7a | 463 | |
ca298f7d | 464 | enum { /* pass one of these to get_vtbl */ |
2d1f1fe5 NC |
465 | $want |
466 | }; | |
467 | ||
468 | #ifdef DOINIT | |
bfd14e52 | 469 | EXTCONST char * const PL_magic_vtable_names[magic_vtable_max] = { |
2d1f1fe5 | 470 | "$names" |
ca298f7d | 471 | }; |
2d1f1fe5 | 472 | #else |
bfd14e52 | 473 | EXTCONST char * const PL_magic_vtable_names[magic_vtable_max]; |
2d1f1fe5 | 474 | #endif |
ca298f7d NC |
475 | |
476 | EOH | |
477 | } | |
478 | ||
6f83ef0e | 479 | print $vt <<'EOH'; |
8b09643d NC |
480 | /* These all need to be 0, not NULL, as NULL can be (void*)0, which is a |
481 | * pointer to data, whereas we're assigning pointers to functions, which are | |
482 | * not the same beast. ANSI doesn't allow the assignment from one to the other. | |
483 | * (although most, but not all, compilers are prepared to do it) | |
484 | */ | |
485 | ||
0ffb5b03 | 486 | /* order is: |
8b09643d NC |
487 | get |
488 | set | |
489 | len | |
490 | clear | |
491 | free | |
492 | copy | |
493 | dup | |
494 | local | |
495 | */ | |
496 | ||
b7b5e578 | 497 | #ifdef DOINIT |
c7fdacb9 | 498 | EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = { |
8b09643d NC |
499 | EOH |
500 | ||
b7b5e578 | 501 | my @vtable_names; |
b2e9fc6f | 502 | my @aliases; |
b7b5e578 | 503 | |
23cfd2fc NC |
504 | while (my $name = shift @names) { |
505 | my $data = $sig{$name}; | |
b7b5e578 | 506 | push @vtable_names, $name; |
0a1f728a | 507 | my @funcs = map { |
9824c081 | 508 | $data->{$_} ? "Perl_magic_$data->{$_}" : 0; |
8b09643d NC |
509 | } qw(get set len clear free copy dup local); |
510 | ||
0a1f728a | 511 | $funcs[0] = "(int (*)(pTHX_ SV *, MAGIC *))" . $funcs[0] if $data->{const}; |
0ffb5b03 | 512 | my $funcs = join ", ", @funcs; |
8b09643d | 513 | |
b7b5e578 | 514 | # Because we can't have a , after the last {...} |
23cfd2fc | 515 | my $comma = @names ? ',' : ''; |
b7b5e578 | 516 | |
6f83ef0e NC |
517 | print $vt "$data->{cond}\n" if $data->{cond}; |
518 | print $vt " { $funcs }$comma\n"; | |
519 | print $vt <<"EOH" if $data->{cond}; | |
0ffb5b03 | 520 | #else |
b7b5e578 | 521 | { 0, 0, 0, 0, 0, 0, 0, 0 }$comma |
0ffb5b03 | 522 | #endif |
b7b5e578 | 523 | EOH |
b2e9fc6f | 524 | foreach(@{$data->{alias}}) { |
9824c081 MS |
525 | push @aliases, "#define want_vtbl_$_ want_vtbl_$name\n"; |
526 | push @vtable_names, $_; | |
b2e9fc6f | 527 | } |
8b09643d NC |
528 | } |
529 | ||
6f83ef0e | 530 | print $vt <<'EOH'; |
b7b5e578 NC |
531 | }; |
532 | #else | |
c7fdacb9 | 533 | EXT_MGVTBL PL_magic_vtables[magic_vtable_max]; |
b7b5e578 NC |
534 | #endif |
535 | ||
536 | EOH | |
537 | ||
6f83ef0e | 538 | print $vt (sort @aliases), "\n"; |
b7b5e578 | 539 | |
6f83ef0e | 540 | print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n" |
b7b5e578 NC |
541 | foreach sort @vtable_names; |
542 | ||
e0a73de4 NC |
543 | # 63, not 64, As we rely on the last possible value to mean "NULL vtable" |
544 | die "Too many vtable names" if @vtable_names > 63; | |
545 | ||
52f49505 | 546 | read_only_bottom_close_and_rename($_) foreach $vt, $raw, $names; |
9824c081 | 547 | close_and_rename($guts); |