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) = @_;
176 my $has_context = ( $flags !~ /n/ );
177 $ret .= '/* ' if $flags =~ /m/;
179 $retval = "STATIC $retval";
183 $retval = "PERL_CALLCONV $retval";
185 $func = "Perl_$func";
188 $ret .= "$retval\t$func(";
189 if ( $has_context ) {
190 $ret .= @args ? "pTHX_ " : "pTHX";
194 for my $arg ( @args ) {
196 push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
198 $ret .= join ", ", @args;
201 $ret .= "void" if !$has_context;
204 $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
205 $ret .= "\n\t\t\t__attribute__((malloc)) __attribute__((warn_unused_result))" if $flags =~ /a/;
206 $ret .= "\n\t\t\t__attribute__((pure))" if $flags =~ /P/;
207 if( $flags =~ /f/ ) {
208 my $prefix = $has_context ? 'pTHX_' : '';
209 my $args = scalar @args;
210 $ret .= sprintf "\n\t\t\t__attribute__format__(__printf__,%s%d,%s%d)",
211 $prefix, $args - 1, $prefix, $args;
213 $ret .= "\n\t\t\t__attribute__((nonnull))" if $flags =~ /N/;
216 my @pos = map { $has_context ? $_ + 1 : $_ } @nonnull;
217 $ret .= sprintf( <<ATTR,
220 __attribute__((nonnull(%s)))
222 __attribute__((nonnull(%s)))
226 join( ",", @nonnull ),
230 $ret .= sprintf( "\n\t\t\t__attribute__((nonnull(%s)))", join( ",", @nonnull ) );
234 $ret .= ' */' if $flags =~ /m/;
240 # generates global.sym (API export list), and populates %global with global symbols
241 sub write_global_sym {
244 my ($flags,$retval,$func,@args) = @_;
245 if ($flags =~ /[AX]/ && $flags !~ /[xm]/
246 || $flags =~ /b/) { # public API, so export
247 $func = "Perl_$func" if $flags =~ /[pbX]/;
254 walk_table(\&write_protos, "proto.h", undef);
255 walk_table(\&write_global_sym, "global.sym", undef);
257 # XXX others that may need adding
261 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
263 tainting tainted stack_base stack_sp sv_arenaroot
265 curstash DBsub DBsingle DBassertion debstash
279 my ($syms, $file) = @_;
281 open(FILE, "< $file")
282 or die "embed.pl: Can't open $file: $!\n";
284 s/[ \t]*#.*//; # Delete comments.
285 if (/^\s*(\S+)\s*$/) {
287 warn "duplicate symbol $sym while processing $file\n"
288 if exists $$syms{$sym};
295 # Perl_pp_* and Perl_ck_* are in pp.sym
296 readsyms my %ppsym, 'pp.sym';
298 sub readvars(\%$$@) {
299 my ($syms, $file,$pre,$keep_pre) = @_;
301 open(FILE, "< $file")
302 or die "embed.pl: Can't open $file: $!\n";
304 s/[ \t]*#.*//; # Delete comments.
305 if (/PERLVARA?I?S?C?\($pre(\w+)/) {
307 $sym = $pre . $sym if $keep_pre;
308 warn "duplicate symbol $sym while processing $file\n"
309 if exists $$syms{$sym};
310 $$syms{$sym} = $pre || 1;
319 readvars %intrp, 'intrpvar.h','I';
320 readvars %thread, 'thrdvar.h','T';
321 readvars %globvar, 'perlvars.h','G';
324 foreach $sym (sort keys %thread) {
325 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
334 my ($from, $to) = @_;
335 my $t = int(length($from) / 8);
336 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
339 sub bincompat_var ($$) {
340 my ($pfx, $sym) = @_;
341 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
342 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
346 my ($sym,$pre,$ptr) = @_;
347 hide("PL_$sym", "($ptr$pre$sym)");
352 return hide("PL_$pre$sym", "PL_$sym");
355 safer_unlink 'embed.h';
356 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
359 print EM do_not_edit ("embed.h"), <<'END';
361 /* (Doing namespace management portably in C is really gross.) */
363 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
364 * (like warn instead of Perl_warn) for the API are not defined.
365 * Not defining the short forms is a good thing for cleaner embedding. */
367 #ifndef PERL_NO_SHORT_NAMES
369 /* Hide global symbols */
371 #if !defined(PERL_IMPLICIT_CONTEXT)
375 # Try to elimiate lots of repeated
382 # by tracking state and merging foo and bar into one block.
383 my $ifdef_state = '';
387 my $new_ifdef_state = '';
390 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
393 my ($flags,$retval,$func,@args) = @_;
394 unless ($flags =~ /[om]/) {
396 $ret .= hide($func,"S_$func");
398 elsif ($flags =~ /p/) {
399 $ret .= hide($func,"Perl_$func");
402 if ($ret ne '' && $flags !~ /A/) {
405 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
408 $new_ifdef_state = "#ifdef PERL_CORE\n";
411 if ($new_ifdef_state ne $ifdef_state) {
412 $ret = $new_ifdef_state . $ret;
416 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
417 # Close the old one ahead of opening the new one.
418 $ret = "#endif\n$ret";
420 # Remember the new state.
421 $ifdef_state = $new_ifdef_state;
429 for $sym (sort keys %ppsym) {
431 print EM hide($sym, "Perl_$sym");
436 #else /* PERL_IMPLICIT_CONTEXT */
445 my $new_ifdef_state = '';
448 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
451 my ($flags,$retval,$func,@args) = @_;
452 unless ($flags =~ /[om]/) {
453 my $args = scalar @args;
454 if ($args and $args[$args-1] =~ /\.\.\./) {
455 # we're out of luck for varargs functions under CPP
457 elsif ($flags =~ /n/) {
459 $ret .= hide($func,"S_$func");
461 elsif ($flags =~ /p/) {
462 $ret .= hide($func,"Perl_$func");
466 my $alist = join(",", @az[0..$args-1]);
467 $ret = "#define $func($alist)";
468 my $t = int(length($ret) / 8);
469 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
471 $ret .= "S_$func(aTHX";
473 elsif ($flags =~ /p/) {
474 $ret .= "Perl_$func(aTHX";
476 $ret .= "_ " if $alist;
477 $ret .= $alist . ")\n";
480 unless ($flags =~ /A/) {
483 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
486 $new_ifdef_state = "#ifdef PERL_CORE\n";
489 if ($new_ifdef_state ne $ifdef_state) {
490 $ret = $new_ifdef_state . $ret;
494 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
495 # Close the old one ahead of opening the new one.
496 $ret = "#endif\n$ret";
498 # Remember the new state.
499 $ifdef_state = $new_ifdef_state;
507 for $sym (sort keys %ppsym) {
509 if ($sym =~ /^ck_/) {
510 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
512 elsif ($sym =~ /^pp_/) {
513 print EM hide("$sym()", "Perl_$sym(aTHX)");
516 warn "Illegal symbol '$sym' in pp.sym";
522 #endif /* PERL_IMPLICIT_CONTEXT */
524 #endif /* #ifndef PERL_NO_SHORT_NAMES */
530 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
534 #if !defined(PERL_CORE)
535 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
536 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
539 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
541 /* Compatibility for various misnamed functions. All functions
542 in the API that begin with "perl_" (not "Perl_") take an explicit
543 interpreter context pointer.
544 The following are not like that, but since they had a "perl_"
545 prefix in previous versions, we provide compatibility macros.
547 # define perl_atexit(a,b) call_atexit(a,b)
548 # define perl_call_argv(a,b,c) call_argv(a,b,c)
549 # define perl_call_pv(a,b) call_pv(a,b)
550 # define perl_call_method(a,b) call_method(a,b)
551 # define perl_call_sv(a,b) call_sv(a,b)
552 # define perl_eval_sv(a,b) eval_sv(a,b)
553 # define perl_eval_pv(a,b) eval_pv(a,b)
554 # define perl_require_pv(a) require_pv(a)
555 # define perl_get_sv(a,b) get_sv(a,b)
556 # define perl_get_av(a,b) get_av(a,b)
557 # define perl_get_hv(a,b) get_hv(a,b)
558 # define perl_get_cv(a,b) get_cv(a,b)
559 # define perl_init_i18nl10n(a) init_i18nl10n(a)
560 # define perl_init_i18nl14n(a) init_i18nl14n(a)
561 # define perl_new_ctype(a) new_ctype(a)
562 # define perl_new_collate(a) new_collate(a)
563 # define perl_new_numeric(a) new_numeric(a)
565 /* varargs functions can't be handled with CPP macros. :-(
566 This provides a set of compatibility functions that don't take
567 an extra argument but grab the context pointer using the macro
570 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
571 # define croak Perl_croak_nocontext
572 # define deb Perl_deb_nocontext
573 # define die Perl_die_nocontext
574 # define form Perl_form_nocontext
575 # define load_module Perl_load_module_nocontext
576 # define mess Perl_mess_nocontext
577 # define newSVpvf Perl_newSVpvf_nocontext
578 # define sv_catpvf Perl_sv_catpvf_nocontext
579 # define sv_setpvf Perl_sv_setpvf_nocontext
580 # define warn Perl_warn_nocontext
581 # define warner Perl_warner_nocontext
582 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
583 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
586 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
588 #if !defined(PERL_IMPLICIT_CONTEXT)
589 /* undefined symbols, point them back at the usual ones */
590 # define Perl_croak_nocontext Perl_croak
591 # define Perl_die_nocontext Perl_die
592 # define Perl_deb_nocontext Perl_deb
593 # define Perl_form_nocontext Perl_form
594 # define Perl_load_module_nocontext Perl_load_module
595 # define Perl_mess_nocontext Perl_mess
596 # define Perl_newSVpvf_nocontext Perl_newSVpvf
597 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
598 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
599 # define Perl_warn_nocontext Perl_warn
600 # define Perl_warner_nocontext Perl_warner
601 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
602 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
607 close(EM) or die "Error closing EM: $!";
609 safer_unlink 'embedvar.h';
610 open(EM, '> embedvar.h')
611 or die "Can't create embedvar.h: $!\n";
614 print EM do_not_edit ("embedvar.h"), <<'END';
616 /* (Doing namespace management portably in C is really gross.) */
619 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
622 2) MULTIPLICITY # supported for compatibility
623 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
625 All other combinations of these flags are errors.
627 only #3 is supported directly, while #2 is a special
628 case of #3 (supported by redefining vTHX appropriately).
631 #if defined(MULTIPLICITY)
632 /* cases 2 and 3 above */
634 # if defined(PERL_IMPLICIT_CONTEXT)
637 # define vTHX PERL_GET_INTERP
642 for $sym (sort keys %thread) {
643 print EM multon($sym,'T','vTHX->');
648 /* cases 2 and 3 above */
652 for $sym (sort keys %intrp) {
653 print EM multon($sym,'I','vTHX->');
658 #else /* !MULTIPLICITY */
664 for $sym (sort keys %intrp) {
665 print EM multoff($sym,'I');
672 for $sym (sort keys %thread) {
673 print EM multoff($sym,'T');
678 #endif /* MULTIPLICITY */
680 #if defined(PERL_GLOBAL_STRUCT)
684 for $sym (sort keys %globvar) {
685 print EM multon($sym, 'G','my_vars->');
686 print EM multon("G$sym",'', 'my_vars->');
691 #else /* !PERL_GLOBAL_STRUCT */
695 for $sym (sort keys %globvar) {
696 print EM multoff($sym,'G');
701 #endif /* PERL_GLOBAL_STRUCT */
703 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
707 for $sym (sort @extvars) {
708 print EM hide($sym,"PL_$sym");
713 #endif /* PERL_POLLUTE */
716 close(EM) or die "Error closing EM: $!";
718 safer_unlink 'perlapi.h';
719 safer_unlink 'perlapi.c';
720 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
722 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
725 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
727 /* declare accessor functions for Perl variables */
728 #ifndef __perlapi_h__
729 #define __perlapi_h__
731 #if defined (MULTIPLICITY)
740 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
741 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
742 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
743 #define PERLVARI(v,t,i) PERLVAR(v,t)
744 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
745 #define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
746 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
749 #include "intrpvar.h"
750 #include "perlvars.h"
758 #ifndef PERL_GLOBAL_STRUCT
759 EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
760 EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX);
761 EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
762 #define Perl_ppaddr_ptr Perl_Gppaddr_ptr
763 #define Perl_check_ptr Perl_Gcheck_ptr
764 #define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
769 #if defined(PERL_CORE)
771 /* accessor functions for Perl variables (provide binary compatibility) */
773 /* these need to be mentioned here, or most linkers won't put them in
774 the perl executable */
776 #ifndef PERL_NO_FORCE_LINK
781 EXTCONST void * const PL_force_link_funcs[];
783 EXTCONST void * const PL_force_link_funcs[] = {
788 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
789 #define PERLVARA(v,n,t) PERLVAR(v,t)
790 #define PERLVARI(v,t,i) PERLVAR(v,t)
791 #define PERLVARIC(v,t,i) PERLVAR(v,t)
792 #define PERLVARISC(v,i) PERLVAR(v,char)
795 #include "intrpvar.h"
796 #include "perlvars.h"
808 #endif /* PERL_NO_FORCE_LINK */
810 #else /* !PERL_CORE */
814 foreach $sym (sort keys %intrp) {
815 print CAPIH bincompat_var('I',$sym);
818 foreach $sym (sort keys %thread) {
819 print CAPIH bincompat_var('T',$sym);
822 foreach $sym (sort keys %globvar) {
823 print CAPIH bincompat_var('G',$sym);
828 #endif /* !PERL_CORE */
829 #endif /* MULTIPLICITY */
831 #endif /* __perlapi_h__ */
834 close CAPIH or die "Error closing CAPIH: $!";
836 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
842 #if defined (MULTIPLICITY)
844 /* accessor functions for Perl variables (provides binary compatibility) */
853 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
854 { dVAR; return &(aTHX->v); }
855 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
856 { dVAR; return &(aTHX->v); }
858 #define PERLVARI(v,t,i) PERLVAR(v,t)
859 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
860 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
861 { dVAR; return &(aTHX->v); }
864 #include "intrpvar.h"
868 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
869 { dVAR; return &(PL_##v); }
870 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
871 { dVAR; return &(PL_##v); }
874 #define PERLVARIC(v,t,i) \
875 const t* Perl_##v##_ptr(pTHX) \
876 { return (const t *)&(PL_##v); }
877 #define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
878 { dVAR; return &(PL_##v); }
879 #include "perlvars.h"
887 #ifndef PERL_GLOBAL_STRUCT
888 /* A few evil special cases. Could probably macrofy this. */
891 #undef PL_fold_locale
892 Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
893 static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr;
894 return (Perl_ppaddr_t**)&ppaddr_ptr;
896 Perl_check_t** Perl_Gcheck_ptr(pTHX) {
897 static const Perl_check_t* check_ptr = PL_check;
898 return (Perl_check_t**)&check_ptr;
900 unsigned char** Perl_Gfold_locale_ptr(pTHX) {
901 static const unsigned char* fold_locale_ptr = PL_fold_locale;
902 return (unsigned char**)&fold_locale_ptr;
908 #endif /* MULTIPLICITY */
911 close(CAPI) or die "Error closing CAPI: $!";
913 # functions that take va_list* for implementing vararg functions
914 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
915 # XXX %vfuncs currently unused
917 Perl_croak Perl_vcroak
919 Perl_warner Perl_vwarner
922 Perl_load_module Perl_vload_module
925 Perl_newSVpvf Perl_vnewSVpvf
926 Perl_sv_setpvf Perl_sv_vsetpvf
927 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
928 Perl_sv_catpvf Perl_sv_vcatpvf
929 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
930 Perl_dump_indent Perl_dump_vindent
931 Perl_default_protect Perl_vdefault_protect