Mercurial > repo
comparison perl-5.22.2/regen/embed.pl @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
8044:711c038a7dce | 8045:a16537d2fe07 |
---|---|
1 #!/usr/bin/perl -w | |
2 # | |
3 # Regenerate (overwriting only if changed): | |
4 # | |
5 # embed.h | |
6 # embedvar.h | |
7 # perlapi.c | |
8 # perlapi.h | |
9 # proto.h | |
10 # | |
11 # from information stored in | |
12 # | |
13 # embed.fnc | |
14 # intrpvar.h | |
15 # perlvars.h | |
16 # regen/opcodes | |
17 # | |
18 # Accepts the standard regen_lib -q and -v args. | |
19 # | |
20 # This script is normally invoked from regen.pl. | |
21 | |
22 require 5.004; # keep this compatible, an old perl is all we may have before | |
23 # we build the new one | |
24 | |
25 use strict; | |
26 | |
27 BEGIN { | |
28 # Get function prototypes | |
29 require 'regen/regen_lib.pl'; | |
30 require 'regen/embed_lib.pl'; | |
31 } | |
32 | |
33 my $SPLINT = 0; # Turn true for experimental splint support http://www.splint.org | |
34 my $unflagged_pointers; | |
35 | |
36 # | |
37 # See database of global and static function prototypes in embed.fnc | |
38 # This is used to generate prototype headers under various configurations, | |
39 # export symbols lists for different platforms, and macros to provide an | |
40 # implicit interpreter context argument. | |
41 # | |
42 | |
43 sub full_name ($$) { # Returns the function name with potentially the | |
44 # prefixes 'S_' or 'Perl_' | |
45 my ($func, $flags) = @_; | |
46 | |
47 return "S_$func" if $flags =~ /[si]/; | |
48 return "Perl_$func" if $flags =~ /[bp]/; | |
49 return $func; | |
50 } | |
51 | |
52 sub open_print_header { | |
53 my ($file, $quote) = @_; | |
54 | |
55 return open_new($file, '>', | |
56 { file => $file, style => '*', by => 'regen/embed.pl', | |
57 from => ['data in embed.fnc', 'regen/embed.pl', | |
58 'regen/opcodes', 'intrpvar.h', 'perlvars.h'], | |
59 final => "\nEdit those files and run 'make regen_headers' to effect changes.\n", | |
60 copyright => [1993 .. 2009], quote => $quote }); | |
61 } | |
62 | |
63 my ($embed, $core, $ext, $api) = setup_embed(); | |
64 | |
65 # generate proto.h | |
66 { | |
67 my $pr = open_print_header("proto.h"); | |
68 print $pr "START_EXTERN_C\n"; | |
69 my $ret; | |
70 | |
71 foreach (@$embed) { | |
72 if (@$_ == 1) { | |
73 print $pr "$_->[0]\n"; | |
74 next; | |
75 } | |
76 | |
77 my ($flags,$retval,$plain_func,@args) = @$_; | |
78 my @nonnull; | |
79 my $has_context = ( $flags !~ /n/ ); | |
80 my $never_returns = ( $flags =~ /r/ ); | |
81 my $commented_out = ( $flags =~ /m/ ); | |
82 my $binarycompat = ( $flags =~ /b/ ); | |
83 my $is_malloc = ( $flags =~ /a/ ); | |
84 my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc; | |
85 my @names_of_nn; | |
86 my $func; | |
87 | |
88 if (! $can_ignore && $retval eq 'void') { | |
89 warn "It is nonsensical to require the return value of a void function ($plain_func) to be checked"; | |
90 } | |
91 | |
92 my $scope_type_flag_count = 0; | |
93 $scope_type_flag_count++ if $flags =~ /s/; | |
94 $scope_type_flag_count++ if $flags =~ /i/; | |
95 $scope_type_flag_count++ if $flags =~ /p/; | |
96 warn "$plain_func: i, p, and s flags are all mutually exclusive" | |
97 if $scope_type_flag_count > 1; | |
98 my $splint_flags = ""; | |
99 if ( $SPLINT && !$commented_out ) { | |
100 $splint_flags .= '/*@noreturn@*/ ' if $never_returns; | |
101 if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) { | |
102 $retval .= " /*\@alt void\@*/"; | |
103 } | |
104 } | |
105 | |
106 if ($flags =~ /([si])/) { | |
107 my $type; | |
108 if ($never_returns) { | |
109 $type = $1 eq 's' ? "PERL_STATIC_NO_RET" : "PERL_STATIC_INLINE_NO_RET"; | |
110 } | |
111 else { | |
112 $type = $1 eq 's' ? "STATIC" : "PERL_STATIC_INLINE"; | |
113 } | |
114 $retval = "$type $splint_flags$retval"; | |
115 } | |
116 else { | |
117 if ($never_returns) { | |
118 $retval = "PERL_CALLCONV_NO_RET $splint_flags$retval"; | |
119 } | |
120 else { | |
121 $retval = "PERL_CALLCONV $splint_flags$retval"; | |
122 } | |
123 } | |
124 $func = full_name($plain_func, $flags); | |
125 $ret = "$retval\t$func("; | |
126 if ( $has_context ) { | |
127 $ret .= @args ? "pTHX_ " : "pTHX"; | |
128 } | |
129 if (@args) { | |
130 my $n; | |
131 for my $arg ( @args ) { | |
132 ++$n; | |
133 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) { | |
134 warn "$func: $arg needs NN or NULLOK\n"; | |
135 ++$unflagged_pointers; | |
136 } | |
137 my $nn = ( $arg =~ s/\s*\bNN\b\s+// ); | |
138 push( @nonnull, $n ) if $nn; | |
139 | |
140 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect | |
141 | |
142 # Make sure each arg has at least a type and a var name. | |
143 # An arg of "int" is valid C, but want it to be "int foo". | |
144 my $temp_arg = $arg; | |
145 $temp_arg =~ s/\*//g; | |
146 $temp_arg =~ s/\s*\bstruct\b\s*/ /g; | |
147 if ( ($temp_arg ne "...") | |
148 && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) { | |
149 warn "$func: $arg ($n) doesn't have a name\n"; | |
150 } | |
151 if ( $SPLINT && $nullok && !$commented_out ) { | |
152 $arg = '/*@null@*/ ' . $arg; | |
153 } | |
154 if (defined $1 && $nn && !($commented_out && !$binarycompat)) { | |
155 push @names_of_nn, $1; | |
156 } | |
157 } | |
158 $ret .= join ", ", @args; | |
159 } | |
160 else { | |
161 $ret .= "void" if !$has_context; | |
162 } | |
163 $ret .= ")"; | |
164 my @attrs; | |
165 if ( $flags =~ /r/ ) { | |
166 push @attrs, "__attribute__noreturn__"; | |
167 } | |
168 if ( $flags =~ /D/ ) { | |
169 push @attrs, "__attribute__deprecated__"; | |
170 } | |
171 if ( $is_malloc ) { | |
172 push @attrs, "__attribute__malloc__"; | |
173 } | |
174 if ( !$can_ignore ) { | |
175 push @attrs, "__attribute__warn_unused_result__"; | |
176 } | |
177 if ( $flags =~ /P/ ) { | |
178 push @attrs, "__attribute__pure__"; | |
179 } | |
180 if( $flags =~ /f/ ) { | |
181 my $prefix = $has_context ? 'pTHX_' : ''; | |
182 my ($args, $pat); | |
183 if ($args[-1] eq '...') { | |
184 $args = scalar @args; | |
185 $pat = $args - 1; | |
186 $args = $prefix . $args; | |
187 } | |
188 else { | |
189 # don't check args, and guess which arg is the pattern | |
190 # (one of 'fmt', 'pat', 'f'), | |
191 $args = 0; | |
192 my @fmts = grep $args[$_] =~ /\b(f|pat|fmt)$/, 0..$#args; | |
193 if (@fmts != 1) { | |
194 die "embed.pl: '$plain_func': can't determine pattern arg\n"; | |
195 } | |
196 $pat = $fmts[0] + 1; | |
197 } | |
198 my $macro = grep($_ == $pat, @nonnull) | |
199 ? '__attribute__format__' | |
200 : '__attribute__format__null_ok__'; | |
201 if ($plain_func =~ /strftime/) { | |
202 push @attrs, sprintf "%s(__strftime__,%s1,0)", $macro, $prefix; | |
203 } | |
204 else { | |
205 push @attrs, sprintf "%s(__printf__,%s%d,%s)", $macro, | |
206 $prefix, $pat, $args; | |
207 } | |
208 } | |
209 if ( @nonnull ) { | |
210 my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull; | |
211 push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos; | |
212 } | |
213 if ( @attrs ) { | |
214 $ret .= "\n"; | |
215 $ret .= join( "\n", map { "\t\t\t$_" } @attrs ); | |
216 } | |
217 $ret .= ";"; | |
218 $ret = "/* $ret */" if $commented_out; | |
219 if (@names_of_nn) { | |
220 $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t" | |
221 . join '; ', map "assert($_)", @names_of_nn; | |
222 } | |
223 $ret .= @attrs ? "\n\n" : "\n"; | |
224 | |
225 print $pr $ret; | |
226 } | |
227 | |
228 print $pr <<'EOF'; | |
229 #ifdef PERL_CORE | |
230 # include "pp_proto.h" | |
231 #endif | |
232 END_EXTERN_C | |
233 EOF | |
234 | |
235 read_only_bottom_close_and_rename($pr); | |
236 } | |
237 | |
238 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers; | |
239 | |
240 sub readvars { | |
241 my ($file, $pre) = @_; | |
242 local (*FILE, $_); | |
243 my %seen; | |
244 open(FILE, "< $file") | |
245 or die "embed.pl: Can't open $file: $!\n"; | |
246 while (<FILE>) { | |
247 s/[ \t]*#.*//; # Delete comments. | |
248 if (/PERLVARA?I?C?\($pre,\s*(\w+)/) { | |
249 warn "duplicate symbol $1 while processing $file line $.\n" | |
250 if $seen{$1}++; | |
251 } | |
252 } | |
253 close(FILE); | |
254 return sort keys %seen; | |
255 } | |
256 | |
257 my @intrp = readvars 'intrpvar.h','I'; | |
258 my @globvar = readvars 'perlvars.h','G'; | |
259 | |
260 sub hide { | |
261 my ($from, $to, $indent) = @_; | |
262 $indent = '' unless defined $indent; | |
263 my $t = int(length("$indent$from") / 8); | |
264 "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n"; | |
265 } | |
266 | |
267 sub multon ($$$) { | |
268 my ($sym,$pre,$ptr) = @_; | |
269 hide("PL_$sym", "($ptr$pre$sym)"); | |
270 } | |
271 | |
272 my $em = open_print_header('embed.h'); | |
273 | |
274 print $em <<'END'; | |
275 /* (Doing namespace management portably in C is really gross.) */ | |
276 | |
277 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms | |
278 * (like warn instead of Perl_warn) for the API are not defined. | |
279 * Not defining the short forms is a good thing for cleaner embedding. */ | |
280 | |
281 #ifndef PERL_NO_SHORT_NAMES | |
282 | |
283 /* Hide global symbols */ | |
284 | |
285 END | |
286 | |
287 my @az = ('a'..'z'); | |
288 | |
289 sub embed_h { | |
290 my ($guard, $funcs) = @_; | |
291 print $em "$guard\n" if $guard; | |
292 | |
293 my $lines; | |
294 foreach (@$funcs) { | |
295 if (@$_ == 1) { | |
296 my $cond = $_->[0]; | |
297 # Indent the conditionals if we are wrapped in an #if/#endif pair. | |
298 $cond =~ s/#(.*)/# $1/ if $guard; | |
299 $lines .= "$cond\n"; | |
300 next; | |
301 } | |
302 my $ret = ""; | |
303 my ($flags,$retval,$func,@args) = @$_; | |
304 unless ($flags =~ /[om]/) { | |
305 my $args = scalar @args; | |
306 if ($flags =~ /n/) { | |
307 $ret = hide($func, full_name($func, $flags)); | |
308 } | |
309 elsif ($args and $args[$args-1] =~ /\.\.\./) { | |
310 if ($flags =~ /p/) { | |
311 # we're out of luck for varargs functions under CPP | |
312 # So we can only do these macros for no implicit context: | |
313 $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n" | |
314 . hide($func, full_name($func, $flags)) . "#endif\n"; | |
315 } | |
316 } | |
317 else { | |
318 my $alist = join(",", @az[0..$args-1]); | |
319 $ret = "#define $func($alist)"; | |
320 my $t = int(length($ret) / 8); | |
321 $ret .= "\t" x ($t < 4 ? 4 - $t : 1); | |
322 $ret .= full_name($func, $flags) . "(aTHX"; | |
323 $ret .= "_ " if $alist; | |
324 $ret .= $alist . ")\n"; | |
325 } | |
326 } | |
327 $lines .= $ret; | |
328 } | |
329 # Prune empty #if/#endif pairs. | |
330 while ($lines =~ s/#\s*if[^\n]+\n#\s*endif\n//) { | |
331 } | |
332 # Merge adjacent blocks. | |
333 while ($lines =~ s/(#ifndef PERL_IMPLICIT_CONTEXT | |
334 [^\n]+ | |
335 )#endif | |
336 #ifndef PERL_IMPLICIT_CONTEXT | |
337 /$1/) { | |
338 } | |
339 | |
340 print $em $lines; | |
341 print $em "#endif\n" if $guard; | |
342 } | |
343 | |
344 embed_h('', $api); | |
345 embed_h('#if defined(PERL_CORE) || defined(PERL_EXT)', $ext); | |
346 embed_h('#ifdef PERL_CORE', $core); | |
347 | |
348 print $em <<'END'; | |
349 | |
350 #endif /* #ifndef PERL_NO_SHORT_NAMES */ | |
351 | |
352 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to | |
353 disable them. | |
354 */ | |
355 | |
356 #if !defined(PERL_CORE) | |
357 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr)) | |
358 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr)) | |
359 #endif | |
360 | |
361 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) | |
362 | |
363 /* Compatibility for various misnamed functions. All functions | |
364 in the API that begin with "perl_" (not "Perl_") take an explicit | |
365 interpreter context pointer. | |
366 The following are not like that, but since they had a "perl_" | |
367 prefix in previous versions, we provide compatibility macros. | |
368 */ | |
369 # define perl_atexit(a,b) call_atexit(a,b) | |
370 END | |
371 | |
372 foreach (@$embed) { | |
373 my ($flags, $retval, $func, @args) = @$_; | |
374 next unless $func; | |
375 next unless $flags =~ /O/; | |
376 | |
377 my $alist = join ",", @az[0..$#args]; | |
378 my $ret = "# define perl_$func($alist)"; | |
379 my $t = (length $ret) >> 3; | |
380 $ret .= "\t" x ($t < 5 ? 5 - $t : 1); | |
381 print $em "$ret$func($alist)\n"; | |
382 } | |
383 | |
384 my @nocontext; | |
385 { | |
386 my (%has_va, %has_nocontext); | |
387 foreach (@$embed) { | |
388 next unless @$_ > 1; | |
389 ++$has_va{$_->[2]} if $_->[-1] =~ /\.\.\./; | |
390 ++$has_nocontext{$1} if $_->[2] =~ /(.*)_nocontext/; | |
391 } | |
392 | |
393 @nocontext = sort grep { | |
394 $has_nocontext{$_} | |
395 && !/printf/ # Not clear to me why these are skipped but they are. | |
396 } keys %has_va; | |
397 } | |
398 | |
399 print $em <<'END'; | |
400 | |
401 /* varargs functions can't be handled with CPP macros. :-( | |
402 This provides a set of compatibility functions that don't take | |
403 an extra argument but grab the context pointer using the macro | |
404 dTHX. | |
405 */ | |
406 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES) | |
407 END | |
408 | |
409 foreach (@nocontext) { | |
410 print $em hide($_, "Perl_${_}_nocontext", " "); | |
411 } | |
412 | |
413 print $em <<'END'; | |
414 #endif | |
415 | |
416 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */ | |
417 | |
418 #if !defined(PERL_IMPLICIT_CONTEXT) | |
419 /* undefined symbols, point them back at the usual ones */ | |
420 END | |
421 | |
422 foreach (@nocontext) { | |
423 print $em hide("Perl_${_}_nocontext", "Perl_$_", " "); | |
424 } | |
425 | |
426 print $em <<'END'; | |
427 #endif | |
428 END | |
429 | |
430 read_only_bottom_close_and_rename($em); | |
431 | |
432 $em = open_print_header('embedvar.h'); | |
433 | |
434 print $em <<'END'; | |
435 /* (Doing namespace management portably in C is really gross.) */ | |
436 | |
437 /* | |
438 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT | |
439 are supported: | |
440 1) none | |
441 2) MULTIPLICITY # supported for compatibility | |
442 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT | |
443 | |
444 All other combinations of these flags are errors. | |
445 | |
446 only #3 is supported directly, while #2 is a special | |
447 case of #3 (supported by redefining vTHX appropriately). | |
448 */ | |
449 | |
450 #if defined(MULTIPLICITY) | |
451 /* cases 2 and 3 above */ | |
452 | |
453 # if defined(PERL_IMPLICIT_CONTEXT) | |
454 # define vTHX aTHX | |
455 # else | |
456 # define vTHX PERL_GET_INTERP | |
457 # endif | |
458 | |
459 END | |
460 | |
461 my $sym; | |
462 | |
463 for $sym (@intrp) { | |
464 if ($sym eq 'sawampersand') { | |
465 print $em "#ifndef PL_sawampersand\n"; | |
466 } | |
467 print $em multon($sym,'I','vTHX->'); | |
468 if ($sym eq 'sawampersand') { | |
469 print $em "#endif\n"; | |
470 } | |
471 } | |
472 | |
473 print $em <<'END'; | |
474 | |
475 #endif /* MULTIPLICITY */ | |
476 | |
477 #if defined(PERL_GLOBAL_STRUCT) | |
478 | |
479 END | |
480 | |
481 for $sym (@globvar) { | |
482 print $em "#ifdef OS2\n" if $sym eq 'sh_path'; | |
483 print $em multon($sym, 'G','my_vars->'); | |
484 print $em multon("G$sym",'', 'my_vars->'); | |
485 print $em "#endif\n" if $sym eq 'sh_path'; | |
486 } | |
487 | |
488 print $em <<'END'; | |
489 | |
490 #endif /* PERL_GLOBAL_STRUCT */ | |
491 END | |
492 | |
493 read_only_bottom_close_and_rename($em); | |
494 | |
495 my $capih = open_print_header('perlapi.h'); | |
496 | |
497 print $capih <<'EOT'; | |
498 /* declare accessor functions for Perl variables */ | |
499 #ifndef __perlapi_h__ | |
500 #define __perlapi_h__ | |
501 | |
502 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT) | |
503 | |
504 START_EXTERN_C | |
505 | |
506 #undef PERLVAR | |
507 #undef PERLVARA | |
508 #undef PERLVARI | |
509 #undef PERLVARIC | |
510 #define PERLVAR(p,v,t) EXTERN_C t* Perl_##p##v##_ptr(pTHX); | |
511 #define PERLVARA(p,v,n,t) typedef t PL_##v##_t[n]; \ | |
512 EXTERN_C PL_##v##_t* Perl_##p##v##_ptr(pTHX); | |
513 #define PERLVARI(p,v,t,i) PERLVAR(p,v,t) | |
514 #define PERLVARIC(p,v,t,i) PERLVAR(p,v, const t) | |
515 | |
516 #include "perlvars.h" | |
517 | |
518 #undef PERLVAR | |
519 #undef PERLVARA | |
520 #undef PERLVARI | |
521 #undef PERLVARIC | |
522 | |
523 END_EXTERN_C | |
524 | |
525 #if defined(PERL_CORE) | |
526 | |
527 /* accessor functions for Perl "global" variables */ | |
528 | |
529 /* these need to be mentioned here, or most linkers won't put them in | |
530 the perl executable */ | |
531 | |
532 #ifndef PERL_NO_FORCE_LINK | |
533 | |
534 START_EXTERN_C | |
535 | |
536 #ifndef DOINIT | |
537 EXTCONST void * const PL_force_link_funcs[]; | |
538 #else | |
539 EXTCONST void * const PL_force_link_funcs[] = { | |
540 #undef PERLVAR | |
541 #undef PERLVARA | |
542 #undef PERLVARI | |
543 #undef PERLVARIC | |
544 #define PERLVAR(p,v,t) (void*)Perl_##p##v##_ptr, | |
545 #define PERLVARA(p,v,n,t) PERLVAR(p,v,t) | |
546 #define PERLVARI(p,v,t,i) PERLVAR(p,v,t) | |
547 #define PERLVARIC(p,v,t,i) PERLVAR(p,v,t) | |
548 | |
549 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one | |
550 * cannot cast between void pointers and function pointers without | |
551 * info level warnings. The PL_force_link_funcs[] would cause a few | |
552 * hundred of those warnings. In code one can circumnavigate this by using | |
553 * unions that overlay the different pointers, but in declarations one | |
554 * cannot use this trick. Therefore we just disable the warning here | |
555 * for the duration of the PL_force_link_funcs[] declaration. */ | |
556 | |
557 #if defined(__DECC) && defined(__osf__) | |
558 #pragma message save | |
559 #pragma message disable (nonstandcast) | |
560 #endif | |
561 | |
562 #include "perlvars.h" | |
563 | |
564 #if defined(__DECC) && defined(__osf__) | |
565 #pragma message restore | |
566 #endif | |
567 | |
568 #undef PERLVAR | |
569 #undef PERLVARA | |
570 #undef PERLVARI | |
571 #undef PERLVARIC | |
572 }; | |
573 #endif /* DOINIT */ | |
574 | |
575 END_EXTERN_C | |
576 | |
577 #endif /* PERL_NO_FORCE_LINK */ | |
578 | |
579 #else /* !PERL_CORE */ | |
580 | |
581 EOT | |
582 | |
583 foreach $sym (@globvar) { | |
584 print $capih | |
585 "#undef PL_$sym\n" . hide("PL_$sym", "(*Perl_G${sym}_ptr(NULL))"); | |
586 } | |
587 | |
588 print $capih <<'EOT'; | |
589 | |
590 #endif /* !PERL_CORE */ | |
591 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */ | |
592 | |
593 #endif /* __perlapi_h__ */ | |
594 EOT | |
595 | |
596 read_only_bottom_close_and_rename($capih); | |
597 | |
598 my $capi = open_print_header('perlapi.c', <<'EOQ'); | |
599 * | |
600 * | |
601 * Up to the threshold of the door there mounted a flight of twenty-seven | |
602 * broad stairs, hewn by some unknown art of the same black stone. This | |
603 * was the only entrance to the tower; ... | |
604 * | |
605 * [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"] | |
606 * | |
607 */ | |
608 EOQ | |
609 | |
610 print $capi <<'EOT'; | |
611 #include "EXTERN.h" | |
612 #include "perl.h" | |
613 #include "perlapi.h" | |
614 | |
615 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT) | |
616 | |
617 /* accessor functions for Perl "global" variables */ | |
618 START_EXTERN_C | |
619 | |
620 #undef PERLVARI | |
621 #define PERLVARI(p,v,t,i) PERLVAR(p,v,t) | |
622 | |
623 #undef PERLVAR | |
624 #undef PERLVARA | |
625 #define PERLVAR(p,v,t) t* Perl_##p##v##_ptr(pTHX) \ | |
626 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } | |
627 #define PERLVARA(p,v,n,t) PL_##v##_t* Perl_##p##v##_ptr(pTHX) \ | |
628 { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); } | |
629 #undef PERLVARIC | |
630 #define PERLVARIC(p,v,t,i) \ | |
631 const t* Perl_##p##v##_ptr(pTHX) \ | |
632 { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); } | |
633 #include "perlvars.h" | |
634 | |
635 #undef PERLVAR | |
636 #undef PERLVARA | |
637 #undef PERLVARI | |
638 #undef PERLVARIC | |
639 | |
640 END_EXTERN_C | |
641 | |
642 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */ | |
643 EOT | |
644 | |
645 read_only_bottom_close_and_rename($capi); | |
646 | |
647 # ex: set ts=8 sts=4 sw=4 noet: |