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