embed.pl

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