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 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
 320  * (like warn instead of Perl_warn) for the API are not defined.
 321  * Not defining the short forms is a good thing for cleaner embedding. */
 322
 323 #ifndef PERL_NO_SHORT_NAMES
 324
 325 /* Hide global symbols */
 326
 327 #if !defined(PERL_IMPLICIT_CONTEXT)
 328
 329 END
 330
 331 walk_table {
 332     my $ret = "";
 333     if (@_ == 1) {
 334         my $arg = shift;
 335         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 336     }
 337     else {
 338         my ($flags,$retval,$func,@args) = @_;
 339         unless ($flags =~ /[om]/) {
 340             if ($flags =~ /s/) {
 341                 $ret .= hide($func,"S_$func");
 342             }
 343             elsif ($flags =~ /p/) {
 344                 $ret .= hide($func,"Perl_$func");
 345             }
 346         }
 347          unless ($flags =~ /A/) {
 348             if ($flags =~ /E/) {
 349                 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
 350             } else {
 351                 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
 352             }
 353         }
 354     }
 355     $ret;
 356 } \*EM, "";
 357
 358 for $sym (sort keys %ppsym) {
 359     $sym =~ s/^Perl_//;
 360     print EM hide($sym, "Perl_$sym");
 361 }
 362
 363 print EM <<'END';
 364
 365 #else   /* PERL_IMPLICIT_CONTEXT */
 366
 367 END
 368
 369 my @az = ('a'..'z');
 370
 371 walk_table {
 372     my $ret = "";
 373     if (@_ == 1) {
 374         my $arg = shift;
 375         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 376     }
 377     else {
 378         my ($flags,$retval,$func,@args) = @_;
 379         unless ($flags =~ /[om]/) {
 380             my $args = scalar @args;
 381             if ($args and $args[$args-1] =~ /\.\.\./) {
 382                 # we're out of luck for varargs functions under CPP
 383             }
 384             elsif ($flags =~ /n/) {
 385                 if ($flags =~ /s/) {
 386                     $ret .= hide($func,"S_$func");
 387                 }
 388                 elsif ($flags =~ /p/) {
 389                     $ret .= hide($func,"Perl_$func");
 390                 }
 391             }
 392             else {
 393                 my $alist = join(",", @az[0..$args-1]);
 394                 $ret = "#define $func($alist)";
 395                 my $t = int(length($ret) / 8);
 396                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 397                 if ($flags =~ /s/) {
 398                     $ret .= "S_$func(aTHX";
 399                 }
 400                 elsif ($flags =~ /p/) {
 401                     $ret .= "Perl_$func(aTHX";
 402                 }
 403                 $ret .= "_ " if $alist;
 404                 $ret .= $alist . ")\n";
 405             }
 406         }
 407          unless ($flags =~ /A/) {
 408             if ($flags =~ /E/) {
 409                 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
 410             } else {
 411                 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
 412             }
 413         }
 414     }
 415     $ret;
 416 } \*EM, "";
 417
 418 for $sym (sort keys %ppsym) {
 419     $sym =~ s/^Perl_//;
 420     if ($sym =~ /^ck_/) {
 421         print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
 422     }
 423     elsif ($sym =~ /^pp_/) {
 424         print EM hide("$sym()", "Perl_$sym(aTHX)");
 425     }
 426     else {
 427         warn "Illegal symbol '$sym' in pp.sym";
 428     }
 429 }
 430
 431 print EM <<'END';
 432
 433 #endif  /* PERL_IMPLICIT_CONTEXT */
 434
 435 #endif  /* #ifndef PERL_NO_SHORT_NAMES */
 436
 437 END
 438
 439 print EM <<'END';
 440
 441 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 442    disable them.
 443  */
 444
 445 #if !defined(PERL_CORE)
 446 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
 447 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,Nullch,PTR2IV(ptr))
 448 #endif
 449
 450 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
 451
 452 /* Compatibility for various misnamed functions.  All functions
 453    in the API that begin with "perl_" (not "Perl_") take an explicit
 454    interpreter context pointer.
 455    The following are not like that, but since they had a "perl_"
 456    prefix in previous versions, we provide compatibility macros.
 457  */
 458 #  define perl_atexit(a,b)              call_atexit(a,b)
 459 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
 460 #  define perl_call_pv(a,b)             call_pv(a,b)
 461 #  define perl_call_method(a,b)         call_method(a,b)
 462 #  define perl_call_sv(a,b)             call_sv(a,b)
 463 #  define perl_eval_sv(a,b)             eval_sv(a,b)
 464 #  define perl_eval_pv(a,b)             eval_pv(a,b)
 465 #  define perl_require_pv(a)            require_pv(a)
 466 #  define perl_get_sv(a,b)              get_sv(a,b)
 467 #  define perl_get_av(a,b)              get_av(a,b)
 468 #  define perl_get_hv(a,b)              get_hv(a,b)
 469 #  define perl_get_cv(a,b)              get_cv(a,b)
 470 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
 471 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
 472 #  define perl_new_ctype(a)             new_ctype(a)
 473 #  define perl_new_collate(a)           new_collate(a)
 474 #  define perl_new_numeric(a)           new_numeric(a)
 475
 476 /* varargs functions can't be handled with CPP macros. :-(
 477    This provides a set of compatibility functions that don't take
 478    an extra argument but grab the context pointer using the macro
 479    dTHX.
 480  */
 481 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
 482 #  define croak                         Perl_croak_nocontext
 483 #  define deb                           Perl_deb_nocontext
 484 #  define die                           Perl_die_nocontext
 485 #  define form                          Perl_form_nocontext
 486 #  define load_module                   Perl_load_module_nocontext
 487 #  define mess                          Perl_mess_nocontext
 488 #  define newSVpvf                      Perl_newSVpvf_nocontext
 489 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
 490 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
 491 #  define warn                          Perl_warn_nocontext
 492 #  define warner                        Perl_warner_nocontext
 493 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
 494 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
 495 #endif
 496
 497 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 498
 499 #if !defined(PERL_IMPLICIT_CONTEXT)
 500 /* undefined symbols, point them back at the usual ones */
 501 #  define Perl_croak_nocontext          Perl_croak
 502 #  define Perl_die_nocontext            Perl_die
 503 #  define Perl_deb_nocontext            Perl_deb
 504 #  define Perl_form_nocontext           Perl_form
 505 #  define Perl_load_module_nocontext    Perl_load_module
 506 #  define Perl_mess_nocontext           Perl_mess
 507 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
 508 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
 509 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
 510 #  define Perl_warn_nocontext           Perl_warn
 511 #  define Perl_warner_nocontext         Perl_warner
 512 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
 513 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
 514 #endif
 515
 516 END
 517
 518 close(EM) or die "Error closing EM: $!";
 519
 520 safer_unlink 'embedvar.h';
 521 open(EM, '> embedvar.h')
 522     or die "Can't create embedvar.h: $!\n";
 523
 524 print EM do_not_edit ("embedvar.h"), <<'END';
 525
 526 /* (Doing namespace management portably in C is really gross.) */
 527
 528 /*
 529    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
 530    are supported:
 531      1) none
 532      2) MULTIPLICITY    # supported for compatibility
 533      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 534
 535    All other combinations of these flags are errors.
 536
 537    only #3 is supported directly, while #2 is a special
 538    case of #3 (supported by redefining vTHX appropriately).
 539 */
 540
 541 #if defined(MULTIPLICITY)
 542 /* cases 2 and 3 above */
 543
 544 #  if defined(PERL_IMPLICIT_CONTEXT)
 545 #    define vTHX        aTHX
 546 #  else
 547 #    define vTHX        PERL_GET_INTERP
 548 #  endif
 549
 550 END
 551
 552 for $sym (sort keys %thread) {
 553     print EM multon($sym,'T','vTHX->');
 554 }
 555
 556 print EM <<'END';
 557
 558 /* cases 2 and 3 above */
 559
 560 END
 561
 562 for $sym (sort keys %intrp) {
 563     print EM multon($sym,'I','vTHX->');
 564 }
 565
 566 print EM <<'END';
 567
 568 #else   /* !MULTIPLICITY */
 569
 570 /* case 1 above */
 571
 572 END
 573
 574 for $sym (sort keys %intrp) {
 575     print EM multoff($sym,'I');
 576 }
 577
 578 print EM <<'END';
 579
 580 END
 581
 582 for $sym (sort keys %thread) {
 583     print EM multoff($sym,'T');
 584 }
 585
 586 print EM <<'END';
 587
 588 #endif  /* MULTIPLICITY */
 589
 590 #if defined(PERL_GLOBAL_STRUCT)
 591
 592 END
 593
 594 for $sym (sort keys %globvar) {
 595     print EM multon($sym,'G','PL_Vars.');
 596 }
 597
 598 print EM <<'END';
 599
 600 #else /* !PERL_GLOBAL_STRUCT */
 601
 602 END
 603
 604 for $sym (sort keys %globvar) {
 605     print EM multoff($sym,'G');
 606 }
 607
 608 print EM <<'END';
 609
 610 #endif /* PERL_GLOBAL_STRUCT */
 611
 612 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
 613
 614 END
 615
 616 for $sym (sort @extvars) {
 617     print EM hide($sym,"PL_$sym");
 618 }
 619
 620 print EM <<'END';
 621
 622 #endif /* PERL_POLLUTE */
 623 END
 624
 625 close(EM) or die "Error closing EM: $!";
 626
 627 safer_unlink 'perlapi.h';
 628 safer_unlink 'perlapi.c';
 629 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
 630 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
 631
 632 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
 633
 634 /* declare accessor functions for Perl variables */
 635 #ifndef __perlapi_h__
 636 #define __perlapi_h__
 637
 638 #if defined (MULTIPLICITY)
 639
 640 START_EXTERN_C
 641
 642 #undef PERLVAR
 643 #undef PERLVARA
 644 #undef PERLVARI
 645 #undef PERLVARIC
 646 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 647 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 648                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 649 #define PERLVARI(v,t,i) PERLVAR(v,t)
 650 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 651
 652 #include "thrdvar.h"
 653 #include "intrpvar.h"
 654 #include "perlvars.h"
 655
 656 #undef PERLVAR
 657 #undef PERLVARA
 658 #undef PERLVARI
 659 #undef PERLVARIC
 660
 661 END_EXTERN_C
 662
 663 #if defined(PERL_CORE)
 664
 665 /* accessor functions for Perl variables (provide binary compatibility) */
 666
 667 /* these need to be mentioned here, or most linkers won't put them in
 668    the perl executable */
 669
 670 #ifndef PERL_NO_FORCE_LINK
 671
 672 START_EXTERN_C
 673
 674 #ifndef DOINIT
 675 EXT void *PL_force_link_funcs[];
 676 #else
 677 EXT void *PL_force_link_funcs[] = {
 678 #undef PERLVAR
 679 #undef PERLVARA
 680 #undef PERLVARI
 681 #undef PERLVARIC
 682 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 683 #define PERLVARA(v,n,t) PERLVAR(v,t)
 684 #define PERLVARI(v,t,i) PERLVAR(v,t)
 685 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 686
 687 #include "thrdvar.h"
 688 #include "intrpvar.h"
 689 #include "perlvars.h"
 690
 691 #undef PERLVAR
 692 #undef PERLVARA
 693 #undef PERLVARI
 694 #undef PERLVARIC
 695 };
 696 #endif  /* DOINIT */
 697
 698 END_EXTERN_C
 699
 700 #endif  /* PERL_NO_FORCE_LINK */
 701
 702 #else   /* !PERL_CORE */
 703
 704 EOT
 705
 706 foreach $sym (sort keys %intrp) {
 707     print CAPIH bincompat_var('I',$sym);
 708 }
 709
 710 foreach $sym (sort keys %thread) {
 711     print CAPIH bincompat_var('T',$sym);
 712 }
 713
 714 foreach $sym (sort keys %globvar) {
 715     print CAPIH bincompat_var('G',$sym);
 716 }
 717
 718 print CAPIH <<'EOT';
 719
 720 #endif /* !PERL_CORE */
 721 #endif /* MULTIPLICITY */
 722
 723 #endif /* __perlapi_h__ */
 724
 725 EOT
 726 close CAPIH or die "Error closing CAPIH: $!";
 727
 728 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
 729
 730 #include "EXTERN.h"
 731 #include "perl.h"
 732 #include "perlapi.h"
 733
 734 #if defined (MULTIPLICITY)
 735
 736 /* accessor functions for Perl variables (provides binary compatibility) */
 737 START_EXTERN_C
 738
 739 #undef PERLVAR
 740 #undef PERLVARA
 741 #undef PERLVARI
 742 #undef PERLVARIC
 743
 744 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 745                         { return &(aTHX->v); }
 746 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 747                         { return &(aTHX->v); }
 748
 749 #define PERLVARI(v,t,i) PERLVAR(v,t)
 750 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 751
 752 #include "thrdvar.h"
 753 #include "intrpvar.h"
 754
 755 #undef PERLVAR
 756 #undef PERLVARA
 757 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 758                         { return &(PL_##v); }
 759 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 760                         { return &(PL_##v); }
 761 #undef PERLVARIC
 762 #define PERLVARIC(v,t,i)        const t* Perl_##v##_ptr(pTHX)           \
 763                         { return (const t *)&(PL_##v); }
 764 #include "perlvars.h"
 765
 766 #undef PERLVAR
 767 #undef PERLVARA
 768 #undef PERLVARI
 769 #undef PERLVARIC
 770
 771 END_EXTERN_C
 772
 773 #endif /* MULTIPLICITY */
 774 EOT
 775
 776 close(CAPI) or die "Error closing CAPI: $!";
 777
 778 # functions that take va_list* for implementing vararg functions
 779 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 780 # XXX %vfuncs currently unused
 781 my %vfuncs = qw(
 782     Perl_croak                  Perl_vcroak
 783     Perl_warn                   Perl_vwarn
 784     Perl_warner                 Perl_vwarner
 785     Perl_die                    Perl_vdie
 786     Perl_form                   Perl_vform
 787     Perl_load_module            Perl_vload_module
 788     Perl_mess                   Perl_vmess
 789     Perl_deb                    Perl_vdeb
 790     Perl_newSVpvf               Perl_vnewSVpvf
 791     Perl_sv_setpvf              Perl_sv_vsetpvf
 792     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
 793     Perl_sv_catpvf              Perl_sv_vcatpvf
 794     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
 795     Perl_dump_indent            Perl_dump_vindent
 796     Perl_default_protect        Perl_vdefault_protect
 797 );