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