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