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