Commit | Line | Data |
---|---|---|
8b09643d NC |
1 | #!/usr/bin/perl -w |
2 | # | |
3 | # Regenerate (overwriting only if changed): | |
4 | # | |
5 | # mg_vtable.h | |
1083e5c1 | 6 | # pod/perlguts.pod |
8b09643d | 7 | # |
1083e5c1 FC |
8 | # from information stored in this file. pod/perlguts.pod is not completely |
9 | # regenerated. Only the magic table is replaced; the other parts remain | |
10 | # untouched. | |
8b09643d NC |
11 | # |
12 | # Accepts the standard regen_lib -q and -v args. | |
13 | # | |
14 | # This script is normally invoked from regen.pl. | |
15 | ||
16 | use strict; | |
17 | require 5.004; | |
18 | ||
19 | BEGIN { | |
20 | # Get function prototypes | |
21 | require 'regen/regen_lib.pl'; | |
22 | } | |
23 | ||
23cfd2fc | 24 | my %mg = |
6f83ef0e | 25 | ( |
82ff486e NC |
26 | sv => { char => '\0', vtable => 'sv', readonly_acceptable => 1, |
27 | desc => 'Special scalar variable' }, | |
bd6e6c12 FC |
28 | # overload, or type "A" magic, used to be here. Hence overloaded is |
29 | # often called AMAGIC internally, even though it does not use "A" | |
30 | # magic any more. | |
6f83ef0e NC |
31 | overload_table => { char => 'c', vtable => 'ovrld', |
32 | desc => 'Holds overload table (AMT) on stash' }, | |
e0a73de4 | 33 | bm => { char => 'B', vtable => 'regexp', value_magic => 1, |
82ff486e | 34 | readonly_acceptable => 1, |
6f83ef0e NC |
35 | desc => 'Boyer-Moore (fast string search)' }, |
36 | regdata => { char => 'D', vtable => 'regdata', | |
abf9aa7a | 37 | desc => "Regex match position data\n(\@+ and \@- vars)" }, |
6f83ef0e NC |
38 | regdatum => { char => 'd', vtable => 'regdatum', |
39 | desc => 'Regex match position data element' }, | |
40 | env => { char => 'E', vtable => 'env', desc => '%ENV hash' }, | |
41 | envelem => { char => 'e', vtable => 'envelem', | |
42 | desc => '%ENV hash element' }, | |
e0a73de4 | 43 | fm => { char => 'f', vtable => 'regdata', value_magic => 1, |
82ff486e | 44 | readonly_acceptable => 1, desc => "Formline ('compiled' format)" }, |
e0a73de4 | 45 | regex_global => { char => 'g', vtable => 'mglob', value_magic => 1, |
0177730e | 46 | readonly_acceptable => 1, desc => 'm//g target' }, |
6f83ef0e NC |
47 | hints => { char => 'H', vtable => 'hints', desc => '%^H hash' }, |
48 | hintselem => { char => 'h', vtable => 'hintselem', | |
49 | desc => '%^H hash element' }, | |
50 | isa => { char => 'I', vtable => 'isa', desc => '@ISA array' }, | |
51 | isaelem => { char => 'i', vtable => 'isaelem', | |
52 | desc => '@ISA array element' }, | |
e0a73de4 | 53 | nkeys => { char => 'k', vtable => 'nkeys', value_magic => 1, |
6f83ef0e | 54 | desc => 'scalar(keys()) lvalue' }, |
f34d1562 | 55 | dbfile => { char => 'L', |
6f83ef0e | 56 | desc => 'Debugger %_<filename' }, |
f34d1562 FC |
57 | dbline => { char => 'l', vtable => 'dbline', |
58 | desc => 'Debugger %_<filename element' }, | |
6f83ef0e NC |
59 | shared => { char => 'N', desc => 'Shared between threads', |
60 | unknown_to_sv_magic => 1 }, | |
61 | shared_scalar => { char => 'n', desc => 'Shared between threads', | |
62 | unknown_to_sv_magic => 1 }, | |
e0a73de4 | 63 | collxfrm => { char => 'o', vtable => 'collxfrm', value_magic => 1, |
6f83ef0e | 64 | desc => 'Locale transformation' }, |
e0a73de4 NC |
65 | tied => { char => 'P', vtable => 'pack', |
66 | value_magic => 1, # treat as value, so 'local @tied' isn't tied | |
67 | desc => 'Tied array or hash' }, | |
6f83ef0e NC |
68 | tiedelem => { char => 'p', vtable => 'packelem', |
69 | desc => 'Tied array or hash element' }, | |
70 | tiedscalar => { char => 'q', vtable => 'packelem', | |
71 | desc => 'Tied scalar or handle' }, | |
e0a73de4 NC |
72 | qr => { char => 'r', vtable => 'regexp', value_magic => 1, |
73 | desc => 'precompiled qr// regex' }, | |
6f83ef0e NC |
74 | sig => { char => 'S', desc => '%SIG hash' }, |
75 | sigelem => { char => 's', vtable => 'sigelem', | |
76 | desc => '%SIG hash element' }, | |
e0a73de4 NC |
77 | taint => { char => 't', vtable => 'taint', value_magic => 1, |
78 | desc => 'Taintedness' }, | |
6f83ef0e NC |
79 | uvar => { char => 'U', vtable => 'uvar', |
80 | desc => 'Available for use by extensions' }, | |
81 | uvar_elem => { char => 'u', desc => 'Reserved for use by extensions', | |
82 | unknown_to_sv_magic => 1 }, | |
e0a73de4 NC |
83 | vec => { char => 'v', vtable => 'vec', value_magic => 1, |
84 | desc => 'vec() lvalue' }, | |
1e6bda93 | 85 | vstring => { char => 'V', value_magic => 1, vtable => 'vstring', |
e0a73de4 NC |
86 | desc => 'SV was vstring literal' }, |
87 | utf8 => { char => 'w', vtable => 'utf8', value_magic => 1, | |
6f83ef0e | 88 | desc => 'Cached UTF-8 information' }, |
e0a73de4 NC |
89 | substr => { char => 'x', vtable => 'substr', value_magic => 1, |
90 | desc => 'substr() lvalue' }, | |
91 | defelem => { char => 'y', vtable => 'defelem', value_magic => 1, | |
abf9aa7a | 92 | desc => "Shadow \"foreach\" iterator variable /\nsmart parameter vivification" }, |
e0a73de4 | 93 | arylen => { char => '#', vtable => 'arylen', value_magic => 1, |
6f83ef0e | 94 | desc => 'Array length ($#ary)' }, |
e0a73de4 NC |
95 | pos => { char => '.', vtable => 'pos', value_magic => 1, |
96 | desc => 'pos() lvalue' }, | |
97 | backref => { char => '<', vtable => 'backref', value_magic => 1, | |
82ff486e | 98 | readonly_acceptable => 1, desc => 'for weak ref data' }, |
e0a73de4 NC |
99 | symtab => { char => ':', value_magic => 1, |
100 | desc => 'extra data for symbol tables' }, | |
101 | rhash => { char => '%', value_magic => 1, | |
102 | desc => 'extra data for restricted hashes' }, | |
103 | arylen_p => { char => '@', value_magic => 1, | |
104 | desc => 'to move arylen out of XPVAV' }, | |
6f83ef0e | 105 | ext => { char => '~', desc => 'Available for use by extensions' }, |
09fb282d | 106 | checkcall => { char => ']', value_magic => 1, vtable => 'checkcall', |
e0a73de4 | 107 | desc => 'inlining/mutation of call to this CV'}, |
6f83ef0e NC |
108 | ); |
109 | ||
0a1f728a | 110 | # These have a subtly different "namespace" from the magic types. |
23cfd2fc | 111 | my %sig = |
8b09643d NC |
112 | ( |
113 | 'sv' => {get => 'get', set => 'set', len => 'len'}, | |
114 | 'env' => {set => 'set_all_env', clear => 'clear_all_env'}, | |
115 | 'envelem' => {set => 'setenv', clear => 'clearenv'}, | |
116 | 'sigelem' => {get => 'getsig', set => 'setsig', clear => 'clearsig', | |
117 | cond => '#ifndef PERL_MICRO'}, | |
118 | 'pack' => {len => 'sizepack', clear => 'wipepack'}, | |
119 | 'packelem' => {get => 'getpack', set => 'setpack', clear => 'clearpack'}, | |
120 | 'dbline' => {set => 'setdbline'}, | |
121 | 'isa' => {set => 'setisa', clear => 'clearisa'}, | |
122 | 'isaelem' => {set => 'setisa'}, | |
123 | 'arylen' => {get => 'getarylen', set => 'setarylen', const => 1}, | |
83f29afa | 124 | 'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'}, |
8b09643d NC |
125 | 'mglob' => {set => 'setmglob'}, |
126 | 'nkeys' => {get => 'getnkeys', set => 'setnkeys'}, | |
127 | 'taint' => {get => 'gettaint', set => 'settaint'}, | |
128 | 'substr' => {get => 'getsubstr', set => 'setsubstr'}, | |
129 | 'vec' => {get => 'getvec', set => 'setvec'}, | |
130 | 'pos' => {get => 'getpos', set => 'setpos'}, | |
8b09643d NC |
131 | 'uvar' => {get => 'getuvar', set => 'setuvar'}, |
132 | 'defelem' => {get => 'getdefelem', set => 'setdefelem'}, | |
b2e9fc6f | 133 | 'regexp' => {set => 'setregexp', alias => [qw(bm fm)]}, |
8b09643d NC |
134 | 'regdata' => {len => 'regdata_cnt'}, |
135 | 'regdatum' => {get => 'regdatum_get', set => 'regdatum_set'}, | |
8b09643d NC |
136 | 'backref' => {free => 'killbackrefs'}, |
137 | 'ovrld' => {free => 'freeovrld'}, | |
138 | 'utf8' => {set => 'setutf8'}, | |
139 | 'collxfrm' => {set => 'setcollxfrm', | |
140 | cond => '#ifdef USE_LOCALE_COLLATE'}, | |
141 | 'hintselem' => {set => 'sethint', clear => 'clearhint'}, | |
142 | 'hints' => {clear => 'clearhints'}, | |
1e6bda93 | 143 | 'vstring' => {set => 'setvstring'}, |
09fb282d | 144 | 'checkcall' => {copy => 'copycallchecker'}, |
8b09643d NC |
145 | ); |
146 | ||
52f49505 | 147 | my ($vt, $raw, $names) = map { |
6f83ef0e NC |
148 | open_new($_, '>', |
149 | { by => 'regen/mg_vtable.pl', file => $_, style => '*' }); | |
52f49505 | 150 | } 'mg_vtable.h', 'mg_raw.h', 'mg_names.c'; |
f1f5ddd7 | 151 | my $guts = open_new("pod/perlguts.pod", ">"); |
6f83ef0e | 152 | |
abf9aa7a NC |
153 | print $vt <<'EOH'; |
154 | /* These constants should be used in preference to raw characters | |
155 | * when using magic. Note that some perl guts still assume | |
156 | * certain character properties of these constants, namely that | |
157 | * isUPPER() and toLOWER() may do useful mappings. | |
158 | */ | |
159 | ||
160 | EOH | |
161 | ||
6f83ef0e NC |
162 | # Of course, it would be *much* easier if we could output this table directly |
163 | # here and now. However, for our sins, we try to support EBCDIC, which wouldn't | |
164 | # be *so* bad, except that there are (at least) 3 EBCDIC charset variants, and | |
165 | # they don't agree on the code point for '~'. Which we use. Great. | |
166 | # So we have to get the local build runtime to sort our table in character order | |
167 | # (And of course, just to be helpful, in POSIX BC '~' is \xFF, so we can't even | |
168 | # simplify the C code by assuming that the last element of the array is | |
169 | # predictable) | |
170 | ||
171 | { | |
e972d315 NC |
172 | my $longest = 0; |
173 | foreach (keys %mg) { | |
174 | $longest = length $_ if length $_ > $longest; | |
175 | } | |
176 | ||
52f49505 NC |
177 | my $longest_p1 = $longest + 1; |
178 | ||
23cfd2fc NC |
179 | my %mg_order; |
180 | while (my ($name, $data) = each %mg) { | |
181 | my $byte = eval qq{"$data->{char}"}; | |
182 | $data->{byte} = $byte; | |
183 | $mg_order{(uc $byte) . $byte} = $name; | |
184 | } | |
63e77aaf | 185 | my @rows; |
23cfd2fc NC |
186 | foreach (sort keys %mg_order) { |
187 | my $name = $mg_order{$_}; | |
188 | my $data = $mg{$name}; | |
189 | my $i = ord $data->{byte}; | |
6f83ef0e | 190 | unless ($data->{unknown_to_sv_magic}) { |
e0a73de4 | 191 | my $value = $data->{vtable} |
6f83ef0e | 192 | ? "want_vtbl_$data->{vtable}" : 'magic_vtable_max'; |
82ff486e NC |
193 | $value .= ' | PERL_MAGIC_READONLY_ACCEPTABLE' |
194 | if $data->{readonly_acceptable}; | |
e0a73de4 | 195 | $value .= ' | PERL_MAGIC_VALUE_MAGIC' if $data->{value_magic}; |
6f83ef0e NC |
196 | my $comment = "/* $name '$data->{char}' $data->{desc} */"; |
197 | $comment =~ s/([\\"])/\\$1/g; | |
abf9aa7a | 198 | $comment =~ tr/\n/ /; |
e0a73de4 | 199 | print $raw qq{ { '$data->{char}', "$value",\n "$comment" },\n}; |
6f83ef0e | 200 | } |
abf9aa7a NC |
201 | |
202 | my $comment = $data->{desc}; | |
203 | my $leader = ' ' x ($longest + 27); | |
204 | $comment =~ s/\n/\n$leader/s; | |
205 | printf $vt "#define PERL_MAGIC_%-${longest}s '%s' /* %s */\n", | |
206 | $name, $data->{char}, $comment; | |
52f49505 NC |
207 | |
208 | my $char = $data->{char}; | |
209 | $char =~ s/([\\"])/\\$1/g; | |
210 | printf $names qq[\t{ PERL_MAGIC_%-${longest_p1}s "%s(%s)" },\n], | |
211 | "$name,", $name, $char; | |
63e77aaf NC |
212 | |
213 | push @rows, [(sprintf "%-2s PERL_MAGIC_%s", $data->{char}, $name), | |
214 | $data->{vtable} ? "vtbl_$data->{vtable}" : '(none)', | |
215 | $data->{desc}]; | |
216 | } | |
f1f5ddd7 | 217 | select +(select($guts), do { |
63e77aaf NC |
218 | my @header = ('(old-style char and macro)', 'MGVTBL', 'Type of magic'); |
219 | my @widths = (0, 0); | |
220 | foreach my $row (@rows) { | |
221 | for (0, 1) { | |
222 | $widths[$_] = length $row->[$_] | |
223 | if length $row->[$_] > $widths[$_]; | |
224 | } | |
225 | } | |
f1f5ddd7 | 226 | my $indent = ' '; |
63e77aaf NC |
227 | my $format |
228 | = sprintf "$indent%%-%ds%%-%ds%%s\n", $widths[0] + 1, $widths[1] + 1; | |
f1f5ddd7 FC |
229 | my $desc_wrap = |
230 | 79 - 7 - (length $indent) - $widths[0] - $widths[1] - 2; | |
231 | ||
232 | open my $oldguts, "<", "pod/perlguts.pod" | |
233 | or die "$0 cannot open pod/perlguts.pod for reading: $!"; | |
234 | while (<$oldguts>) { | |
235 | print; | |
236 | last if /^=for mg_vtable.pl begin/ | |
237 | } | |
63e77aaf | 238 | |
f1f5ddd7 | 239 | print "\n", $indent . "mg_type\n"; |
63e77aaf NC |
240 | printf $format, @header; |
241 | printf $format, map {'-' x length $_} @header; | |
242 | foreach (@rows) { | |
243 | my ($type, $vtbl, $desc) = @$_; | |
244 | $desc =~ tr/\n/ /; | |
245 | my @cont; | |
246 | if (length $desc > $desc_wrap) { | |
247 | # If it's too long, first split on '(', if there. | |
248 | # [Which, if there, is always short enough, currently. | |
249 | # Make this more robust if that changes] | |
250 | ($desc, @cont) = split /(?=\()/, $desc; | |
251 | if (!@cont) { | |
252 | ($desc, @cont) = $desc =~ /(.{1,$desc_wrap})(?: |\z)/g | |
253 | } | |
254 | } | |
255 | printf $format, $type, $vtbl, $desc; | |
256 | printf $format, '', '', $_ foreach @cont; | |
257 | } | |
f1f5ddd7 FC |
258 | print "\n"; |
259 | ||
260 | while (<$oldguts>) { | |
261 | last if /^=for mg_vtable.pl end/; | |
262 | } | |
263 | do { print } while <$oldguts>; | |
264 | })[0]; | |
6f83ef0e | 265 | } |
8b09643d | 266 | |
23cfd2fc | 267 | my @names = sort keys %sig; |
ca298f7d | 268 | { |
2d1f1fe5 NC |
269 | my $want = join ",\n ", (map {"want_vtbl_$_"} @names), 'magic_vtable_max'; |
270 | my $names = join qq{",\n "}, @names; | |
271 | ||
6f83ef0e | 272 | print $vt <<"EOH"; |
abf9aa7a | 273 | |
ca298f7d | 274 | enum { /* pass one of these to get_vtbl */ |
2d1f1fe5 NC |
275 | $want |
276 | }; | |
277 | ||
278 | #ifdef DOINIT | |
279 | EXTCONST char *PL_magic_vtable_names[magic_vtable_max] = { | |
280 | "$names" | |
ca298f7d | 281 | }; |
2d1f1fe5 NC |
282 | #else |
283 | EXTCONST char *PL_magic_vtable_names[magic_vtable_max]; | |
284 | #endif | |
ca298f7d NC |
285 | |
286 | EOH | |
287 | } | |
288 | ||
6f83ef0e | 289 | print $vt <<'EOH'; |
8b09643d NC |
290 | /* These all need to be 0, not NULL, as NULL can be (void*)0, which is a |
291 | * pointer to data, whereas we're assigning pointers to functions, which are | |
292 | * not the same beast. ANSI doesn't allow the assignment from one to the other. | |
293 | * (although most, but not all, compilers are prepared to do it) | |
294 | */ | |
295 | ||
0ffb5b03 | 296 | /* order is: |
8b09643d NC |
297 | get |
298 | set | |
299 | len | |
300 | clear | |
301 | free | |
302 | copy | |
303 | dup | |
304 | local | |
305 | */ | |
306 | ||
b7b5e578 | 307 | #ifdef DOINIT |
c7fdacb9 | 308 | EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = { |
8b09643d NC |
309 | EOH |
310 | ||
b7b5e578 | 311 | my @vtable_names; |
b2e9fc6f | 312 | my @aliases; |
b7b5e578 | 313 | |
23cfd2fc NC |
314 | while (my $name = shift @names) { |
315 | my $data = $sig{$name}; | |
b7b5e578 | 316 | push @vtable_names, $name; |
0a1f728a | 317 | my @funcs = map { |
8b09643d NC |
318 | $data->{$_} ? "Perl_magic_$data->{$_}" : 0; |
319 | } qw(get set len clear free copy dup local); | |
320 | ||
0a1f728a | 321 | $funcs[0] = "(int (*)(pTHX_ SV *, MAGIC *))" . $funcs[0] if $data->{const}; |
0ffb5b03 | 322 | my $funcs = join ", ", @funcs; |
8b09643d | 323 | |
b7b5e578 | 324 | # Because we can't have a , after the last {...} |
23cfd2fc | 325 | my $comma = @names ? ',' : ''; |
b7b5e578 | 326 | |
6f83ef0e NC |
327 | print $vt "$data->{cond}\n" if $data->{cond}; |
328 | print $vt " { $funcs }$comma\n"; | |
329 | print $vt <<"EOH" if $data->{cond}; | |
0ffb5b03 | 330 | #else |
b7b5e578 | 331 | { 0, 0, 0, 0, 0, 0, 0, 0 }$comma |
0ffb5b03 | 332 | #endif |
b7b5e578 | 333 | EOH |
b2e9fc6f NC |
334 | foreach(@{$data->{alias}}) { |
335 | push @aliases, "#define want_vtbl_$_ want_vtbl_$name\n"; | |
336 | push @vtable_names, $_; | |
337 | } | |
8b09643d NC |
338 | } |
339 | ||
6f83ef0e | 340 | print $vt <<'EOH'; |
b7b5e578 NC |
341 | }; |
342 | #else | |
c7fdacb9 | 343 | EXT_MGVTBL PL_magic_vtables[magic_vtable_max]; |
b7b5e578 NC |
344 | #endif |
345 | ||
346 | EOH | |
347 | ||
6f83ef0e | 348 | print $vt (sort @aliases), "\n"; |
b7b5e578 | 349 | |
6f83ef0e | 350 | print $vt "#define PL_vtbl_$_ PL_magic_vtables[want_vtbl_$_]\n" |
b7b5e578 NC |
351 | foreach sort @vtable_names; |
352 | ||
e0a73de4 NC |
353 | # 63, not 64, As we rely on the last possible value to mean "NULL vtable" |
354 | die "Too many vtable names" if @vtable_names > 63; | |
355 | ||
52f49505 | 356 | read_only_bottom_close_and_rename($_) foreach $vt, $raw, $names; |
f1f5ddd7 | 357 | close_and_rename($guts); |