embed.pl

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