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