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