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