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