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, 2008, 2009';
  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     [p.577 of _The Lord of the Rings_, III/x: "The Voice of Saruman"]
  56
  57
  58 EOW
  59
  60     if ($file =~ m:\.[ch]$:) {
  61         $warning =~ s:^: * :gm;
  62         $warning =~ s: +$::gm;
  63         $warning =~ s: :/:;
  64         $warning =~ s:$:/:;
  65     }
  66     else {
  67         $warning =~ s:^:# :gm;
  68         $warning =~ s: +$::gm;
  69     }
  70     $warning;
  71 } # do_not_edit
  72
  73 open IN, "embed.fnc" or die $!;
  74
  75 # walk table providing an array of components in each line to
  76 # subroutine, printing the result
  77 sub walk_table (&@) {
  78     my $function = shift;
  79     my $filename = shift || '-';
  80     my $leader = shift;
  81     defined $leader or $leader = do_not_edit ($filename);
  82     my $trailer = shift;
  83     my $F;
  84     if (ref $filename) {        # filehandle
  85         $F = $filename;
  86     }
  87     else {
  88         # safer_unlink $filename if $filename ne '/dev/null';
  89         $F = safer_open("$filename-new");
  90     }
  91     print $F $leader if $leader;
  92     seek IN, 0, 0;              # so we may restart
  93     while (<IN>) {
  94         chomp;
  95         next if /^:/;
  96         while (s|\\$||) {
  97             $_ .= <IN>;
  98             chomp;
  99         }
 100         s/\s+$//;
 101         my @args;
 102         if (/^\s*(#|$)/) {
 103             @args = $_;
 104         }
 105         else {
 106             @args = split /\s*\|\s*/, $_;
 107         }
 108         my @outs = &{$function}(@args);
 109         print $F @outs; # $function->(@args) is not 5.003
 110     }
 111     print $F $trailer if $trailer;
 112     unless (ref $filename) {
 113         safer_close($F);
 114         rename_if_different("$filename-new", $filename);
 115     }
 116 }
 117
 118 sub munge_c_files () {
 119     my $functions = {};
 120     unless (@ARGV) {
 121         warn "\@ARGV empty, nothing to do\n";
 122         return;
 123     }
 124     walk_table {
 125         if (@_ > 1) {
 126             $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
 127         }
 128     } '/dev/null', '', '';
 129     local $^I = '.bak';
 130     while (<>) {
 131         s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
 132          {
 133             my $repl = $1;
 134             my $f = $2;
 135             if (exists $functions->{$f}) {
 136                 $repl .= "aTHX_ ";
 137                 warn("$ARGV:$.:$`#$repl#$'");
 138             }
 139             $repl;
 140          }eg;
 141         print;
 142         close ARGV if eof;      # restart $.
 143     }
 144     exit;
 145 }
 146
 147 #munge_c_files();
 148
 149 # generate proto.h
 150 my $wrote_protected = 0;
 151
 152 sub write_protos {
 153     my $ret = "";
 154     if (@_ == 1) {
 155         my $arg = shift;
 156         $ret .= "$arg\n";
 157     }
 158     else {
 159         my ($flags,$retval,$plain_func,@args) = @_;
 160         my @nonnull;
 161         my $has_context = ( $flags !~ /n/ );
 162         my $never_returns = ( $flags =~ /r/ );
 163         my $commented_out = ( $flags =~ /m/ );
 164         my $binarycompat = ( $flags =~ /b/ );
 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 && !($commented_out && !$binarycompat)) {
 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 my $em = safer_open('embed.h-new');
 393
 394 print $em do_not_edit ("embed.h"), <<'END';
 395
 396 /* (Doing namespace management portably in C is really gross.) */
 397
 398 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
 399  * (like warn instead of Perl_warn) for the API are not defined.
 400  * Not defining the short forms is a good thing for cleaner embedding. */
 401
 402 #ifndef PERL_NO_SHORT_NAMES
 403
 404 /* Hide global symbols */
 405
 406 #if !defined(PERL_IMPLICIT_CONTEXT)
 407
 408 END
 409
 410 # Try to elimiate lots of repeated
 411 # #ifdef PERL_CORE
 412 # foo
 413 # #endif
 414 # #ifdef PERL_CORE
 415 # bar
 416 # #endif
 417 # by tracking state and merging foo and bar into one block.
 418 my $ifdef_state = '';
 419
 420 walk_table {
 421     my $ret = "";
 422     my $new_ifdef_state = '';
 423     if (@_ == 1) {
 424         my $arg = shift;
 425         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 426     }
 427     else {
 428         my ($flags,$retval,$func,@args) = @_;
 429         unless ($flags =~ /[om]/) {
 430             if ($flags =~ /s/) {
 431                 $ret .= hide($func,"S_$func");
 432             }
 433             elsif ($flags =~ /p/) {
 434                 $ret .= hide($func,"Perl_$func");
 435             }
 436         }
 437         if ($ret ne '' && $flags !~ /A/) {
 438             if ($flags =~ /E/) {
 439                 $new_ifdef_state
 440                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
 441             }
 442             else {
 443                 $new_ifdef_state = "#ifdef PERL_CORE\n";
 444             }
 445
 446             if ($new_ifdef_state ne $ifdef_state) {
 447                 $ret = $new_ifdef_state . $ret;
 448             }
 449         }
 450     }
 451     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
 452         # Close the old one ahead of opening the new one.
 453         $ret = "#endif\n$ret";
 454     }
 455     # Remember the new state.
 456     $ifdef_state = $new_ifdef_state;
 457     $ret;
 458 } $em, "";
 459
 460 if ($ifdef_state) {
 461     print $em "#endif\n";
 462 }
 463
 464 for $sym (sort keys %ppsym) {
 465     $sym =~ s/^Perl_//;
 466     print $em hide($sym, "Perl_$sym");
 467 }
 468
 469 print $em <<'END';
 470
 471 #else   /* PERL_IMPLICIT_CONTEXT */
 472
 473 END
 474
 475 my @az = ('a'..'z');
 476
 477 $ifdef_state = '';
 478 walk_table {
 479     my $ret = "";
 480     my $new_ifdef_state = '';
 481     if (@_ == 1) {
 482         my $arg = shift;
 483         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 484     }
 485     else {
 486         my ($flags,$retval,$func,@args) = @_;
 487         unless ($flags =~ /[om]/) {
 488             my $args = scalar @args;
 489             if ($args and $args[$args-1] =~ /\.\.\./) {
 490                 # we're out of luck for varargs functions under CPP
 491             }
 492             elsif ($flags =~ /n/) {
 493                 if ($flags =~ /s/) {
 494                     $ret .= hide($func,"S_$func");
 495                 }
 496                 elsif ($flags =~ /p/) {
 497                     $ret .= hide($func,"Perl_$func");
 498                 }
 499             }
 500             else {
 501                 my $alist = join(",", @az[0..$args-1]);
 502                 $ret = "#define $func($alist)";
 503                 my $t = int(length($ret) / 8);
 504                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 505                 if ($flags =~ /s/) {
 506                     $ret .= "S_$func(aTHX";
 507                 }
 508                 elsif ($flags =~ /p/) {
 509                     $ret .= "Perl_$func(aTHX";
 510                 }
 511                 $ret .= "_ " if $alist;
 512                 $ret .= $alist . ")\n";
 513             }
 514         }
 515         unless ($flags =~ /A/) {
 516             if ($flags =~ /E/) {
 517                 $new_ifdef_state
 518                     = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
 519             }
 520             else {
 521                 $new_ifdef_state = "#ifdef PERL_CORE\n";
 522             }
 523
 524             if ($new_ifdef_state ne $ifdef_state) {
 525                 $ret = $new_ifdef_state . $ret;
 526             }
 527         }
 528     }
 529     if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
 530         # Close the old one ahead of opening the new one.
 531         $ret = "#endif\n$ret";
 532     }
 533     # Remember the new state.
 534     $ifdef_state = $new_ifdef_state;
 535     $ret;
 536 } $em, "";
 537
 538 if ($ifdef_state) {
 539     print $em "#endif\n";
 540 }
 541
 542 for $sym (sort keys %ppsym) {
 543     $sym =~ s/^Perl_//;
 544     if ($sym =~ /^ck_/) {
 545         print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
 546     }
 547     elsif ($sym =~ /^pp_/) {
 548         print $em hide("$sym()", "Perl_$sym(aTHX)");
 549     }
 550     else {
 551         warn "Illegal symbol '$sym' in pp.sym";
 552     }
 553 }
 554
 555 print $em <<'END';
 556
 557 #endif  /* PERL_IMPLICIT_CONTEXT */
 558
 559 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
 560
 561 END
 562
 563 print $em <<'END';
 564
 565 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 566    disable them.
 567  */
 568
 569 #if !defined(PERL_CORE)
 570 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
 571 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,NULL,PTR2IV(ptr))
 572 #endif
 573
 574 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
 575
 576 /* Compatibility for various misnamed functions.  All functions
 577    in the API that begin with "perl_" (not "Perl_") take an explicit
 578    interpreter context pointer.
 579    The following are not like that, but since they had a "perl_"
 580    prefix in previous versions, we provide compatibility macros.
 581  */
 582 #  define perl_atexit(a,b)              call_atexit(a,b)
 583 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
 584 #  define perl_call_pv(a,b)             call_pv(a,b)
 585 #  define perl_call_method(a,b)         call_method(a,b)
 586 #  define perl_call_sv(a,b)             call_sv(a,b)
 587 #  define perl_eval_sv(a,b)             eval_sv(a,b)
 588 #  define perl_eval_pv(a,b)             eval_pv(a,b)
 589 #  define perl_require_pv(a)            require_pv(a)
 590 #  define perl_get_sv(a,b)              get_sv(a,b)
 591 #  define perl_get_av(a,b)              get_av(a,b)
 592 #  define perl_get_hv(a,b)              get_hv(a,b)
 593 #  define perl_get_cv(a,b)              get_cv(a,b)
 594 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
 595 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
 596 #  define perl_new_ctype(a)             new_ctype(a)
 597 #  define perl_new_collate(a)           new_collate(a)
 598 #  define perl_new_numeric(a)           new_numeric(a)
 599
 600 /* varargs functions can't be handled with CPP macros. :-(
 601    This provides a set of compatibility functions that don't take
 602    an extra argument but grab the context pointer using the macro
 603    dTHX.
 604  */
 605 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
 606 #  define croak                         Perl_croak_nocontext
 607 #  define deb                           Perl_deb_nocontext
 608 #  define die                           Perl_die_nocontext
 609 #  define form                          Perl_form_nocontext
 610 #  define load_module                   Perl_load_module_nocontext
 611 #  define mess                          Perl_mess_nocontext
 612 #  define newSVpvf                      Perl_newSVpvf_nocontext
 613 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
 614 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
 615 #  define warn                          Perl_warn_nocontext
 616 #  define warner                        Perl_warner_nocontext
 617 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
 618 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
 619 #endif
 620
 621 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 622
 623 #if !defined(PERL_IMPLICIT_CONTEXT)
 624 /* undefined symbols, point them back at the usual ones */
 625 #  define Perl_croak_nocontext          Perl_croak
 626 #  define Perl_die_nocontext            Perl_die
 627 #  define Perl_deb_nocontext            Perl_deb
 628 #  define Perl_form_nocontext           Perl_form
 629 #  define Perl_load_module_nocontext    Perl_load_module
 630 #  define Perl_mess_nocontext           Perl_mess
 631 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
 632 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
 633 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
 634 #  define Perl_warn_nocontext           Perl_warn
 635 #  define Perl_warner_nocontext         Perl_warner
 636 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
 637 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
 638 #endif
 639
 640 /* ex: set ro: */
 641 END
 642
 643 safer_close($em);
 644 rename_if_different('embed.h-new', 'embed.h');
 645
 646 $em = safer_open('embedvar.h-new');
 647
 648 print $em do_not_edit ("embedvar.h"), <<'END';
 649
 650 /* (Doing namespace management portably in C is really gross.) */
 651
 652 /*
 653    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
 654    are supported:
 655      1) none
 656      2) MULTIPLICITY    # supported for compatibility
 657      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 658
 659    All other combinations of these flags are errors.
 660
 661    only #3 is supported directly, while #2 is a special
 662    case of #3 (supported by redefining vTHX appropriately).
 663 */
 664
 665 #if defined(MULTIPLICITY)
 666 /* cases 2 and 3 above */
 667
 668 #  if defined(PERL_IMPLICIT_CONTEXT)
 669 #    define vTHX        aTHX
 670 #  else
 671 #    define vTHX        PERL_GET_INTERP
 672 #  endif
 673
 674 END
 675
 676 for $sym (sort keys %intrp) {
 677     print $em multon($sym,'I','vTHX->');
 678 }
 679
 680 print $em <<'END';
 681
 682 #else   /* !MULTIPLICITY */
 683
 684 /* case 1 above */
 685
 686 END
 687
 688 for $sym (sort keys %intrp) {
 689     print $em multoff($sym,'I');
 690 }
 691
 692 print $em <<'END';
 693
 694 END
 695
 696 print $em <<'END';
 697
 698 #endif  /* MULTIPLICITY */
 699
 700 #if defined(PERL_GLOBAL_STRUCT)
 701
 702 END
 703
 704 for $sym (sort keys %globvar) {
 705     print $em multon($sym,   'G','my_vars->');
 706     print $em multon("G$sym",'', 'my_vars->');
 707 }
 708
 709 print $em <<'END';
 710
 711 #else /* !PERL_GLOBAL_STRUCT */
 712
 713 END
 714
 715 for $sym (sort keys %globvar) {
 716     print $em multoff($sym,'G');
 717 }
 718
 719 print $em <<'END';
 720
 721 #endif /* PERL_GLOBAL_STRUCT */
 722
 723 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
 724
 725 END
 726
 727 for $sym (sort @extvars) {
 728     print $em hide($sym,"PL_$sym");
 729 }
 730
 731 print $em <<'END';
 732
 733 #endif /* PERL_POLLUTE */
 734
 735 /* ex: set ro: */
 736 END
 737
 738 safer_close($em);
 739 rename_if_different('embedvar.h-new', 'embedvar.h');
 740
 741 my $capi = safer_open('perlapi.c-new');
 742 my $capih = safer_open('perlapi.h-new');
 743
 744 print $capih do_not_edit ("perlapi.h"), <<'EOT';
 745
 746 /* declare accessor functions for Perl variables */
 747 #ifndef __perlapi_h__
 748 #define __perlapi_h__
 749
 750 #if defined (MULTIPLICITY)
 751
 752 START_EXTERN_C
 753
 754 #undef PERLVAR
 755 #undef PERLVARA
 756 #undef PERLVARI
 757 #undef PERLVARIC
 758 #undef PERLVARISC
 759 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 760 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 761                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 762 #define PERLVARI(v,t,i) PERLVAR(v,t)
 763 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 764 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)];       \
 765                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 766
 767 #include "intrpvar.h"
 768 #include "perlvars.h"
 769
 770 #undef PERLVAR
 771 #undef PERLVARA
 772 #undef PERLVARI
 773 #undef PERLVARIC
 774 #undef PERLVARISC
 775
 776 #ifndef PERL_GLOBAL_STRUCT
 777 EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
 778 EXTERN_C Perl_check_t**  Perl_Gcheck_ptr(pTHX);
 779 EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
 780 #define Perl_ppaddr_ptr      Perl_Gppaddr_ptr
 781 #define Perl_check_ptr       Perl_Gcheck_ptr
 782 #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
 783 #endif
 784
 785 END_EXTERN_C
 786
 787 #if defined(PERL_CORE)
 788
 789 /* accessor functions for Perl variables (provide binary compatibility) */
 790
 791 /* these need to be mentioned here, or most linkers won't put them in
 792    the perl executable */
 793
 794 #ifndef PERL_NO_FORCE_LINK
 795
 796 START_EXTERN_C
 797
 798 #ifndef DOINIT
 799 EXTCONST void * const PL_force_link_funcs[];
 800 #else
 801 EXTCONST void * const PL_force_link_funcs[] = {
 802 #undef PERLVAR
 803 #undef PERLVARA
 804 #undef PERLVARI
 805 #undef PERLVARIC
 806 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 807 #define PERLVARA(v,n,t) PERLVAR(v,t)
 808 #define PERLVARI(v,t,i) PERLVAR(v,t)
 809 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 810 #define PERLVARISC(v,i) PERLVAR(v,char)
 811
 812 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
 813  * cannot cast between void pointers and function pointers without
 814  * info level warnings.  The PL_force_link_funcs[] would cause a few
 815  * hundred of those warnings.  In code one can circumnavigate this by using
 816  * unions that overlay the different pointers, but in declarations one
 817  * cannot use this trick.  Therefore we just disable the warning here
 818  * for the duration of the PL_force_link_funcs[] declaration. */
 819
 820 #if defined(__DECC) && defined(__osf__)
 821 #pragma message save
 822 #pragma message disable (nonstandcast)
 823 #endif
 824
 825 #include "intrpvar.h"
 826 #include "perlvars.h"
 827
 828 #if defined(__DECC) && defined(__osf__)
 829 #pragma message restore
 830 #endif
 831
 832 #undef PERLVAR
 833 #undef PERLVARA
 834 #undef PERLVARI
 835 #undef PERLVARIC
 836 #undef PERLVARISC
 837 };
 838 #endif  /* DOINIT */
 839
 840 END_EXTERN_C
 841
 842 #endif  /* PERL_NO_FORCE_LINK */
 843
 844 #else   /* !PERL_CORE */
 845
 846 EOT
 847
 848 foreach $sym (sort keys %intrp) {
 849     print $capih bincompat_var('I',$sym);
 850 }
 851
 852 foreach $sym (sort keys %globvar) {
 853     print $capih bincompat_var('G',$sym);
 854 }
 855
 856 print $capih <<'EOT';
 857
 858 #endif /* !PERL_CORE */
 859 #endif /* MULTIPLICITY */
 860
 861 #endif /* __perlapi_h__ */
 862
 863 /* ex: set ro: */
 864 EOT
 865 safer_close($capih);
 866 rename_if_different('perlapi.h-new', 'perlapi.h');
 867
 868 print $capi do_not_edit ("perlapi.c"), <<'EOT';
 869
 870 #include "EXTERN.h"
 871 #include "perl.h"
 872 #include "perlapi.h"
 873
 874 #if defined (MULTIPLICITY)
 875
 876 /* accessor functions for Perl variables (provides binary compatibility) */
 877 START_EXTERN_C
 878
 879 #undef PERLVAR
 880 #undef PERLVARA
 881 #undef PERLVARI
 882 #undef PERLVARIC
 883 #undef PERLVARISC
 884
 885 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 886                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 887 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 888                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 889
 890 #define PERLVARI(v,t,i) PERLVAR(v,t)
 891 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 892 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 893                         { dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
 894
 895 #include "intrpvar.h"
 896
 897 #undef PERLVAR
 898 #undef PERLVARA
 899 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 900                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 901 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 902                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 903 #undef PERLVARIC
 904 #undef PERLVARISC
 905 #define PERLVARIC(v,t,i)        \
 906                         const t* Perl_##v##_ptr(pTHX)           \
 907                         { PERL_UNUSED_CONTEXT; return (const t *)&(PL_##v); }
 908 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX)        \
 909                         { dVAR; PERL_UNUSED_CONTEXT; return &(PL_##v); }
 910 #include "perlvars.h"
 911
 912 #undef PERLVAR
 913 #undef PERLVARA
 914 #undef PERLVARI
 915 #undef PERLVARIC
 916 #undef PERLVARISC
 917
 918 #ifndef PERL_GLOBAL_STRUCT
 919 /* A few evil special cases.  Could probably macrofy this. */
 920 #undef PL_ppaddr
 921 #undef PL_check
 922 #undef PL_fold_locale
 923 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
 924     static Perl_ppaddr_t* const ppaddr_ptr = PL_ppaddr;
 925     PERL_UNUSED_CONTEXT;
 926     return (Perl_ppaddr_t**)&ppaddr_ptr;
 927 }
 928 Perl_check_t**  Perl_Gcheck_ptr(pTHX) {
 929     static Perl_check_t* const check_ptr  = PL_check;
 930     PERL_UNUSED_CONTEXT;
 931     return (Perl_check_t**)&check_ptr;
 932 }
 933 unsigned char** Perl_Gfold_locale_ptr(pTHX) {
 934     static unsigned char* const fold_locale_ptr = PL_fold_locale;
 935     PERL_UNUSED_CONTEXT;
 936     return (unsigned char**)&fold_locale_ptr;
 937 }
 938 #endif
 939
 940 END_EXTERN_C
 941
 942 #endif /* MULTIPLICITY */
 943
 944 /* ex: set ro: */
 945 EOT
 946
 947 safer_close($capi);
 948 rename_if_different('perlapi.c-new', 'perlapi.c');
 949
 950 # functions that take va_list* for implementing vararg functions
 951 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 952 # XXX %vfuncs currently unused
 953 my %vfuncs = qw(
 954     Perl_croak                  Perl_vcroak
 955     Perl_warn                   Perl_vwarn
 956     Perl_warner                 Perl_vwarner
 957     Perl_die                    Perl_vdie
 958     Perl_form                   Perl_vform
 959     Perl_load_module            Perl_vload_module
 960     Perl_mess                   Perl_vmess
 961     Perl_deb                    Perl_vdeb
 962     Perl_newSVpvf               Perl_vnewSVpvf
 963     Perl_sv_setpvf              Perl_sv_vsetpvf
 964     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
 965     Perl_sv_catpvf              Perl_sv_vcatpvf
 966     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
 967     Perl_dump_indent            Perl_dump_vindent
 968     Perl_default_protect        Perl_vdefault_protect
 969 );
 970
 971 # ex: set ts=8 sts=4 sw=4 noet: