This patch with tests resolves CPAN RT #40727. The issue is an infi-
[perl.git] / embed.pl
1 #!/usr/bin/perl -w
2
3 # Regenerate (overwriting only if changed):
4 #
5 #    embed.h
6 #    embedvar.h
7 #    global.sym
8 #    perlapi.c
9 #    perlapi.h
10 #    proto.h
11 #
12 # from information stored in
13 #
14 #    embed.fnc
15 #    intrpvar.h
16 #    perlvars.h
17 #    pp.sym     (which has been generated by opcode.pl)
18 #
19 # Accepts the standard regen_lib -q and -v args.
20 #
21 # This script is normally invoked from regen.pl.
22
23 require 5.004;  # keep this compatible, an old perl is all we may have before
24                 # we build the new one
25
26 use strict;
27
28 BEGIN {
29     # Get function prototypes
30     require 'regen_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 do_not_edit ($)
44 {
45     my $file = shift;
46
47     my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009';
48
49     $years =~ s/1999,/1999,\n  / if length $years > 40;
50
51     my $warning = <<EOW;
52  -*- buffer-read-only: t -*-
53
54    $file
55
56    Copyright (C) $years, by Larry Wall and others
57
58    You may distribute under the terms of either the GNU General Public
59    License or the Artistic License, as specified in the README file.
60
61 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
62 This file is built by embed.pl from data in embed.fnc, embed.pl,
63 pp.sym, intrpvar.h, and perlvars.h.
64 Any changes made here will be lost!
65
66 Edit those files and run 'make regen_headers' to effect changes.
67
68 EOW
69
70     $warning .= <<EOW if $file eq 'perlapi.c';
71
72 Up to the threshold of the door there mounted a flight of twenty-seven
73 broad stairs, hewn by some unknown art of the same black stone.  This
74 was the only entrance to the tower; ...
75
76     [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
77
78
79 EOW
80
81     if ($file =~ m:\.[ch]$:) {
82         $warning =~ s:^: * :gm;
83         $warning =~ s: +$::gm;
84         $warning =~ s: :/:;
85         $warning =~ s:$:/:;
86     }
87     else {
88         $warning =~ s:^:# :gm;
89         $warning =~ s: +$::gm;
90     }
91     $warning;
92 } # do_not_edit
93
94 open IN, "embed.fnc" or die $!;
95
96 my @embed;
97 my (%has_va, %has_nocontext);
98
99 while (<IN>) {
100     chomp;
101     next if /^:/;
102     while (s|\\$||) {
103         $_ .= <IN>;
104         chomp;
105     }
106     s/\s+$//;
107     my @args;
108     if (/^\s*(#|$)/) {
109         @args = $_;
110     }
111     else {
112         @args = split /\s*\|\s*/, $_;
113         my $func = $args[2];
114         if ($func) {
115             ++$has_va{$func} if $args[-1] =~ /\.\.\./;
116             ++$has_nocontext{$1} if $func =~ /(.*)_nocontext/;
117         }
118     }
119     push @embed, \@args;
120 }
121
122 # walk table providing an array of components in each line to
123 # subroutine, printing the result
124 sub walk_table (&@) {
125     my ($function, $filename, $trailer) = @_;
126     my $F;
127     if (ref $filename) {        # filehandle
128         $F = $filename;
129     }
130     else {
131         $F = safer_open("$filename-new");
132         print $F do_not_edit ($filename);
133     }
134     foreach (@embed) {
135         my @outs = &{$function}(@$_);
136         # $function->(@args) is not 5.003
137         print $F @outs;
138     }
139     print $F $trailer if $trailer;
140     unless (ref $filename) {
141         safer_close($F);
142         rename_if_different("$filename-new", $filename);
143     }
144 }
145
146 # generate proto.h
147 my $wrote_protected = 0;
148
149 sub write_protos {
150     my $ret;
151     if (@_ == 1) {
152         my $arg = shift;
153         $ret = "$arg\n";
154     }
155     else {
156         my ($flags,$retval,$plain_func,@args) = @_;
157         my @nonnull;
158         my $has_context = ( $flags !~ /n/ );
159         my $never_returns = ( $flags =~ /r/ );
160         my $commented_out = ( $flags =~ /m/ );
161         my $binarycompat = ( $flags =~ /b/ );
162         my $is_malloc = ( $flags =~ /a/ );
163         my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
164         my @names_of_nn;
165         my $func;
166
167         my $splint_flags = "";
168         if ( $SPLINT && !$commented_out ) {
169             $splint_flags .= '/*@noreturn@*/ ' if $never_returns;
170             if ($can_ignore && ($retval ne 'void') && ($retval !~ /\*/)) {
171                 $retval .= " /*\@alt void\@*/";
172             }
173         }
174
175         if ($flags =~ /s/) {
176             $retval = "STATIC $splint_flags$retval";
177             $func = "S_$plain_func";
178         }
179         else {
180             $retval = "PERL_CALLCONV $splint_flags$retval";
181             if ($flags =~ /[bp]/) {
182                 $func = "Perl_$plain_func";
183             } else {
184                 $func = $plain_func;
185             }
186         }
187         $ret = "$retval\t$func(";
188         if ( $has_context ) {
189             $ret .= @args ? "pTHX_ " : "pTHX";
190         }
191         if (@args) {
192             my $n;
193             for my $arg ( @args ) {
194                 ++$n;
195                 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
196                     warn "$func: $arg needs NN or NULLOK\n";
197                     ++$unflagged_pointers;
198                 }
199                 my $nn = ( $arg =~ s/\s*\bNN\b\s+// );
200                 push( @nonnull, $n ) if $nn;
201
202                 my $nullok = ( $arg =~ s/\s*\bNULLOK\b\s+// ); # strip NULLOK with no effect
203
204                 # Make sure each arg has at least a type and a var name.
205                 # An arg of "int" is valid C, but want it to be "int foo".
206                 my $temp_arg = $arg;
207                 $temp_arg =~ s/\*//g;
208                 $temp_arg =~ s/\s*\bstruct\b\s*/ /g;
209                 if ( ($temp_arg ne "...")
210                      && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
211                     warn "$func: $arg ($n) doesn't have a name\n";
212                 }
213                 if ( $SPLINT && $nullok && !$commented_out ) {
214                     $arg = '/*@null@*/ ' . $arg;
215                 }
216                 if (defined $1 && $nn && !($commented_out && !$binarycompat)) {
217                     push @names_of_nn, $1;
218                 }
219             }
220             $ret .= join ", ", @args;
221         }
222         else {
223             $ret .= "void" if !$has_context;
224         }
225         $ret .= ")";
226         my @attrs;
227         if ( $flags =~ /r/ ) {
228             push @attrs, "__attribute__noreturn__";
229         }
230         if ( $flags =~ /D/ ) {
231             push @attrs, "__attribute__deprecated__";
232         }
233         if ( $is_malloc ) {
234             push @attrs, "__attribute__malloc__";
235         }
236         if ( !$can_ignore ) {
237             push @attrs, "__attribute__warn_unused_result__";
238         }
239         if ( $flags =~ /P/ ) {
240             push @attrs, "__attribute__pure__";
241         }
242         if( $flags =~ /f/ ) {
243             my $prefix  = $has_context ? 'pTHX_' : '';
244             my $args    = scalar @args;
245             my $pat     = $args - 1;
246             my $macro   = @nonnull && $nonnull[-1] == $pat  
247                                 ? '__attribute__format__'
248                                 : '__attribute__format__null_ok__';
249             push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
250                                 $prefix, $pat, $prefix, $args;
251         }
252         if ( @nonnull ) {
253             my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
254             push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
255         }
256         if ( @attrs ) {
257             $ret .= "\n";
258             $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
259         }
260         $ret .= ";";
261         $ret = "/* $ret */" if $commented_out;
262         if (@names_of_nn) {
263             $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
264                 . join '; ', map "assert($_)", @names_of_nn;
265         }
266         $ret .= @attrs ? "\n\n" : "\n";
267     }
268     $ret;
269 }
270
271 # generates global.sym (API export list)
272 {
273   my %seen;
274   sub write_global_sym {
275       if (@_ > 1) {
276           my ($flags,$retval,$func,@args) = @_;
277           # If a function is defined twice, for example before and after an
278           # #else, only process the flags on the first instance for global.sym
279           return '' if $seen{$func}++;
280           if ($flags =~ /[AX]/ && $flags !~ /[xm]/
281               || $flags =~ /b/) { # public API, so export
282               $func = "Perl_$func" if $flags =~ /[pbX]/;
283               return "$func\n";
284           }
285       }
286       return '';
287   }
288 }
289
290 walk_table(\&write_protos,     "proto.h", "/* ex: set ro: */\n");
291 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
292 walk_table(\&write_global_sym, "global.sym", "# ex: set ro:\n");
293
294 sub readsyms (\%$) {
295     my ($syms, $file) = @_;
296     local (*FILE, $_);
297     open(FILE, "< $file")
298         or die "embed.pl: Can't open $file: $!\n";
299     while (<FILE>) {
300         s/[ \t]*#.*//;          # Delete comments.
301         if (/^\s*(\S+)\s*$/) {
302             my $sym = $1;
303             warn "duplicate symbol $sym while processing $file line $.\n"
304                 if exists $$syms{$sym};
305             $$syms{$sym} = 1;
306         }
307     }
308     close(FILE);
309 }
310
311 # Perl_pp_* and Perl_ck_* are in pp.sym
312 readsyms my %ppsym, 'pp.sym';
313
314 sub readvars(\%$$@) {
315     my ($syms, $file,$pre,$keep_pre) = @_;
316     local (*FILE, $_);
317     open(FILE, "< $file")
318         or die "embed.pl: Can't open $file: $!\n";
319     while (<FILE>) {
320         s/[ \t]*#.*//;          # Delete comments.
321         if (/PERLVARA?I?S?C?\($pre(\w+)/) {
322             my $sym = $1;
323             $sym = $pre . $sym if $keep_pre;
324             warn "duplicate symbol $sym while processing $file line $.\n"
325                 if exists $$syms{$sym};
326             $$syms{$sym} = $pre || 1;
327         }
328     }
329     close(FILE);
330 }
331
332 my %intrp;
333 my %globvar;
334
335 readvars %intrp,  'intrpvar.h','I';
336 readvars %globvar, 'perlvars.h','G';
337
338 my $sym;
339
340 sub undefine ($) {
341     my ($sym) = @_;
342     "#undef  $sym\n";
343 }
344
345 sub hide {
346     my ($from, $to, $indent) = @_;
347     $indent = '' unless defined $indent;
348     my $t = int(length("$indent$from") / 8);
349     "#${indent}define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
350 }
351
352 sub bincompat_var ($$) {
353     my ($pfx, $sym) = @_;
354     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
355     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
356 }
357
358 sub multon ($$$) {
359     my ($sym,$pre,$ptr) = @_;
360     hide("PL_$sym", "($ptr$pre$sym)");
361 }
362
363 sub multoff ($$) {
364     my ($sym,$pre) = @_;
365     return hide("PL_$pre$sym", "PL_$sym");
366 }
367
368 my $em = safer_open('embed.h-new');
369
370 print $em do_not_edit ("embed.h"), <<'END';
371
372 /* (Doing namespace management portably in C is really gross.) */
373
374 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
375  * (like warn instead of Perl_warn) for the API are not defined.
376  * Not defining the short forms is a good thing for cleaner embedding. */
377
378 #ifndef PERL_NO_SHORT_NAMES
379
380 /* Hide global symbols */
381
382 END
383
384 # Try to elimiate lots of repeated
385 # #ifdef PERL_CORE
386 # foo
387 # #endif
388 # #ifdef PERL_CORE
389 # bar
390 # #endif
391 # by tracking state and merging foo and bar into one block.
392 my $ifdef_state = '';
393
394 my @az = ('a'..'z');
395
396 walk_table {
397     my $ret = "";
398     my $new_ifdef_state = '';
399     if (@_ == 1) {
400         my $arg = shift;
401         $ret = "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
402     }
403     else {
404         my ($flags,$retval,$func,@args) = @_;
405         unless ($flags =~ /[om]/) {
406             my $args = scalar @args;
407             if ($flags =~ /n/) {
408                 if ($flags =~ /s/) {
409                     $ret = hide($func,"S_$func");
410                 }
411                 elsif ($flags =~ /p/) {
412                     $ret = hide($func,"Perl_$func");
413                 }
414             }
415             elsif ($args and $args[$args-1] =~ /\.\.\./) {
416                 if ($flags =~ /p/) {
417                     # we're out of luck for varargs functions under CPP
418                     # So we can only do these macros for no implicit context:
419                     $ret = "#ifndef PERL_IMPLICIT_CONTEXT\n"
420                         . hide($func,"Perl_$func") . "#endif\n";
421                 }
422             }
423             else {
424                 my $alist = join(",", @az[0..$args-1]);
425                 $ret = "#define $func($alist)";
426                 my $t = int(length($ret) / 8);
427                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
428                 if ($flags =~ /s/) {
429                     $ret .= "S_$func(aTHX";
430                 }
431                 elsif ($flags =~ /p/) {
432                     $ret .= "Perl_$func(aTHX";
433                 }
434                 $ret .= "_ " if $alist;
435                 $ret .= $alist . ")\n";
436             }
437         }
438         unless ($flags =~ /A/) {
439             if ($flags =~ /E/) {
440                 $new_ifdef_state
441                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
442             }
443             else {
444                 $new_ifdef_state = "#ifdef PERL_CORE\n";
445             }
446
447             if ($new_ifdef_state ne $ifdef_state) {
448                 $ret = $new_ifdef_state . $ret;
449             }
450         }
451     }
452     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
453         # Close the old one ahead of opening the new one.
454         $ret = "#endif\n$ret";
455     }
456     # Remember the new state.
457     $ifdef_state = $new_ifdef_state;
458     $ret;
459 } $em;
460
461 if ($ifdef_state) {
462     print $em "#endif\n";
463 }
464
465 for $sym (sort keys %ppsym) {
466     $sym =~ s/^Perl_//;
467     if ($sym =~ /^ck_/) {
468         print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
469     }
470     elsif ($sym =~ /^pp_/) {
471         print $em hide("$sym()", "Perl_$sym(aTHX)");
472     }
473     else {
474         warn "Illegal symbol '$sym' in pp.sym";
475     }
476 }
477
478 print $em <<'END';
479
480 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
481
482 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
483    disable them.
484  */
485
486 #if !defined(PERL_CORE)
487 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
488 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
489 #endif
490
491 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
492
493 /* Compatibility for various misnamed functions.  All functions
494    in the API that begin with "perl_" (not "Perl_") take an explicit
495    interpreter context pointer.
496    The following are not like that, but since they had a "perl_"
497    prefix in previous versions, we provide compatibility macros.
498  */
499 #  define perl_atexit(a,b)              call_atexit(a,b)
500 END
501
502 walk_table {
503     my ($flags,$retval,$func,@args) = @_;
504     return unless $func;
505     return unless $flags =~ /O/;
506
507     my $alist = join ",", @az[0..$#args];
508     my $ret = "#  define perl_$func($alist)";
509     my $t = (length $ret) >> 3;
510     $ret .=  "\t" x ($t < 5 ? 5 - $t : 1);
511     "$ret$func($alist)\n";
512 } $em;
513
514 print $em <<'END';
515
516 /* varargs functions can't be handled with CPP macros. :-(
517    This provides a set of compatibility functions that don't take
518    an extra argument but grab the context pointer using the macro
519    dTHX.
520  */
521 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
522 END
523
524 foreach (sort keys %has_va) {
525     next unless $has_nocontext{$_};
526     next if /printf/; # Not clear to me why these are skipped but they are.
527     print $em hide($_, "Perl_${_}_nocontext", "  ");
528 }
529
530 print $em <<'END';
531 #endif
532
533 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
534
535 #if !defined(PERL_IMPLICIT_CONTEXT)
536 /* undefined symbols, point them back at the usual ones */
537 END
538
539 foreach (sort keys %has_va) {
540     next unless $has_nocontext{$_};
541     next if /printf/; # Not clear to me why these are skipped but they are.
542     print $em hide("Perl_${_}_nocontext", "Perl_$_", "  ");
543 }
544
545 print $em <<'END';
546 #endif
547
548 /* ex: set ro: */
549 END
550
551 safer_close($em);
552 rename_if_different('embed.h-new', 'embed.h');
553
554 $em = safer_open('embedvar.h-new');
555
556 print $em do_not_edit ("embedvar.h"), <<'END';
557
558 /* (Doing namespace management portably in C is really gross.) */
559
560 /*
561    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
562    are supported:
563      1) none
564      2) MULTIPLICITY    # supported for compatibility
565      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
566
567    All other combinations of these flags are errors.
568
569    only #3 is supported directly, while #2 is a special
570    case of #3 (supported by redefining vTHX appropriately).
571 */
572
573 #if defined(MULTIPLICITY)
574 /* cases 2 and 3 above */
575
576 #  if defined(PERL_IMPLICIT_CONTEXT)
577 #    define vTHX        aTHX
578 #  else
579 #    define vTHX        PERL_GET_INTERP
580 #  endif
581
582 END
583
584 for $sym (sort keys %intrp) {
585     print $em multon($sym,'I','vTHX->');
586 }
587
588 print $em <<'END';
589
590 #else   /* !MULTIPLICITY */
591
592 /* case 1 above */
593
594 END
595
596 for $sym (sort keys %intrp) {
597     print $em multoff($sym,'I');
598 }
599
600 print $em <<'END';
601
602 END
603
604 print $em <<'END';
605
606 #endif  /* MULTIPLICITY */
607
608 #if defined(PERL_GLOBAL_STRUCT)
609
610 END
611
612 for $sym (sort keys %globvar) {
613     print $em multon($sym,   'G','my_vars->');
614     print $em multon("G$sym",'', 'my_vars->');
615 }
616
617 print $em <<'END';
618
619 #else /* !PERL_GLOBAL_STRUCT */
620
621 END
622
623 for $sym (sort keys %globvar) {
624     print $em multoff($sym,'G');
625 }
626
627 print $em <<'END';
628
629 #endif /* PERL_GLOBAL_STRUCT */
630
631 /* ex: set ro: */
632 END
633
634 safer_close($em);
635 rename_if_different('embedvar.h-new', 'embedvar.h');
636
637 my $capi = safer_open('perlapi.c-new');
638 my $capih = safer_open('perlapi.h-new');
639
640 print $capih do_not_edit ("perlapi.h"), <<'EOT';
641
642 /* declare accessor functions for Perl variables */
643 #ifndef __perlapi_h__
644 #define __perlapi_h__
645
646 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
647
648 START_EXTERN_C
649
650 #undef PERLVAR
651 #undef PERLVARA
652 #undef PERLVARI
653 #undef PERLVARIC
654 #undef PERLVARISC
655 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
656 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
657                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
658 #define PERLVARI(v,t,i) PERLVAR(v,t)
659 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
660 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
661                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
662
663 #include "perlvars.h"
664
665 #undef PERLVAR
666 #undef PERLVARA
667 #undef PERLVARI
668 #undef PERLVARIC
669 #undef PERLVARISC
670
671 END_EXTERN_C
672
673 #if defined(PERL_CORE)
674
675 /* accessor functions for Perl "global" variables */
676
677 /* these need to be mentioned here, or most linkers won't put them in
678    the perl executable */
679
680 #ifndef PERL_NO_FORCE_LINK
681
682 START_EXTERN_C
683
684 #ifndef DOINIT
685 EXTCONST void * const PL_force_link_funcs[];
686 #else
687 EXTCONST void * const PL_force_link_funcs[] = {
688 #undef PERLVAR
689 #undef PERLVARA
690 #undef PERLVARI
691 #undef PERLVARIC
692 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
693 #define PERLVARA(v,n,t) PERLVAR(v,t)
694 #define PERLVARI(v,t,i) PERLVAR(v,t)
695 #define PERLVARIC(v,t,i) PERLVAR(v,t)
696 #define PERLVARISC(v,i) PERLVAR(v,char)
697
698 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
699  * cannot cast between void pointers and function pointers without
700  * info level warnings.  The PL_force_link_funcs[] would cause a few
701  * hundred of those warnings.  In code one can circumnavigate this by using
702  * unions that overlay the different pointers, but in declarations one
703  * cannot use this trick.  Therefore we just disable the warning here
704  * for the duration of the PL_force_link_funcs[] declaration. */
705
706 #if defined(__DECC) && defined(__osf__)
707 #pragma message save
708 #pragma message disable (nonstandcast)
709 #endif
710
711 #include "perlvars.h"
712
713 #if defined(__DECC) && defined(__osf__)
714 #pragma message restore
715 #endif
716
717 #undef PERLVAR
718 #undef PERLVARA
719 #undef PERLVARI
720 #undef PERLVARIC
721 #undef PERLVARISC
722 };
723 #endif  /* DOINIT */
724
725 END_EXTERN_C
726
727 #endif  /* PERL_NO_FORCE_LINK */
728
729 #else   /* !PERL_CORE */
730
731 EOT
732
733 foreach $sym (sort keys %globvar) {
734     print $capih bincompat_var('G',$sym);
735 }
736
737 print $capih <<'EOT';
738
739 #endif /* !PERL_CORE */
740 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
741
742 #endif /* __perlapi_h__ */
743
744 /* ex: set ro: */
745 EOT
746 safer_close($capih);
747 rename_if_different('perlapi.h-new', 'perlapi.h');
748
749 print $capi do_not_edit ("perlapi.c"), <<'EOT';
750
751 #include "EXTERN.h"
752 #include "perl.h"
753 #include "perlapi.h"
754
755 #if defined (MULTIPLICITY) && defined (PERL_GLOBAL_STRUCT)
756
757 /* accessor functions for Perl "global" variables */
758 START_EXTERN_C
759
760 #undef PERLVARI
761 #define PERLVARI(v,t,i) PERLVAR(v,t)
762
763 #undef PERLVAR
764 #undef PERLVARA
765 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
766                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
767 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
768                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
769 #undef PERLVARIC
770 #undef PERLVARISC
771 #define PERLVARIC(v,t,i)        \
772                         const t* Perl_##v##_ptr(pTHX)           \
773                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
774 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
775                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
776 #include "perlvars.h"
777
778 #undef PERLVAR
779 #undef PERLVARA
780 #undef PERLVARI
781 #undef PERLVARIC
782 #undef PERLVARISC
783
784 END_EXTERN_C
785
786 #endif /* MULTIPLICITY && PERL_GLOBAL_STRUCT */
787
788 /* ex: set ro: */
789 EOT
790
791 safer_close($capi);
792 rename_if_different('perlapi.c-new', 'perlapi.c');
793
794 # ex: set ts=8 sts=4 sw=4 noet: