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