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