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