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