embed.pl

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