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