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