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