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