3 require 5.003; # keep this compatible, an old perl is all we may have before
7 # Get function prototypes
8 require 'regen_lib.pl';
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.
22 my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005';
24 $years =~ s/1999,/1999,\n / if length $years > 40;
30 Copyright (C) $years, by Larry Wall and others
32 You may distribute under the terms of either the GNU General Public
33 License or the Artistic License, as specified in the README file.
35 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
36 This file is built by embed.pl from data in embed.fnc, embed.pl,
37 pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
38 Any changes made here will be lost!
40 Edit those files and run 'make regen_headers' to effect changes.
44 $warning .= <<EOW if $file eq 'perlapi.c';
46 Up to the threshold of the door there mounted a flight of twenty-seven
47 broad stairs, hewn by some unknown art of the same black stone. This
48 was the only entrance to the tower.
53 if ($file =~ m:\.[ch]$:) {
54 $warning =~ s:^: * :gm;
55 $warning =~ s: +$::gm;
60 $warning =~ s:^:# :gm;
61 $warning =~ s: +$::gm;
66 open IN, "embed.fnc" or die $!;
68 # walk table providing an array of components in each line to
69 # subroutine, printing the result
72 my $filename = shift || '-';
74 defined $leader or $leader = do_not_edit ($filename);
78 if (ref $filename) { # filehandle
82 safer_unlink $filename;
83 open F, ">$filename" or die "Can't open $filename: $!";
87 print $F $leader if $leader;
88 seek IN, 0, 0; # so we may restart
102 @args = split /\s*\|\s*/, $_;
104 my @outs = &{$function}(@args);
105 print $F @outs; # $function->(@args) is not 5.003
107 print $F $trailer if $trailer;
108 unless (ref $filename) {
109 close $F or die "Error closing $filename: $!";
113 sub munge_c_files () {
116 warn "\@ARGV empty, nothing to do\n";
121 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
126 # if (/^#\s*include\s+"perl.h"/) {
127 # my $file = uc $ARGV;
129 # print "#define PERL_IN_$file\n";
135 # if (exists $functions->{$f}) {
136 # my $flags = $functions->{$f}[0];
137 # $repl = "Perl_$repl" if $flags =~ /p/;
138 # unless ($flags =~ /n/) {
140 # $repl .= "_ " if @{$functions->{$f}} > 3;
142 # warn("$ARGV:$.:$repl\n");
146 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
150 if (exists $functions->{$f}) {
152 warn("$ARGV:$.:$`#$repl#$'");
157 close ARGV if eof; # restart $.
165 my $wrote_protected = 0;
174 my ($flags,$retval,$func,@args) = @_;
175 $ret .= '/* ' if $flags =~ /m/;
177 $retval = "STATIC $retval";
181 $retval = "PERL_CALLCONV $retval";
183 $func = "Perl_$func";
186 $ret .= "$retval\t$func(";
187 unless ($flags =~ /n/) {
189 $ret .= "_ " if @args;
192 $ret .= join ", ", @args;
195 $ret .= "void" if $flags =~ /n/;
198 $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
199 if( $flags =~ /f/ ) {
200 my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
201 my $args = scalar @args;
202 $ret .= sprintf "\n\t__attribute__format__(__printf__,%s%d,%s%d)",
203 $prefix, $args - 1, $prefix, $args;
206 $ret .= ' */' if $flags =~ /m/;
212 # generates global.sym (API export list), and populates %global with global symbols
213 sub write_global_sym {
216 my ($flags,$retval,$func,@args) = @_;
217 if ($flags =~ /[AX]/ && $flags !~ /[xm]/
218 || $flags =~ /b/) { # public API, so export
219 $func = "Perl_$func" if $flags =~ /[pbX]/;
226 walk_table(\&write_protos, "proto.h", undef);
227 walk_table(\&write_global_sym, "global.sym", undef);
229 # XXX others that may need adding
233 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
235 tainting tainted stack_base stack_sp sv_arenaroot
237 curstash DBsub DBsingle DBassertion debstash
251 my ($syms, $file) = @_;
253 open(FILE, "< $file")
254 or die "embed.pl: Can't open $file: $!\n";
256 s/[ \t]*#.*//; # Delete comments.
257 if (/^\s*(\S+)\s*$/) {
259 warn "duplicate symbol $sym while processing $file\n"
260 if exists $$syms{$sym};
267 # Perl_pp_* and Perl_ck_* are in pp.sym
268 readsyms my %ppsym, 'pp.sym';
270 sub readvars(\%$$@) {
271 my ($syms, $file,$pre,$keep_pre) = @_;
273 open(FILE, "< $file")
274 or die "embed.pl: Can't open $file: $!\n";
276 s/[ \t]*#.*//; # Delete comments.
277 if (/PERLVARA?I?S?C?\($pre(\w+)/) {
279 $sym = $pre . $sym if $keep_pre;
280 warn "duplicate symbol $sym while processing $file\n"
281 if exists $$syms{$sym};
282 $$syms{$sym} = $pre || 1;
291 readvars %intrp, 'intrpvar.h','I';
292 readvars %thread, 'thrdvar.h','T';
293 readvars %globvar, 'perlvars.h','G';
296 foreach $sym (sort keys %thread) {
297 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
306 my ($from, $to) = @_;
307 my $t = int(length($from) / 8);
308 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
311 sub bincompat_var ($$) {
312 my ($pfx, $sym) = @_;
313 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
314 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
318 my ($sym,$pre,$ptr) = @_;
319 hide("PL_$sym", "($ptr$pre$sym)");
324 return hide("PL_$pre$sym", "PL_$sym");
327 safer_unlink 'embed.h';
328 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
331 print EM do_not_edit ("embed.h"), <<'END';
333 /* (Doing namespace management portably in C is really gross.) */
335 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
336 * (like warn instead of Perl_warn) for the API are not defined.
337 * Not defining the short forms is a good thing for cleaner embedding. */
339 #ifndef PERL_NO_SHORT_NAMES
341 /* Hide global symbols */
343 #if !defined(PERL_IMPLICIT_CONTEXT)
347 # Try to elimiate lots of repeated
354 # by tracking state and merging foo and bar into one block.
355 my $ifdef_state = '';
359 my $new_ifdef_state = '';
362 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
365 my ($flags,$retval,$func,@args) = @_;
366 unless ($flags =~ /[om]/) {
368 $ret .= hide($func,"S_$func");
370 elsif ($flags =~ /p/) {
371 $ret .= hide($func,"Perl_$func");
374 if ($ret ne '' && $flags !~ /A/) {
377 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
380 $new_ifdef_state = "#ifdef PERL_CORE\n";
383 if ($new_ifdef_state ne $ifdef_state) {
384 $ret = $new_ifdef_state . $ret;
388 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
389 # Close the old one ahead of opening the new one.
390 $ret = "#endif\n$ret";
392 # Remember the new state.
393 $ifdef_state = $new_ifdef_state;
401 for $sym (sort keys %ppsym) {
403 print EM hide($sym, "Perl_$sym");
408 #else /* PERL_IMPLICIT_CONTEXT */
417 my $new_ifdef_state = '';
420 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
423 my ($flags,$retval,$func,@args) = @_;
424 unless ($flags =~ /[om]/) {
425 my $args = scalar @args;
426 if ($args and $args[$args-1] =~ /\.\.\./) {
427 # we're out of luck for varargs functions under CPP
429 elsif ($flags =~ /n/) {
431 $ret .= hide($func,"S_$func");
433 elsif ($flags =~ /p/) {
434 $ret .= hide($func,"Perl_$func");
438 my $alist = join(",", @az[0..$args-1]);
439 $ret = "#define $func($alist)";
440 my $t = int(length($ret) / 8);
441 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
443 $ret .= "S_$func(aTHX";
445 elsif ($flags =~ /p/) {
446 $ret .= "Perl_$func(aTHX";
448 $ret .= "_ " if $alist;
449 $ret .= $alist . ")\n";
452 unless ($flags =~ /A/) {
455 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
458 $new_ifdef_state = "#ifdef PERL_CORE\n";
461 if ($new_ifdef_state ne $ifdef_state) {
462 $ret = $new_ifdef_state . $ret;
466 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
467 # Close the old one ahead of opening the new one.
468 $ret = "#endif\n$ret";
470 # Remember the new state.
471 $ifdef_state = $new_ifdef_state;
479 for $sym (sort keys %ppsym) {
481 if ($sym =~ /^ck_/) {
482 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
484 elsif ($sym =~ /^pp_/) {
485 print EM hide("$sym()", "Perl_$sym(aTHX)");
488 warn "Illegal symbol '$sym' in pp.sym";
494 #endif /* PERL_IMPLICIT_CONTEXT */
496 #endif /* #ifndef PERL_NO_SHORT_NAMES */
502 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
506 #if !defined(PERL_CORE)
507 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
508 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
511 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
513 /* Compatibility for various misnamed functions. All functions
514 in the API that begin with "perl_" (not "Perl_") take an explicit
515 interpreter context pointer.
516 The following are not like that, but since they had a "perl_"
517 prefix in previous versions, we provide compatibility macros.
519 # define perl_atexit(a,b) call_atexit(a,b)
520 # define perl_call_argv(a,b,c) call_argv(a,b,c)
521 # define perl_call_pv(a,b) call_pv(a,b)
522 # define perl_call_method(a,b) call_method(a,b)
523 # define perl_call_sv(a,b) call_sv(a,b)
524 # define perl_eval_sv(a,b) eval_sv(a,b)
525 # define perl_eval_pv(a,b) eval_pv(a,b)
526 # define perl_require_pv(a) require_pv(a)
527 # define perl_get_sv(a,b) get_sv(a,b)
528 # define perl_get_av(a,b) get_av(a,b)
529 # define perl_get_hv(a,b) get_hv(a,b)
530 # define perl_get_cv(a,b) get_cv(a,b)
531 # define perl_init_i18nl10n(a) init_i18nl10n(a)
532 # define perl_init_i18nl14n(a) init_i18nl14n(a)
533 # define perl_new_ctype(a) new_ctype(a)
534 # define perl_new_collate(a) new_collate(a)
535 # define perl_new_numeric(a) new_numeric(a)
537 /* varargs functions can't be handled with CPP macros. :-(
538 This provides a set of compatibility functions that don't take
539 an extra argument but grab the context pointer using the macro
542 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
543 # define croak Perl_croak_nocontext
544 # define deb Perl_deb_nocontext
545 # define die Perl_die_nocontext
546 # define form Perl_form_nocontext
547 # define load_module Perl_load_module_nocontext
548 # define mess Perl_mess_nocontext
549 # define newSVpvf Perl_newSVpvf_nocontext
550 # define sv_catpvf Perl_sv_catpvf_nocontext
551 # define sv_setpvf Perl_sv_setpvf_nocontext
552 # define warn Perl_warn_nocontext
553 # define warner Perl_warner_nocontext
554 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
555 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
558 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
560 #if !defined(PERL_IMPLICIT_CONTEXT)
561 /* undefined symbols, point them back at the usual ones */
562 # define Perl_croak_nocontext Perl_croak
563 # define Perl_die_nocontext Perl_die
564 # define Perl_deb_nocontext Perl_deb
565 # define Perl_form_nocontext Perl_form
566 # define Perl_load_module_nocontext Perl_load_module
567 # define Perl_mess_nocontext Perl_mess
568 # define Perl_newSVpvf_nocontext Perl_newSVpvf
569 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
570 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
571 # define Perl_warn_nocontext Perl_warn
572 # define Perl_warner_nocontext Perl_warner
573 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
574 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
579 close(EM) or die "Error closing EM: $!";
581 safer_unlink 'embedvar.h';
582 open(EM, '> embedvar.h')
583 or die "Can't create embedvar.h: $!\n";
586 print EM do_not_edit ("embedvar.h"), <<'END';
588 /* (Doing namespace management portably in C is really gross.) */
591 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
594 2) MULTIPLICITY # supported for compatibility
595 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
597 All other combinations of these flags are errors.
599 only #3 is supported directly, while #2 is a special
600 case of #3 (supported by redefining vTHX appropriately).
603 #if defined(MULTIPLICITY)
604 /* cases 2 and 3 above */
606 # if defined(PERL_IMPLICIT_CONTEXT)
609 # define vTHX PERL_GET_INTERP
614 for $sym (sort keys %thread) {
615 print EM multon($sym,'T','vTHX->');
620 /* cases 2 and 3 above */
624 for $sym (sort keys %intrp) {
625 print EM multon($sym,'I','vTHX->');
630 #else /* !MULTIPLICITY */
636 for $sym (sort keys %intrp) {
637 print EM multoff($sym,'I');
644 for $sym (sort keys %thread) {
645 print EM multoff($sym,'T');
650 #endif /* MULTIPLICITY */
652 #if defined(PERL_GLOBAL_STRUCT)
656 for $sym (sort keys %globvar) {
657 print EM multon($sym, 'G','my_vars->');
658 print EM multon("G$sym",'', 'my_vars->');
663 #else /* !PERL_GLOBAL_STRUCT */
667 for $sym (sort keys %globvar) {
668 print EM multoff($sym,'G');
673 #endif /* PERL_GLOBAL_STRUCT */
675 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
679 for $sym (sort @extvars) {
680 print EM hide($sym,"PL_$sym");
685 #endif /* PERL_POLLUTE */
688 close(EM) or die "Error closing EM: $!";
690 safer_unlink 'perlapi.h';
691 safer_unlink 'perlapi.c';
692 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
694 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
697 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
699 /* declare accessor functions for Perl variables */
700 #ifndef __perlapi_h__
701 #define __perlapi_h__
703 #if defined (MULTIPLICITY)
712 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
713 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
714 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
715 #define PERLVARI(v,t,i) PERLVAR(v,t)
716 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
717 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
718 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
721 #include "intrpvar.h"
722 #include "perlvars.h"
730 #ifndef PERL_GLOBAL_STRUCT
731 EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
732 EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX);
733 EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
734 #define Perl_ppaddr_ptr Perl_Gppaddr_ptr
735 #define Perl_check_ptr Perl_Gcheck_ptr
736 #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
741 #if defined(PERL_CORE)
743 /* accessor functions for Perl variables (provide binary compatibility) */
745 /* these need to be mentioned here, or most linkers won't put them in
746 the perl executable */
748 #ifndef PERL_NO_FORCE_LINK
753 EXTCONST void * const PL_force_link_funcs[];
755 EXTCONST void * const PL_force_link_funcs[] = {
760 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
761 #define PERLVARA(v,n,t) PERLVAR(v,t)
762 #define PERLVARI(v,t,i) PERLVAR(v,t)
763 #define PERLVARIC(v,t,i) PERLVAR(v,t)
764 #define PERLVARISC(v,i) PERLVAR(v,char)
767 #include "intrpvar.h"
768 #include "perlvars.h"
780 #endif /* PERL_NO_FORCE_LINK */
782 #else /* !PERL_CORE */
786 foreach $sym (sort keys %intrp) {
787 print CAPIH bincompat_var('I',$sym);
790 foreach $sym (sort keys %thread) {
791 print CAPIH bincompat_var('T',$sym);
794 foreach $sym (sort keys %globvar) {
795 print CAPIH bincompat_var('G',$sym);
800 #endif /* !PERL_CORE */
801 #endif /* MULTIPLICITY */
803 #endif /* __perlapi_h__ */
806 close CAPIH or die "Error closing CAPIH: $!";
808 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
814 #if defined (MULTIPLICITY)
816 /* accessor functions for Perl variables (provides binary compatibility) */
825 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
826 { dVAR; return &(aTHX->v); }
827 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
828 { dVAR; return &(aTHX->v); }
830 #define PERLVARI(v,t,i) PERLVAR(v,t)
831 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
832 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
833 { dVAR; return &(aTHX->v); }
836 #include "intrpvar.h"
840 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
841 { dVAR; return &(PL_##v); }
842 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
843 { dVAR; return &(PL_##v); }
846 #define PERLVARIC(v,t,i) \
847 const t* Perl_##v##_ptr(pTHX) \
848 { return (const t *)&(PL_##v); }
849 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
850 { dVAR; return &(PL_##v); }
851 #include "perlvars.h"
859 #ifndef PERL_GLOBAL_STRUCT
860 /* A few evil special cases. Could probably macrofy this. */
863 #undef PL_fold_locale
864 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
865 static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr;
866 return (Perl_ppaddr_t**)&ppaddr_ptr;
868 Perl_check_t** Perl_Gcheck_ptr(pTHX) {
869 static const Perl_check_t* check_ptr = PL_check;
870 return (Perl_check_t**)&check_ptr;
872 unsigned char** Perl_Gfold_locale_ptr(pTHX) {
873 static const unsigned char* fold_locale_ptr = PL_fold_locale;
874 return (unsigned char**)&fold_locale_ptr;
880 #endif /* MULTIPLICITY */
883 close(CAPI) or die "Error closing CAPI: $!";
885 # functions that take va_list* for implementing vararg functions
886 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
887 # XXX %vfuncs currently unused
889 Perl_croak Perl_vcroak
891 Perl_warner Perl_vwarner
894 Perl_load_module Perl_vload_module
897 Perl_newSVpvf Perl_vnewSVpvf
898 Perl_sv_setpvf Perl_sv_vsetpvf
899 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
900 Perl_sv_catpvf Perl_sv_vcatpvf
901 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
902 Perl_dump_indent Perl_dump_vindent
903 Perl_default_protect Perl_vdefault_protect