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