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