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