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 at the __END__.
   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 /* provide binary compatible (but inconsistent) names */
 322 #if defined(PERL_BINCOMPAT_5005)
 323 #  define  Perl_call_atexit             perl_atexit
 324 #  define  Perl_eval_sv                 perl_eval_sv
 325 #  define  Perl_eval_pv                 perl_eval_pv
 326 #  define  Perl_call_argv               perl_call_argv
 327 #  define  Perl_call_method             perl_call_method
 328 #  define  Perl_call_pv                 perl_call_pv
 329 #  define  Perl_call_sv                 perl_call_sv
 330 #  define  Perl_get_av                  perl_get_av
 331 #  define  Perl_get_cv                  perl_get_cv
 332 #  define  Perl_get_hv                  perl_get_hv
 333 #  define  Perl_get_sv                  perl_get_sv
 334 #  define  Perl_init_i18nl10n           perl_init_i18nl10n
 335 #  define  Perl_init_i18nl14n           perl_init_i18nl14n
 336 #  define  Perl_new_collate             perl_new_collate
 337 #  define  Perl_new_ctype               perl_new_ctype
 338 #  define  Perl_new_numeric             perl_new_numeric
 339 #  define  Perl_require_pv              perl_require_pv
 340 #  define  Perl_safesyscalloc           Perl_safecalloc
 341 #  define  Perl_safesysfree             Perl_safefree
 342 #  define  Perl_safesysmalloc           Perl_safemalloc
 343 #  define  Perl_safesysrealloc          Perl_saferealloc
 344 #  define  Perl_set_numeric_local       perl_set_numeric_local
 345 #  define  Perl_set_numeric_standard    perl_set_numeric_standard
 346 /* malloc() pollution was the default in earlier versions, so enable
 347  * it for bincompat; but not for systems that used to do prevent that,
 348  * or when they ask for {HIDE,EMBED}MYMALLOC */
 349 #  if !defined(EMBEDMYMALLOC) && !defined(HIDEMYMALLOC)
 350 #    if !defined(NeXT) && !defined(__NeXT) && !defined(__MACHTEN__) && \
 351         !defined(__QNX__)
 352 #      define  PERL_POLLUTE_MALLOC
 353 #    endif
 354 #  endif
 355 #endif
 356
 357 /* Hide global symbols */
 358
 359 #if !defined(PERL_IMPLICIT_CONTEXT)
 360
 361 END
 362
 363 walk_table {
 364     my $ret = "";
 365     if (@_ == 1) {
 366         my $arg = shift;
 367         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 368     }
 369     else {
 370         my ($flags,$retval,$func,@args) = @_;
 371         unless ($flags =~ /[om]/) {
 372             if ($flags =~ /s/) {
 373                 $ret .= hide($func,"S_$func");
 374             }
 375             elsif ($flags =~ /p/) {
 376                 $ret .= hide($func,"Perl_$func");
 377             }
 378         }
 379     }
 380     $ret;
 381 } \*EM;
 382
 383 for $sym (sort keys %ppsym) {
 384     $sym =~ s/^Perl_//;
 385     print EM hide($sym, "Perl_$sym");
 386 }
 387
 388 print EM <<'END';
 389
 390 #else   /* PERL_IMPLICIT_CONTEXT */
 391
 392 END
 393
 394 my @az = ('a'..'z');
 395
 396 walk_table {
 397     my $ret = "";
 398     if (@_ == 1) {
 399         my $arg = shift;
 400         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 401     }
 402     else {
 403         my ($flags,$retval,$func,@args) = @_;
 404         unless ($flags =~ /[om]/) {
 405             my $args = scalar @args;
 406             if ($args and $args[$args-1] =~ /\.\.\./) {
 407                 # we're out of luck for varargs functions under CPP
 408             }
 409             elsif ($flags =~ /n/) {
 410                 if ($flags =~ /s/) {
 411                     $ret .= hide($func,"S_$func");
 412                 }
 413                 elsif ($flags =~ /p/) {
 414                     $ret .= hide($func,"Perl_$func");
 415                 }
 416             }
 417             else {
 418                 my $alist = join(",", @az[0..$args-1]);
 419                 $ret = "#define $func($alist)";
 420                 my $t = int(length($ret) / 8);
 421                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 422                 if ($flags =~ /s/) {
 423                     $ret .= "S_$func(aTHX";
 424                 }
 425                 elsif ($flags =~ /p/) {
 426                     $ret .= "Perl_$func(aTHX";
 427                 }
 428                 $ret .= "_ " if $alist;
 429                 $ret .= $alist . ")\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 END
 454
 455 print EM <<'END';
 456
 457 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 458    disable them.
 459  */
 460
 461 #if !defined(PERL_CORE)
 462 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
 463 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,Nullch,PTR2IV(ptr))
 464 #endif
 465
 466 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) && !defined(PERL_BINCOMPAT_5005)
 467
 468 /* Compatibility for various misnamed functions.  All functions
 469    in the API that begin with "perl_" (not "Perl_") take an explicit
 470    interpreter context pointer.
 471    The following are not like that, but since they had a "perl_"
 472    prefix in previous versions, we provide compatibility macros.
 473  */
 474 #  define perl_atexit(a,b)              call_atexit(a,b)
 475 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
 476 #  define perl_call_pv(a,b)             call_pv(a,b)
 477 #  define perl_call_method(a,b)         call_method(a,b)
 478 #  define perl_call_sv(a,b)             call_sv(a,b)
 479 #  define perl_eval_sv(a,b)             eval_sv(a,b)
 480 #  define perl_eval_pv(a,b)             eval_pv(a,b)
 481 #  define perl_require_pv(a)            require_pv(a)
 482 #  define perl_get_sv(a,b)              get_sv(a,b)
 483 #  define perl_get_av(a,b)              get_av(a,b)
 484 #  define perl_get_hv(a,b)              get_hv(a,b)
 485 #  define perl_get_cv(a,b)              get_cv(a,b)
 486 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
 487 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
 488 #  define perl_new_ctype(a)             new_ctype(a)
 489 #  define perl_new_collate(a)           new_collate(a)
 490 #  define perl_new_numeric(a)           new_numeric(a)
 491
 492 /* varargs functions can't be handled with CPP macros. :-(
 493    This provides a set of compatibility functions that don't take
 494    an extra argument but grab the context pointer using the macro
 495    dTHX.
 496  */
 497 #if defined(PERL_IMPLICIT_CONTEXT)
 498 #  define croak                         Perl_croak_nocontext
 499 #  define deb                           Perl_deb_nocontext
 500 #  define die                           Perl_die_nocontext
 501 #  define form                          Perl_form_nocontext
 502 #  define load_module                   Perl_load_module_nocontext
 503 #  define mess                          Perl_mess_nocontext
 504 #  define newSVpvf                      Perl_newSVpvf_nocontext
 505 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
 506 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
 507 #  define warn                          Perl_warn_nocontext
 508 #  define warner                        Perl_warner_nocontext
 509 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
 510 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
 511 #endif
 512
 513 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 514
 515 #if !defined(PERL_IMPLICIT_CONTEXT)
 516 /* undefined symbols, point them back at the usual ones */
 517 #  define Perl_croak_nocontext          Perl_croak
 518 #  define Perl_die_nocontext            Perl_die
 519 #  define Perl_deb_nocontext            Perl_deb
 520 #  define Perl_form_nocontext           Perl_form
 521 #  define Perl_load_module_nocontext    Perl_load_module
 522 #  define Perl_mess_nocontext           Perl_mess
 523 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
 524 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
 525 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
 526 #  define Perl_warn_nocontext           Perl_warn
 527 #  define Perl_warner_nocontext         Perl_warner
 528 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
 529 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
 530 #endif
 531
 532 END
 533
 534 close(EM);
 535
 536 unlink 'embedvar.h';
 537 open(EM, '> embedvar.h')
 538     or die "Can't create embedvar.h: $!\n";
 539
 540 print EM <<'END';
 541 /*
 542  *    embedvar.h
 543  *
 544  *    Copyright (c) 1997-2002, Larry Wall
 545  *
 546  *    You may distribute under the terms of either the GNU General Public
 547  *    License or the Artistic License, as specified in the README file.
 548  *
 549  *
 550  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 551  *  This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
 552  *  perlvars.h and thrdvar.h.  Any changes made here will be lost!
 553  */
 554
 555 /* (Doing namespace management portably in C is really gross.) */
 556
 557 /*
 558    The following combinations of MULTIPLICITY, USE_5005THREADS
 559    and PERL_IMPLICIT_CONTEXT are supported:
 560      1) none
 561      2) MULTIPLICITY    # supported for compatibility
 562      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 563      4) USE_5005THREADS && PERL_IMPLICIT_CONTEXT
 564      5) MULTIPLICITY && USE_5005THREADS && PERL_IMPLICIT_CONTEXT
 565
 566    All other combinations of these flags are errors.
 567
 568    #3, #4, #5, and #6 are supported directly, while #2 is a special
 569    case of #3 (supported by redefining vTHX appropriately).
 570 */
 571
 572 #if defined(MULTIPLICITY)
 573 /* cases 2, 3 and 5 above */
 574
 575 #  if defined(PERL_IMPLICIT_CONTEXT)
 576 #    define vTHX        aTHX
 577 #  else
 578 #    define vTHX        PERL_GET_INTERP
 579 #  endif
 580
 581 END
 582
 583 for $sym (sort keys %thread) {
 584     print EM multon($sym,'T','vTHX->');
 585 }
 586
 587 print EM <<'END';
 588
 589 #  if defined(USE_5005THREADS)
 590 /* case 5 above */
 591
 592 END
 593
 594 for $sym (sort keys %intrp) {
 595     print EM multon($sym,'I','PERL_GET_INTERP->');
 596 }
 597
 598 print EM <<'END';
 599
 600 #  else         /* !USE_5005THREADS */
 601 /* cases 2 and 3 above */
 602
 603 END
 604
 605 for $sym (sort keys %intrp) {
 606     print EM multon($sym,'I','vTHX->');
 607 }
 608
 609 print EM <<'END';
 610
 611 #  endif        /* USE_5005THREADS */
 612
 613 #else   /* !MULTIPLICITY */
 614
 615 /* cases 1 and 4 above */
 616
 617 END
 618
 619 for $sym (sort keys %intrp) {
 620     print EM multoff($sym,'I');
 621 }
 622
 623 print EM <<'END';
 624
 625 #  if defined(USE_5005THREADS)
 626 /* case 4 above */
 627
 628 END
 629
 630 for $sym (sort keys %thread) {
 631     print EM multon($sym,'T','aTHX->');
 632 }
 633
 634 print EM <<'END';
 635
 636 #  else /* !USE_5005THREADS */
 637 /* case 1 above */
 638
 639 END
 640
 641 for $sym (sort keys %thread) {
 642     print EM multoff($sym,'T');
 643 }
 644
 645 print EM <<'END';
 646
 647 #  endif        /* USE_5005THREADS */
 648 #endif  /* MULTIPLICITY */
 649
 650 #if defined(PERL_GLOBAL_STRUCT)
 651
 652 END
 653
 654 for $sym (sort keys %globvar) {
 655     print EM multon($sym,'G','PL_Vars.');
 656 }
 657
 658 print EM <<'END';
 659
 660 #else /* !PERL_GLOBAL_STRUCT */
 661
 662 END
 663
 664 for $sym (sort keys %globvar) {
 665     print EM multoff($sym,'G');
 666 }
 667
 668 print EM <<'END';
 669
 670 #endif /* PERL_GLOBAL_STRUCT */
 671
 672 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
 673
 674 END
 675
 676 for $sym (sort @extvars) {
 677     print EM hide($sym,"PL_$sym");
 678 }
 679
 680 print EM <<'END';
 681
 682 #endif /* PERL_POLLUTE */
 683 END
 684
 685 close(EM);
 686
 687 unlink 'perlapi.h';
 688 unlink 'perlapi.c';
 689 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
 690 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
 691
 692 print CAPIH <<'EOT';
 693 /*
 694  *    perlapi.h
 695  *
 696  *    Copyright (c) 1997-2002, Larry Wall
 697  *
 698  *    You may distribute under the terms of either the GNU General Public
 699  *    License or the Artistic License, as specified in the README file.
 700  *
 701  *
 702  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 703  *  This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
 704  *  perlvars.h and thrdvar.h.  Any changes made here will be lost!
 705  */
 706
 707 /* declare accessor functions for Perl variables */
 708 #ifndef __perlapi_h__
 709 #define __perlapi_h__
 710
 711 #if defined (MULTIPLICITY)
 712
 713 START_EXTERN_C
 714
 715 #undef PERLVAR
 716 #undef PERLVARA
 717 #undef PERLVARI
 718 #undef PERLVARIC
 719 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 720 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 721                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 722 #define PERLVARI(v,t,i) PERLVAR(v,t)
 723 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 724
 725 #include "thrdvar.h"
 726 #include "intrpvar.h"
 727 #include "perlvars.h"
 728
 729 #undef PERLVAR
 730 #undef PERLVARA
 731 #undef PERLVARI
 732 #undef PERLVARIC
 733
 734 END_EXTERN_C
 735
 736 #if defined(PERL_CORE)
 737
 738 /* accessor functions for Perl variables (provide binary compatibility) */
 739
 740 /* these need to be mentioned here, or most linkers won't put them in
 741    the perl executable */
 742
 743 #ifndef PERL_NO_FORCE_LINK
 744
 745 START_EXTERN_C
 746
 747 #ifndef DOINIT
 748 EXT void *PL_force_link_funcs[];
 749 #else
 750 EXT void *PL_force_link_funcs[] = {
 751 #undef PERLVAR
 752 #undef PERLVARA
 753 #undef PERLVARI
 754 #undef PERLVARIC
 755 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 756 #define PERLVARA(v,n,t) PERLVAR(v,t)
 757 #define PERLVARI(v,t,i) PERLVAR(v,t)
 758 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 759
 760 #include "thrdvar.h"
 761 #include "intrpvar.h"
 762 #include "perlvars.h"
 763
 764 #undef PERLVAR
 765 #undef PERLVARA
 766 #undef PERLVARI
 767 #undef PERLVARIC
 768 };
 769 #endif  /* DOINIT */
 770
 771 END_EXTERN_C
 772
 773 #endif  /* PERL_NO_FORCE_LINK */
 774
 775 #else   /* !PERL_CORE */
 776
 777 EOT
 778
 779 foreach $sym (sort keys %intrp) {
 780     print CAPIH bincompat_var('I',$sym);
 781 }
 782
 783 foreach $sym (sort keys %thread) {
 784     print CAPIH bincompat_var('T',$sym);
 785 }
 786
 787 foreach $sym (sort keys %globvar) {
 788     print CAPIH bincompat_var('G',$sym);
 789 }
 790
 791 print CAPIH <<'EOT';
 792
 793 #endif /* !PERL_CORE */
 794 #endif /* MULTIPLICITY */
 795
 796 #endif /* __perlapi_h__ */
 797
 798 EOT
 799 close CAPIH;
 800
 801 print CAPI <<'EOT';
 802 /*
 803  *    perlapi.c
 804  *
 805  *    Copyright (c) 1997-2002, Larry Wall
 806  *
 807  *    You may distribute under the terms of either the GNU General Public
 808  *    License or the Artistic License, as specified in the README file.
 809  *
 810  *
 811  * !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
 812  *  This file is built by embed.pl from data in embed.pl, pp.sym, intrpvar.h,
 813  *  perlvars.h and thrdvar.h.  Any changes made here will be lost!
 814  */
 815
 816 #include "EXTERN.h"
 817 #include "perl.h"
 818 #include "perlapi.h"
 819
 820 #if defined (MULTIPLICITY)
 821
 822 /* accessor functions for Perl variables (provides binary compatibility) */
 823 START_EXTERN_C
 824
 825 #undef PERLVAR
 826 #undef PERLVARA
 827 #undef PERLVARI
 828 #undef PERLVARIC
 829
 830 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 831                         { return &(aTHX->v); }
 832 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 833                         { return &(aTHX->v); }
 834
 835 #define PERLVARI(v,t,i) PERLVAR(v,t)
 836 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 837
 838 #include "thrdvar.h"
 839 #include "intrpvar.h"
 840
 841 #undef PERLVAR
 842 #undef PERLVARA
 843 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 844                         { return &(PL_##v); }
 845 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 846                         { return &(PL_##v); }
 847 #undef PERLVARIC
 848 #define PERLVARIC(v,t,i)        const t* Perl_##v##_ptr(pTHX)           \
 849                         { return (const t *)&(PL_##v); }
 850 #include "perlvars.h"
 851
 852 #undef PERLVAR
 853 #undef PERLVARA
 854 #undef PERLVARI
 855 #undef PERLVARIC
 856
 857 END_EXTERN_C
 858
 859 #endif /* MULTIPLICITY */
 860 EOT
 861
 862 close(CAPI);
 863
 864 # functions that take va_list* for implementing vararg functions
 865 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 866 # XXX %vfuncs currently unused
 867 my %vfuncs = qw(
 868     Perl_croak                  Perl_vcroak
 869     Perl_warn                   Perl_vwarn
 870     Perl_warner                 Perl_vwarner
 871     Perl_die                    Perl_vdie
 872     Perl_form                   Perl_vform
 873     Perl_load_module            Perl_vload_module
 874     Perl_mess                   Perl_vmess
 875     Perl_deb                    Perl_vdeb
 876     Perl_newSVpvf               Perl_vnewSVpvf
 877     Perl_sv_setpvf              Perl_sv_vsetpvf
 878     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
 879     Perl_sv_catpvf              Perl_sv_vcatpvf
 880     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
 881     Perl_dump_indent            Perl_dump_vindent
 882     Perl_default_protect        Perl_vdefault_protect
 883 );