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