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