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