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