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