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