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.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     my $warning = <<EOW;
  22
  23    $file
  24
  25    Copyright (c) 1997-2002, Larry Wall
  26
  27    You may distribute under the terms of either the GNU General Public
  28    License or the Artistic License, as specified in the README file.
  29
  30 !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
  31 This file is built by embed.pl from data in embed.fnc, embed.pl,
  32 pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
  33 Any changes made here will be lost!
  34
  35 Edit those files and run 'make regen_headers' to effect changes.
  36
  37 EOW
  38
  39     if ($file =~ m:\.[ch]$:) {
  40         $warning =~ s:^: * :gm;
  41         $warning =~ s: +$::gm;
  42         $warning =~ s: :/:;
  43         $warning =~ s:$:/:;
  44     }
  45     else {
  46         $warning =~ s:^:# :gm;
  47         $warning =~ s: +$::gm;
  48     }
  49     $warning;
  50 } # do_not_edit
  51
  52 open IN, "embed.fnc" or die $!;
  53
  54 # walk table providing an array of components in each line to
  55 # subroutine, printing the result
  56 sub walk_table (&@) {
  57     my $function = shift;
  58     my $filename = shift || '-';
  59     my $leader = shift;
  60     defined $leader or $leader = do_not_edit ($filename);
  61     my $trailer = shift;
  62     my $F;
  63     local *F;
  64     if (ref $filename) {        # filehandle
  65         $F = $filename;
  66     }
  67     else {
  68         safer_unlink $filename;
  69         open F, ">$filename" or die "Can't open $filename: $!";
  70         $F = \*F;
  71     }
  72     print $F $leader if $leader;
  73     seek IN, 0, 0;              # so we may restart
  74     while (<IN>) {
  75         chomp;
  76         next if /^:/;
  77         while (s|\\$||) {
  78             $_ .= <IN>;
  79             chomp;
  80         }
  81         my @args;
  82         if (/^\s*(#|$)/) {
  83             @args = $_;
  84         }
  85         else {
  86             @args = split /\s*\|\s*/, $_;
  87         }
  88         my @outs = &{$function}(@args);
  89         print $F @outs; # $function->(@args) is not 5.003
  90     }
  91     print $F $trailer if $trailer;
  92     unless (ref $filename) {
  93         close $F or die "Error closing $filename: $!";
  94     }
  95 }
  96
  97 sub munge_c_files () {
  98     my $functions = {};
  99     unless (@ARGV) {
 100         warn "\@ARGV empty, nothing to do\n";
 101         return;
 102     }
 103     walk_table {
 104         if (@_ > 1) {
 105             $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
 106         }
 107     } '/dev/null', '';
 108     local $^I = '.bak';
 109     while (<>) {
 110 #       if (/^#\s*include\s+"perl.h"/) {
 111 #           my $file = uc $ARGV;
 112 #           $file =~ s/\./_/g;
 113 #           print "#define PERL_IN_$file\n";
 114 #       }
 115 #       s{^(\w+)\s*\(}
 116 #        {
 117 #           my $f = $1;
 118 #           my $repl = "$f(";
 119 #           if (exists $functions->{$f}) {
 120 #               my $flags = $functions->{$f}[0];
 121 #               $repl = "Perl_$repl" if $flags =~ /p/;
 122 #               unless ($flags =~ /n/) {
 123 #                   $repl .= "pTHX";
 124 #                   $repl .= "_ " if @{$functions->{$f}} > 3;
 125 #               }
 126 #               warn("$ARGV:$.:$repl\n");
 127 #           }
 128 #           $repl;
 129 #        }e;
 130         s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
 131          {
 132             my $repl = $1;
 133             my $f = $2;
 134             if (exists $functions->{$f}) {
 135                 $repl .= "aTHX_ ";
 136                 warn("$ARGV:$.:$`#$repl#$'");
 137             }
 138             $repl;
 139          }eg;
 140         print;
 141         close ARGV if eof;      # restart $.
 142     }
 143     exit;
 144 }
 145
 146 #munge_c_files();
 147
 148 # generate proto.h
 149 my $wrote_protected = 0;
 150
 151 sub write_protos {
 152     my $ret = "";
 153     if (@_ == 1) {
 154         my $arg = shift;
 155         $ret .= "$arg\n";
 156     }
 157     else {
 158         my ($flags,$retval,$func,@args) = @_;
 159         $ret .= '/* ' if $flags =~ /m/;
 160         if ($flags =~ /s/) {
 161             $retval = "STATIC $retval";
 162             $func = "S_$func";
 163         }
 164         else {
 165             $retval = "PERL_CALLCONV $retval";
 166             if ($flags =~ /p/) {
 167                 $func = "Perl_$func";
 168             }
 169         }
 170         $ret .= "$retval\t$func(";
 171         unless ($flags =~ /n/) {
 172             $ret .= "pTHX";
 173             $ret .= "_ " if @args;
 174         }
 175         if (@args) {
 176             $ret .= join ", ", @args;
 177         }
 178         else {
 179             $ret .= "void" if $flags =~ /n/;
 180         }
 181         $ret .= ")";
 182         $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
 183         if( $flags =~ /f/ ) {
 184             my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
 185             my $args = scalar @args;
 186             $ret .= "\n#ifdef CHECK_FORMAT\n";
 187             $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
 188                                     $prefix, $args - 1, $prefix, $args;
 189             $ret .= "\n#endif\n";
 190         }
 191         $ret .= ";";
 192         $ret .= ' */' if $flags =~ /m/;
 193         $ret .= "\n";
 194     }
 195     $ret;
 196 }
 197
 198 # generates global.sym (API export list), and populates %global with global symbols
 199 sub write_global_sym {
 200     my $ret = "";
 201     if (@_ > 1) {
 202         my ($flags,$retval,$func,@args) = @_;
 203         if ($flags =~ /A/ && $flags !~ /[xm]/) { # public API, so export
 204             $func = "Perl_$func" if $flags =~ /p/;
 205             $ret = "$func\n";
 206         }
 207     }
 208     $ret;
 209 }
 210
 211 walk_table(\&write_protos,     "proto.h", undef);
 212 walk_table(\&write_global_sym, "global.sym", undef);
 213
 214 # XXX others that may need adding
 215 #       warnhook
 216 #       hints
 217 #       copline
 218 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
 219                  curcop compiling
 220                  tainting tainted stack_base stack_sp sv_arenaroot
 221                  no_modify
 222                  curstash DBsub DBsingle debstash
 223                  rsfp
 224                  stdingv
 225                  defgv
 226                  errgv
 227                  rsfp_filters
 228                  perldb
 229                  diehook
 230                  dirty
 231                  perl_destruct_level
 232                  ppaddr
 233                 );
 234
 235 sub readsyms (\%$) {
 236     my ($syms, $file) = @_;
 237     local (*FILE, $_);
 238     open(FILE, "< $file")
 239         or die "embed.pl: Can't open $file: $!\n";
 240     while (<FILE>) {
 241         s/[ \t]*#.*//;          # Delete comments.
 242         if (/^\s*(\S+)\s*$/) {
 243             my $sym = $1;
 244             warn "duplicate symbol $sym while processing $file\n"
 245                 if exists $$syms{$sym};
 246             $$syms{$sym} = 1;
 247         }
 248     }
 249     close(FILE);
 250 }
 251
 252 # Perl_pp_* and Perl_ck_* are in pp.sym
 253 readsyms my %ppsym, 'pp.sym';
 254
 255 sub readvars(\%$$@) {
 256     my ($syms, $file,$pre,$keep_pre) = @_;
 257     local (*FILE, $_);
 258     open(FILE, "< $file")
 259         or die "embed.pl: Can't open $file: $!\n";
 260     while (<FILE>) {
 261         s/[ \t]*#.*//;          # Delete comments.
 262         if (/PERLVARA?I?C?\($pre(\w+)/) {
 263             my $sym = $1;
 264             $sym = $pre . $sym if $keep_pre;
 265             warn "duplicate symbol $sym while processing $file\n"
 266                 if exists $$syms{$sym};
 267             $$syms{$sym} = $pre || 1;
 268         }
 269     }
 270     close(FILE);
 271 }
 272
 273 my %intrp;
 274 my %thread;
 275
 276 readvars %intrp,  'intrpvar.h','I';
 277 readvars %thread, 'thrdvar.h','T';
 278 readvars %globvar, 'perlvars.h','G';
 279
 280 my $sym;
 281 foreach $sym (sort keys %thread) {
 282   warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
 283 }
 284
 285 sub undefine ($) {
 286     my ($sym) = @_;
 287     "#undef  $sym\n";
 288 }
 289
 290 sub hide ($$) {
 291     my ($from, $to) = @_;
 292     my $t = int(length($from) / 8);
 293     "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
 294 }
 295
 296 sub bincompat_var ($$) {
 297     my ($pfx, $sym) = @_;
 298     my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
 299     undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
 300 }
 301
 302 sub multon ($$$) {
 303     my ($sym,$pre,$ptr) = @_;
 304     hide("PL_$sym", "($ptr$pre$sym)");
 305 }
 306
 307 sub multoff ($$) {
 308     my ($sym,$pre) = @_;
 309     return hide("PL_$pre$sym", "PL_$sym");
 310 }
 311
 312 safer_unlink 'embed.h';
 313 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
 314
 315 print EM do_not_edit ("embed.h"), <<'END';
 316
 317 /* (Doing namespace management portably in C is really gross.) */
 318
 319 /* NO_EMBED is no longer supported. i.e. EMBED is always active. */
 320
 321 /* Hide global symbols */
 322
 323 #if !defined(PERL_IMPLICIT_CONTEXT)
 324
 325 END
 326
 327 walk_table {
 328     my $ret = "";
 329     if (@_ == 1) {
 330         my $arg = shift;
 331         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 332     }
 333     else {
 334         my ($flags,$retval,$func,@args) = @_;
 335         unless ($flags =~ /[om]/) {
 336             if ($flags =~ /s/) {
 337                 $ret .= hide($func,"S_$func");
 338             }
 339             elsif ($flags =~ /p/) {
 340                 $ret .= hide($func,"Perl_$func");
 341             }
 342         }
 343     }
 344     $ret;
 345 } \*EM, "";
 346
 347 for $sym (sort keys %ppsym) {
 348     $sym =~ s/^Perl_//;
 349     print EM hide($sym, "Perl_$sym");
 350 }
 351
 352 print EM <<'END';
 353
 354 #else   /* PERL_IMPLICIT_CONTEXT */
 355
 356 END
 357
 358 my @az = ('a'..'z');
 359
 360 walk_table {
 361     my $ret = "";
 362     if (@_ == 1) {
 363         my $arg = shift;
 364         $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
 365     }
 366     else {
 367         my ($flags,$retval,$func,@args) = @_;
 368         unless ($flags =~ /[om]/) {
 369             my $args = scalar @args;
 370             if ($args and $args[$args-1] =~ /\.\.\./) {
 371                 # we're out of luck for varargs functions under CPP
 372             }
 373             elsif ($flags =~ /n/) {
 374                 if ($flags =~ /s/) {
 375                     $ret .= hide($func,"S_$func");
 376                 }
 377                 elsif ($flags =~ /p/) {
 378                     $ret .= hide($func,"Perl_$func");
 379                 }
 380             }
 381             else {
 382                 my $alist = join(",", @az[0..$args-1]);
 383                 $ret = "#define $func($alist)";
 384                 my $t = int(length($ret) / 8);
 385                 $ret .=  "\t" x ($t < 4 ? 4 - $t : 1);
 386                 if ($flags =~ /s/) {
 387                     $ret .= "S_$func(aTHX";
 388                 }
 389                 elsif ($flags =~ /p/) {
 390                     $ret .= "Perl_$func(aTHX";
 391                 }
 392                 $ret .= "_ " if $alist;
 393                 $ret .= $alist . ")\n";
 394             }
 395         }
 396     }
 397     $ret;
 398 } \*EM, "";
 399
 400 for $sym (sort keys %ppsym) {
 401     $sym =~ s/^Perl_//;
 402     if ($sym =~ /^ck_/) {
 403         print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
 404     }
 405     elsif ($sym =~ /^pp_/) {
 406         print EM hide("$sym()", "Perl_$sym(aTHX)");
 407     }
 408     else {
 409         warn "Illegal symbol '$sym' in pp.sym";
 410     }
 411 }
 412
 413 print EM <<'END';
 414
 415 #endif  /* PERL_IMPLICIT_CONTEXT */
 416
 417 END
 418
 419 print EM <<'END';
 420
 421 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
 422    disable them.
 423  */
 424
 425 #if !defined(PERL_CORE)
 426 #  define sv_setptrobj(rv,ptr,name)     sv_setref_iv(rv,name,PTR2IV(ptr))
 427 #  define sv_setptrref(rv,ptr)          sv_setref_iv(rv,Nullch,PTR2IV(ptr))
 428 #endif
 429
 430 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
 431
 432 /* Compatibility for various misnamed functions.  All functions
 433    in the API that begin with "perl_" (not "Perl_") take an explicit
 434    interpreter context pointer.
 435    The following are not like that, but since they had a "perl_"
 436    prefix in previous versions, we provide compatibility macros.
 437  */
 438 #  define perl_atexit(a,b)              call_atexit(a,b)
 439 #  define perl_call_argv(a,b,c)         call_argv(a,b,c)
 440 #  define perl_call_pv(a,b)             call_pv(a,b)
 441 #  define perl_call_method(a,b)         call_method(a,b)
 442 #  define perl_call_sv(a,b)             call_sv(a,b)
 443 #  define perl_eval_sv(a,b)             eval_sv(a,b)
 444 #  define perl_eval_pv(a,b)             eval_pv(a,b)
 445 #  define perl_require_pv(a)            require_pv(a)
 446 #  define perl_get_sv(a,b)              get_sv(a,b)
 447 #  define perl_get_av(a,b)              get_av(a,b)
 448 #  define perl_get_hv(a,b)              get_hv(a,b)
 449 #  define perl_get_cv(a,b)              get_cv(a,b)
 450 #  define perl_init_i18nl10n(a)         init_i18nl10n(a)
 451 #  define perl_init_i18nl14n(a)         init_i18nl14n(a)
 452 #  define perl_new_ctype(a)             new_ctype(a)
 453 #  define perl_new_collate(a)           new_collate(a)
 454 #  define perl_new_numeric(a)           new_numeric(a)
 455
 456 /* varargs functions can't be handled with CPP macros. :-(
 457    This provides a set of compatibility functions that don't take
 458    an extra argument but grab the context pointer using the macro
 459    dTHX.
 460  */
 461 #if defined(PERL_IMPLICIT_CONTEXT)
 462 #  define croak                         Perl_croak_nocontext
 463 #  define deb                           Perl_deb_nocontext
 464 #  define die                           Perl_die_nocontext
 465 #  define form                          Perl_form_nocontext
 466 #  define load_module                   Perl_load_module_nocontext
 467 #  define mess                          Perl_mess_nocontext
 468 #  define newSVpvf                      Perl_newSVpvf_nocontext
 469 #  define sv_catpvf                     Perl_sv_catpvf_nocontext
 470 #  define sv_setpvf                     Perl_sv_setpvf_nocontext
 471 #  define warn                          Perl_warn_nocontext
 472 #  define warner                        Perl_warner_nocontext
 473 #  define sv_catpvf_mg                  Perl_sv_catpvf_mg_nocontext
 474 #  define sv_setpvf_mg                  Perl_sv_setpvf_mg_nocontext
 475 #endif
 476
 477 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
 478
 479 #if !defined(PERL_IMPLICIT_CONTEXT)
 480 /* undefined symbols, point them back at the usual ones */
 481 #  define Perl_croak_nocontext          Perl_croak
 482 #  define Perl_die_nocontext            Perl_die
 483 #  define Perl_deb_nocontext            Perl_deb
 484 #  define Perl_form_nocontext           Perl_form
 485 #  define Perl_load_module_nocontext    Perl_load_module
 486 #  define Perl_mess_nocontext           Perl_mess
 487 #  define Perl_newSVpvf_nocontext       Perl_newSVpvf
 488 #  define Perl_sv_catpvf_nocontext      Perl_sv_catpvf
 489 #  define Perl_sv_setpvf_nocontext      Perl_sv_setpvf
 490 #  define Perl_warn_nocontext           Perl_warn
 491 #  define Perl_warner_nocontext         Perl_warner
 492 #  define Perl_sv_catpvf_mg_nocontext   Perl_sv_catpvf_mg
 493 #  define Perl_sv_setpvf_mg_nocontext   Perl_sv_setpvf_mg
 494 #endif
 495
 496 END
 497
 498 close(EM) or die "Error closing EM: $!";
 499
 500 safer_unlink 'embedvar.h';
 501 open(EM, '> embedvar.h')
 502     or die "Can't create embedvar.h: $!\n";
 503
 504 print EM do_not_edit ("embedvar.h"), <<'END';
 505
 506 /* (Doing namespace management portably in C is really gross.) */
 507
 508 /*
 509    The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
 510    are supported:
 511      1) none
 512      2) MULTIPLICITY    # supported for compatibility
 513      3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
 514
 515    All other combinations of these flags are errors.
 516
 517    only #3 is supported directly, while #2 is a special
 518    case of #3 (supported by redefining vTHX appropriately).
 519 */
 520
 521 #if defined(MULTIPLICITY)
 522 /* cases 2 and 3 above */
 523
 524 #  if defined(PERL_IMPLICIT_CONTEXT)
 525 #    define vTHX        aTHX
 526 #  else
 527 #    define vTHX        PERL_GET_INTERP
 528 #  endif
 529
 530 END
 531
 532 for $sym (sort keys %thread) {
 533     print EM multon($sym,'T','vTHX->');
 534 }
 535
 536 print EM <<'END';
 537
 538 /* cases 2 and 3 above */
 539
 540 END
 541
 542 for $sym (sort keys %intrp) {
 543     print EM multon($sym,'I','vTHX->');
 544 }
 545
 546 print EM <<'END';
 547
 548 #else   /* !MULTIPLICITY */
 549
 550 /* case 1 above */
 551
 552 END
 553
 554 for $sym (sort keys %intrp) {
 555     print EM multoff($sym,'I');
 556 }
 557
 558 print EM <<'END';
 559
 560 END
 561
 562 for $sym (sort keys %thread) {
 563     print EM multoff($sym,'T');
 564 }
 565
 566 print EM <<'END';
 567
 568 #endif  /* MULTIPLICITY */
 569
 570 #if defined(PERL_GLOBAL_STRUCT)
 571
 572 END
 573
 574 for $sym (sort keys %globvar) {
 575     print EM multon($sym,'G','PL_Vars.');
 576 }
 577
 578 print EM <<'END';
 579
 580 #else /* !PERL_GLOBAL_STRUCT */
 581
 582 END
 583
 584 for $sym (sort keys %globvar) {
 585     print EM multoff($sym,'G');
 586 }
 587
 588 print EM <<'END';
 589
 590 #endif /* PERL_GLOBAL_STRUCT */
 591
 592 #ifdef PERL_POLLUTE             /* disabled by default in 5.6.0 */
 593
 594 END
 595
 596 for $sym (sort @extvars) {
 597     print EM hide($sym,"PL_$sym");
 598 }
 599
 600 print EM <<'END';
 601
 602 #endif /* PERL_POLLUTE */
 603 END
 604
 605 close(EM) or die "Error closing EM: $!";
 606
 607 safer_unlink 'perlapi.h';
 608 safer_unlink 'perlapi.c';
 609 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
 610 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
 611
 612 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
 613
 614 /* declare accessor functions for Perl variables */
 615 #ifndef __perlapi_h__
 616 #define __perlapi_h__
 617
 618 #if defined (MULTIPLICITY)
 619
 620 START_EXTERN_C
 621
 622 #undef PERLVAR
 623 #undef PERLVARA
 624 #undef PERLVARI
 625 #undef PERLVARIC
 626 #define PERLVAR(v,t)    EXTERN_C t* Perl_##v##_ptr(pTHX);
 627 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n];                        \
 628                         EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
 629 #define PERLVARI(v,t,i) PERLVAR(v,t)
 630 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 631
 632 #include "thrdvar.h"
 633 #include "intrpvar.h"
 634 #include "perlvars.h"
 635
 636 #undef PERLVAR
 637 #undef PERLVARA
 638 #undef PERLVARI
 639 #undef PERLVARIC
 640
 641 END_EXTERN_C
 642
 643 #if defined(PERL_CORE)
 644
 645 /* accessor functions for Perl variables (provide binary compatibility) */
 646
 647 /* these need to be mentioned here, or most linkers won't put them in
 648    the perl executable */
 649
 650 #ifndef PERL_NO_FORCE_LINK
 651
 652 START_EXTERN_C
 653
 654 #ifndef DOINIT
 655 EXT void *PL_force_link_funcs[];
 656 #else
 657 EXT void *PL_force_link_funcs[] = {
 658 #undef PERLVAR
 659 #undef PERLVARA
 660 #undef PERLVARI
 661 #undef PERLVARIC
 662 #define PERLVAR(v,t)    (void*)Perl_##v##_ptr,
 663 #define PERLVARA(v,n,t) PERLVAR(v,t)
 664 #define PERLVARI(v,t,i) PERLVAR(v,t)
 665 #define PERLVARIC(v,t,i) PERLVAR(v,t)
 666
 667 #include "thrdvar.h"
 668 #include "intrpvar.h"
 669 #include "perlvars.h"
 670
 671 #undef PERLVAR
 672 #undef PERLVARA
 673 #undef PERLVARI
 674 #undef PERLVARIC
 675 };
 676 #endif  /* DOINIT */
 677
 678 END_EXTERN_C
 679
 680 #endif  /* PERL_NO_FORCE_LINK */
 681
 682 #else   /* !PERL_CORE */
 683
 684 EOT
 685
 686 foreach $sym (sort keys %intrp) {
 687     print CAPIH bincompat_var('I',$sym);
 688 }
 689
 690 foreach $sym (sort keys %thread) {
 691     print CAPIH bincompat_var('T',$sym);
 692 }
 693
 694 foreach $sym (sort keys %globvar) {
 695     print CAPIH bincompat_var('G',$sym);
 696 }
 697
 698 print CAPIH <<'EOT';
 699
 700 #endif /* !PERL_CORE */
 701 #endif /* MULTIPLICITY */
 702
 703 #endif /* __perlapi_h__ */
 704
 705 EOT
 706 close CAPIH or die "Error closing CAPIH: $!";
 707
 708 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
 709
 710 #include "EXTERN.h"
 711 #include "perl.h"
 712 #include "perlapi.h"
 713
 714 #if defined (MULTIPLICITY)
 715
 716 /* accessor functions for Perl variables (provides binary compatibility) */
 717 START_EXTERN_C
 718
 719 #undef PERLVAR
 720 #undef PERLVARA
 721 #undef PERLVARI
 722 #undef PERLVARIC
 723
 724 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 725                         { return &(aTHX->v); }
 726 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 727                         { return &(aTHX->v); }
 728
 729 #define PERLVARI(v,t,i) PERLVAR(v,t)
 730 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
 731
 732 #include "thrdvar.h"
 733 #include "intrpvar.h"
 734
 735 #undef PERLVAR
 736 #undef PERLVARA
 737 #define PERLVAR(v,t)    t* Perl_##v##_ptr(pTHX)                         \
 738                         { return &(PL_##v); }
 739 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX)                \
 740                         { return &(PL_##v); }
 741 #undef PERLVARIC
 742 #define PERLVARIC(v,t,i)        const t* Perl_##v##_ptr(pTHX)           \
 743                         { return (const t *)&(PL_##v); }
 744 #include "perlvars.h"
 745
 746 #undef PERLVAR
 747 #undef PERLVARA
 748 #undef PERLVARI
 749 #undef PERLVARIC
 750
 751 END_EXTERN_C
 752
 753 #endif /* MULTIPLICITY */
 754 EOT
 755
 756 close(CAPI) or die "Error closing CAPI: $!";
 757
 758 # functions that take va_list* for implementing vararg functions
 759 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
 760 # XXX %vfuncs currently unused
 761 my %vfuncs = qw(
 762     Perl_croak                  Perl_vcroak
 763     Perl_warn                   Perl_vwarn
 764     Perl_warner                 Perl_vwarner
 765     Perl_die                    Perl_vdie
 766     Perl_form                   Perl_vform
 767     Perl_load_module            Perl_vload_module
 768     Perl_mess                   Perl_vmess
 769     Perl_deb                    Perl_vdeb
 770     Perl_newSVpvf               Perl_vnewSVpvf
 771     Perl_sv_setpvf              Perl_sv_vsetpvf
 772     Perl_sv_setpvf_mg           Perl_sv_vsetpvf_mg
 773     Perl_sv_catpvf              Perl_sv_vcatpvf
 774     Perl_sv_catpvf_mg           Perl_sv_vcatpvf_mg
 775     Perl_dump_indent            Perl_dump_vindent
 776     Perl_default_protect        Perl_vdefault_protect
 777 );