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