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 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?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, USE_5005THREADS
 605    and PERL_IMPLICIT_CONTEXT are supported:
 606      1) none
 607      2) MULTIPLICITY    # supported for compatibility
 608      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 609      4) USE_5005THREADS && PERL_IMPLICIT_CONTEXT
 610      5) MULTIPLICITY && USE_5005THREADS && PERL_IMPLICIT_CONTEXT
 611
 612    All other combinations of these flags are errors.
 613
 614    #3, #4, #5, and #6 are supported directly, while #2 is a special
 615    case of #3 (supported by redefining vTHX appropriately).
 616 */
 617
 618 #if defined(MULTIPLICITY)
 619 /* cases 2, 3 and 5 above */
 620
 621 #  if defined(PERL_IMPLICIT_CONTEXT)
 622 #    define vTHX        aTHX
 623 #  else
 624 #    define vTHX        PERL_GET_INTERP
 625 #  endif
 626
 627 END
 628
 629 for $sym (sort keys %thread) {
 630     print EM multon($sym,'T','vTHX->');
 631 }
 632
 633 print EM <<'END';
 634
 635 #  if defined(USE_5005THREADS)
 636 /* case 5 above */
 637
 638 END
 639
 640 for $sym (sort keys %intrp) {
 641     print EM multon($sym,'I','PERL_GET_INTERP->');
 642 }
 643
 644 print EM <<'END';
 645
 646 #  else         /* !USE_5005THREADS */
 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 #  endif        /* USE_5005THREADS */
 658
 659 #else   /* !MULTIPLICITY */
 660
 661 /* cases 1 and 4 above */
 662
 663 END
 664
 665 for $sym (sort keys %intrp) {
 666     print EM multoff($sym,'I');
 667 }
 668
 669 print EM <<'END';
 670
 671 #  if defined(USE_5005THREADS)
 672 /* case 4 above */
 673
 674 END
 675
 676 for $sym (sort keys %thread) {
 677     print EM multon($sym,'T','aTHX->');
 678 }
 679
 680 print EM <<'END';
 681
 682 #  else /* !USE_5005THREADS */
 683 /* case 1 above */
 684
 685 END
 686
 687 for $sym (sort keys %thread) {
 688     print EM multoff($sym,'T');
 689 }
 690
 691 print EM <<'END';
 692
 693 #  endif        /* USE_5005THREADS */
 694 #endif  /* MULTIPLICITY */
 695
 696 #if defined(PERL_GLOBAL_STRUCT)
 697
 698 END
 699
 700 for $sym (sort keys %globvar) {
 701     print EM multon($sym,'G','PL_Vars.');
 702 }
 703
 704 print EM <<'END';
 705
 706 #else /* !PERL_GLOBAL_STRUCT */
 707
 708 END
 709
 710 for $sym (sort keys %globvar) {
 711     print EM multoff($sym,'G');
 712 }
 713
 714 print EM <<'END';
 715
 716 #endif /* PERL_GLOBAL_STRUCT */
 717
 718 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
 719
 720 END
 721
 722 for $sym (sort @extvars) {
 723     print EM hide($sym,"PL_$sym");
 724 }
 725
 726 print EM <<'END';
 727
 728 #endif /* PERL_POLLUTE */
 729 END
 730
 731 close(EM) or die "Error closing EM: $!";
 732
 733 safer_unlink 'perlapi.h';
 734 safer_unlink 'perlapi.c';
 735 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
 736 binmode CAPI;
 737 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
 738 binmode CAPIH;
 739
 740 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
 741
 742 /* declare accessor functions for Perl variables */
 743 #ifndef __perlapi_h__
 744 #define __perlapi_h__
 745
 746 #if defined (MULTIPLICITY)
 747
 748 START_EXTERN_C
 749
 750 #undef PERLVAR
 751 #undef PERLVARA
 752 #undef PERLVARI
 753 #undef PERLVARIC
 754 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 755 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 756                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 757 #define PERLVARI(v,t,i) PERLVAR(v,t)
 758 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 759
 760 #include "thrdvar.h"
 761 #include "intrpvar.h"
 762 #include "perlvars.h"
 763
 764 #undef PERLVAR
 765 #undef PERLVARA
 766 #undef PERLVARI
 767 #undef PERLVARIC
 768
 769 END_EXTERN_C
 770
 771 #if defined(PERL_CORE)
 772
 773 /* accessor functions for Perl variables (provide binary compatibility) */
 774
 775 /* these need to be mentioned here, or most linkers won't put them in
 776    the perl executable */
 777
 778 #ifndef PERL_NO_FORCE_LINK
 779
 780 START_EXTERN_C
 781
 782 #ifndef DOINIT
 783 EXT void *PL_force_link_funcs[];
 784 #else
 785 EXT void *PL_force_link_funcs[] = {
 786 #undef PERLVAR
 787 #undef PERLVARA
 788 #undef PERLVARI
 789 #undef PERLVARIC
 790 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 791 #define PERLVARA(v,n,t) PERLVAR(v,t)
 792 #define PERLVARI(v,t,i) PERLVAR(v,t)
 793 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 794
 795 #include "thrdvar.h"
 796 #include "intrpvar.h"
 797 #include "perlvars.h"
 798
 799 #undef PERLVAR
 800 #undef PERLVARA
 801 #undef PERLVARI
 802 #undef PERLVARIC
 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
 852 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 853                         { return &(aTHX->v); }
 854 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 855                         { return &(aTHX->v); }
 856
 857 #define PERLVARI(v,t,i) PERLVAR(v,t)
 858 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 859
 860 #include "thrdvar.h"
 861 #include "intrpvar.h"
 862
 863 #undef PERLVAR
 864 #undef PERLVARA
 865 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 866                         { return &(PL_##v); }
 867 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 868                         { return &(PL_##v); }
 869 #undef PERLVARIC
 870 #define PERLVARIC(v,t,i)        const t* Perl_##v##_ptr(pTHX)           \
 871                         { return (const t *)&(PL_##v); }
 872 #include "perlvars.h"
 873
 874 #undef PERLVAR
 875 #undef PERLVARA
 876 #undef PERLVARI
 877 #undef PERLVARIC
 878
 879 END_EXTERN_C
 880
 881 #endif /* MULTIPLICITY */
 882 EOT
 883
 884 close(CAPI) or die "Error closing CAPI: $!";
 885
 886 # functions that take va_list* for implementing vararg functions
 887 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 888 # XXX %vfuncs currently unused
 889 my %vfuncs = qw(
 890     Perl_croak                  Perl_vcroak
 891     Perl_warn                   Perl_vwarn
 892     Perl_warner                 Perl_vwarner
 893     Perl_die                    Perl_vdie
 894     Perl_form                   Perl_vform
 895     Perl_load_module            Perl_vload_module
 896     Perl_mess                   Perl_vmess
 897     Perl_deb                    Perl_vdeb
 898     Perl_newSVpvf               Perl_vnewSVpvf
 899     Perl_sv_setpvf              Perl_sv_vsetpvf
 900     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
 901     Perl_sv_catpvf              Perl_sv_vcatpvf
 902     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
 903     Perl_dump_indent            Perl_dump_vindent
 904     Perl_default_protect        Perl_vdefault_protect
 905 );