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