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