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, 2006';
24 $years =~ s/1999,/1999,\n / if length $years > 40;
27 -*- buffer-read-only: t -*-
31 Copyright (C) $years, by Larry Wall and others
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.
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!
41 Edit those files and run 'make regen_headers' to effect changes.
45 $warning .= <<EOW if $file eq 'perlapi.c';
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.
54 if ($file =~ m:\.[ch]$:) {
55 $warning =~ s:^: * :gm;
56 $warning =~ s: +$::gm;
61 $warning =~ s:^:# :gm;
62 $warning =~ s: +$::gm;
67 open IN, "embed.fnc" or die $!;
69 # walk table providing an array of components in each line to
70 # subroutine, printing the result
73 my $filename = shift || '-';
75 defined $leader or $leader = do_not_edit ($filename);
79 if (ref $filename) { # filehandle
83 safer_unlink $filename if $filename ne '/dev/null';
84 open F, ">$filename" or die "Can't open $filename: $!";
88 print $F $leader if $leader;
89 seek IN, 0, 0; # so we may restart
103 @args = split /\s*\|\s*/, $_;
105 my @outs = &{$function}(@args);
106 print $F @outs; # $function->(@args) is not 5.003
108 print $F $trailer if $trailer;
109 unless (ref $filename) {
110 close $F or die "Error closing $filename: $!";
114 sub munge_c_files () {
117 warn "\@ARGV empty, nothing to do\n";
122 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
124 } '/dev/null', '', '';
127 # if (/^#\s*include\s+"perl.h"/) {
128 # my $file = uc $ARGV;
130 # print "#define PERL_IN_$file\n";
136 # if (exists $functions->{$f}) {
137 # my $flags = $functions->{$f}[0];
138 # $repl = "Perl_$repl" if $flags =~ /p/;
139 # unless ($flags =~ /n/) {
141 # $repl .= "_ " if @{$functions->{$f}} > 3;
143 # warn("$ARGV:$.:$repl\n");
147 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
151 if (exists $functions->{$f}) {
153 warn("$ARGV:$.:$`#$repl#$'");
158 close ARGV if eof; # restart $.
166 my $wrote_protected = 0;
175 my ($flags,$retval,$func,@args) = @_;
177 my $has_context = ( $flags !~ /n/ );
178 $ret .= '/* ' if $flags =~ /m/;
180 $retval = "STATIC $retval";
184 $retval = "PERL_CALLCONV $retval";
186 $func = "Perl_$func";
189 $ret .= "$retval\t$func(";
190 if ( $has_context ) {
191 $ret .= @args ? "pTHX_ " : "pTHX";
195 for my $arg ( @args ) {
197 if ( $arg =~ /\*/ && $arg !~ /\b(NN|NULLOK)\b/ ) {
198 warn "$func: $arg needs NN or NULLOK\n";
199 our $unflagged_pointers;
200 ++$unflagged_pointers;
202 # Given the bugs fixed by changes 25822 and 26253, for now
203 # strip NN with no effect, until I'm confident that there are
204 # no similar bugs lurking.
205 # push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
206 $arg =~ s/\s*\bNN\b\s+//;
208 $arg =~ s/\s*\bNULLOK\b\s+//; # strip NULLOK with no effect
210 $ret .= join ", ", @args;
213 $ret .= "void" if !$has_context;
217 if ( $flags =~ /r/ ) {
218 push @attrs, "__attribute__noreturn__";
220 if ( $flags =~ /a/ ) {
221 push @attrs, "__attribute__malloc__";
222 $flags .= "R"; # All allocing must check return value
224 if ( $flags =~ /R/ ) {
225 push @attrs, "__attribute__warn_unused_result__";
227 if ( $flags =~ /P/ ) {
228 push @attrs, "__attribute__pure__";
230 if( $flags =~ /f/ ) {
231 my $prefix = $has_context ? 'pTHX_' : '';
232 my $args = scalar @args;
233 push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
234 $prefix, $args - 1, $prefix, $args;
237 my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
238 push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
242 $ret .= join( "\n", map { "\t\t\t$_" } @attrs );
245 $ret .= ' */' if $flags =~ /m/;
246 $ret .= @attrs ? "\n\n" : "\n";
251 # generates global.sym (API export list)
254 sub write_global_sym {
257 my ($flags,$retval,$func,@args) = @_;
258 # If a function is defined twice, for example before and after an
259 # #else, only process the flags on the first instance for global.sym
260 return $ret if $seen{$func}++;
261 if ($flags =~ /[AX]/ && $flags !~ /[xm]/
262 || $flags =~ /b/) { # public API, so export
263 $func = "Perl_$func" if $flags =~ /[pbX]/;
272 our $unflagged_pointers;
273 walk_table(\&write_protos, "proto.h", undef, "/* ex: set ro: */\n");
274 warn "$unflagged_pointers pointer arguments to clean up\n" if $unflagged_pointers;
275 walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
277 # XXX others that may need adding
281 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
283 tainting tainted stack_base stack_sp sv_arenaroot
285 curstash DBsub DBsingle debstash
299 my ($syms, $file) = @_;
301 open(FILE, "< $file")
302 or die "embed.pl: Can't open $file: $!\n";
304 s/[ \t]*#.*//; # Delete comments.
305 if (/^\s*(\S+)\s*$/) {
307 warn "duplicate symbol $sym while processing $file\n"
308 if exists $$syms{$sym};
315 # Perl_pp_* and Perl_ck_* are in pp.sym
316 readsyms my %ppsym, 'pp.sym';
318 sub readvars(\%$$@) {
319 my ($syms, $file,$pre,$keep_pre) = @_;
321 open(FILE, "< $file")
322 or die "embed.pl: Can't open $file: $!\n";
324 s/[ \t]*#.*//; # Delete comments.
325 if (/PERLVARA?I?C?\($pre(\w+)/) {
327 $sym = $pre . $sym if $keep_pre;
328 warn "duplicate symbol $sym while processing $file\n"
329 if exists $$syms{$sym};
330 $$syms{$sym} = $pre || 1;
339 readvars %intrp, 'intrpvar.h','I';
340 readvars %thread, 'thrdvar.h','T';
341 readvars %globvar, 'perlvars.h','G';
344 foreach $sym (sort keys %thread) {
345 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
354 my ($from, $to) = @_;
355 my $t = int(length($from) / 8);
356 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
359 sub bincompat_var ($$) {
360 my ($pfx, $sym) = @_;
361 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
362 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
366 my ($sym,$pre,$ptr) = @_;
367 hide("PL_$sym", "($ptr$pre$sym)");
372 return hide("PL_$pre$sym", "PL_$sym");
375 safer_unlink 'embed.h';
376 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
379 print EM do_not_edit ("embed.h"), <<'END';
381 /* (Doing namespace management portably in C is really gross.) */
383 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
384 * (like warn instead of Perl_warn) for the API are not defined.
385 * Not defining the short forms is a good thing for cleaner embedding. */
387 #ifndef PERL_NO_SHORT_NAMES
389 /* Hide global symbols */
391 #if !defined(PERL_IMPLICIT_CONTEXT)
395 # Try to elimiate lots of repeated
402 # by tracking state and merging foo and bar into one block.
403 my $ifdef_state = '';
407 my $new_ifdef_state = '';
410 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
413 my ($flags,$retval,$func,@args) = @_;
414 unless ($flags =~ /[om]/) {
416 $ret .= hide($func,"S_$func");
418 elsif ($flags =~ /p/) {
419 $ret .= hide($func,"Perl_$func");
422 if ($ret ne '' && $flags !~ /A/) {
425 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
428 $new_ifdef_state = "#ifdef PERL_CORE\n";
431 if ($new_ifdef_state ne $ifdef_state) {
432 $ret = $new_ifdef_state . $ret;
436 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
437 # Close the old one ahead of opening the new one.
438 $ret = "#endif\n$ret";
440 # Remember the new state.
441 $ifdef_state = $new_ifdef_state;
449 for $sym (sort keys %ppsym) {
451 print EM hide($sym, "Perl_$sym");
456 #else /* PERL_IMPLICIT_CONTEXT */
465 my $new_ifdef_state = '';
468 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
471 my ($flags,$retval,$func,@args) = @_;
472 unless ($flags =~ /[om]/) {
473 my $args = scalar @args;
474 if ($args and $args[$args-1] =~ /\.\.\./) {
475 # we're out of luck for varargs functions under CPP
477 elsif ($flags =~ /n/) {
479 $ret .= hide($func,"S_$func");
481 elsif ($flags =~ /p/) {
482 $ret .= hide($func,"Perl_$func");
486 my $alist = join(",", @az[0..$args-1]);
487 $ret = "#define $func($alist)";
488 my $t = int(length($ret) / 8);
489 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
491 $ret .= "S_$func(aTHX";
493 elsif ($flags =~ /p/) {
494 $ret .= "Perl_$func(aTHX";
496 $ret .= "_ " if $alist;
497 $ret .= $alist . ")\n";
500 unless ($flags =~ /A/) {
503 = "#if defined(PERL_CORE) || defined(PERL_EXT)\n";
506 $new_ifdef_state = "#ifdef PERL_CORE\n";
509 if ($new_ifdef_state ne $ifdef_state) {
510 $ret = $new_ifdef_state . $ret;
514 if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
515 # Close the old one ahead of opening the new one.
516 $ret = "#endif\n$ret";
518 # Remember the new state.
519 $ifdef_state = $new_ifdef_state;
527 for $sym (sort keys %ppsym) {
529 if ($sym =~ /^ck_/) {
530 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
532 elsif ($sym =~ /^pp_/) {
533 print EM hide("$sym()", "Perl_$sym(aTHX)");
536 warn "Illegal symbol '$sym' in pp.sym";
542 #endif /* PERL_IMPLICIT_CONTEXT */
544 #endif /* #ifndef PERL_NO_SHORT_NAMES */
550 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
554 #if !defined(PERL_CORE)
555 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
556 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,NULL,PTR2IV(ptr))
559 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
561 /* Compatibility for various misnamed functions. All functions
562 in the API that begin with "perl_" (not "Perl_") take an explicit
563 interpreter context pointer.
564 The following are not like that, but since they had a "perl_"
565 prefix in previous versions, we provide compatibility macros.
567 # define perl_atexit(a,b) call_atexit(a,b)
568 # define perl_call_argv(a,b,c) call_argv(a,b,c)
569 # define perl_call_pv(a,b) call_pv(a,b)
570 # define perl_call_method(a,b) call_method(a,b)
571 # define perl_call_sv(a,b) call_sv(a,b)
572 # define perl_eval_sv(a,b) eval_sv(a,b)
573 # define perl_eval_pv(a,b) eval_pv(a,b)
574 # define perl_require_pv(a) require_pv(a)
575 # define perl_get_sv(a,b) get_sv(a,b)
576 # define perl_get_av(a,b) get_av(a,b)
577 # define perl_get_hv(a,b) get_hv(a,b)
578 # define perl_get_cv(a,b) get_cv(a,b)
579 # define perl_init_i18nl10n(a) init_i18nl10n(a)
580 # define perl_init_i18nl14n(a) init_i18nl14n(a)
581 # define perl_new_ctype(a) new_ctype(a)
582 # define perl_new_collate(a) new_collate(a)
583 # define perl_new_numeric(a) new_numeric(a)
585 /* varargs functions can't be handled with CPP macros. :-(
586 This provides a set of compatibility functions that don't take
587 an extra argument but grab the context pointer using the macro
590 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
591 # define croak Perl_croak_nocontext
592 # define deb Perl_deb_nocontext
593 # define die Perl_die_nocontext
594 # define form Perl_form_nocontext
595 # define load_module Perl_load_module_nocontext
596 # define mess Perl_mess_nocontext
597 # define newSVpvf Perl_newSVpvf_nocontext
598 # define sv_catpvf Perl_sv_catpvf_nocontext
599 # define sv_setpvf Perl_sv_setpvf_nocontext
600 # define warn Perl_warn_nocontext
601 # define warner Perl_warner_nocontext
602 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
603 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
606 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
608 #if !defined(PERL_IMPLICIT_CONTEXT)
609 /* undefined symbols, point them back at the usual ones */
610 # define Perl_croak_nocontext Perl_croak
611 # define Perl_die_nocontext Perl_die
612 # define Perl_deb_nocontext Perl_deb
613 # define Perl_form_nocontext Perl_form
614 # define Perl_load_module_nocontext Perl_load_module
615 # define Perl_mess_nocontext Perl_mess
616 # define Perl_newSVpvf_nocontext Perl_newSVpvf
617 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
618 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
619 # define Perl_warn_nocontext Perl_warn
620 # define Perl_warner_nocontext Perl_warner
621 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
622 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
628 close(EM) or die "Error closing EM: $!";
630 safer_unlink 'embedvar.h';
631 open(EM, '> embedvar.h')
632 or die "Can't create embedvar.h: $!\n";
635 print EM do_not_edit ("embedvar.h"), <<'END';
637 /* (Doing namespace management portably in C is really gross.) */
640 The following combinations of MULTIPLICITY, USE_5005THREADS
641 and PERL_IMPLICIT_CONTEXT are supported:
643 2) MULTIPLICITY # supported for compatibility
644 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
645 4) USE_5005THREADS && PERL_IMPLICIT_CONTEXT
646 5) MULTIPLICITY && USE_5005THREADS && PERL_IMPLICIT_CONTEXT
648 All other combinations of these flags are errors.
650 #3, #4, #5, and #6 are supported directly, while #2 is a special
651 case of #3 (supported by redefining vTHX appropriately).
654 #if defined(MULTIPLICITY)
655 /* cases 2, 3 and 5 above */
657 # if defined(PERL_IMPLICIT_CONTEXT)
660 # define vTHX PERL_GET_INTERP
665 for $sym (sort keys %thread) {
666 print EM multon($sym,'T','vTHX->');
671 # if defined(USE_5005THREADS)
676 for $sym (sort keys %intrp) {
677 print EM multon($sym,'I','PERL_GET_INTERP->');
682 # else /* !USE_5005THREADS */
683 /* cases 2 and 3 above */
687 for $sym (sort keys %intrp) {
688 print EM multon($sym,'I','vTHX->');
693 # endif /* USE_5005THREADS */
695 #else /* !MULTIPLICITY */
697 /* cases 1 and 4 above */
701 for $sym (sort keys %intrp) {
702 print EM multoff($sym,'I');
707 # if defined(USE_5005THREADS)
712 for $sym (sort keys %thread) {
713 print EM multon($sym,'T','aTHX->');
718 # else /* !USE_5005THREADS */
723 for $sym (sort keys %thread) {
724 print EM multoff($sym,'T');
729 # endif /* USE_5005THREADS */
730 #endif /* MULTIPLICITY */
732 #if defined(PERL_GLOBAL_STRUCT)
736 for $sym (sort keys %globvar) {
737 print EM multon($sym,'G','PL_Vars.');
742 #else /* !PERL_GLOBAL_STRUCT */
746 for $sym (sort keys %globvar) {
747 print EM multoff($sym,'G');
752 #endif /* PERL_GLOBAL_STRUCT */
754 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
758 for $sym (sort @extvars) {
759 print EM hide($sym,"PL_$sym");
764 #endif /* PERL_POLLUTE */
769 close(EM) or die "Error closing EM: $!";
771 safer_unlink 'perlapi.h';
772 safer_unlink 'perlapi.c';
773 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
775 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
778 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
780 /* declare accessor functions for Perl variables */
781 #ifndef __perlapi_h__
782 #define __perlapi_h__
784 #if defined (MULTIPLICITY)
792 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
793 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
794 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
795 #define PERLVARI(v,t,i) PERLVAR(v,t)
796 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
799 #include "intrpvar.h"
800 #include "perlvars.h"
809 #if defined(PERL_CORE)
811 /* accessor functions for Perl variables (provide binary compatibility) */
813 /* these need to be mentioned here, or most linkers won't put them in
814 the perl executable */
816 #ifndef PERL_NO_FORCE_LINK
821 EXT void *PL_force_link_funcs[];
823 EXT void *PL_force_link_funcs[] = {
828 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
829 #define PERLVARA(v,n,t) PERLVAR(v,t)
830 #define PERLVARI(v,t,i) PERLVAR(v,t)
831 #define PERLVARIC(v,t,i) PERLVAR(v,t)
833 /* In Tru64 (__DEC && __osf__) the cc option -std1 causes that one
834 * cannot cast between void pointers and function pointers without
835 * info level warnings. The PL_force_link_funcs[] would cause a few
836 * hundred of those warnings. In code one can circumnavigate this by using
837 * unions that overlay the different pointers, but in declarations one
838 * cannot use this trick. Therefore we just disable the warning here
839 * for the duration of the PL_force_link_funcs[] declaration. */
841 #if defined(__DECC) && defined(__osf__)
843 #pragma message disable (nonstandcast)
847 #include "intrpvar.h"
848 #include "perlvars.h"
850 #if defined(__DECC) && defined(__osf__)
851 #pragma message restore
863 #endif /* PERL_NO_FORCE_LINK */
865 #else /* !PERL_CORE */
869 foreach $sym (sort keys %intrp) {
870 print CAPIH bincompat_var('I',$sym);
873 foreach $sym (sort keys %thread) {
874 print CAPIH bincompat_var('T',$sym);
877 foreach $sym (sort keys %globvar) {
878 print CAPIH bincompat_var('G',$sym);
883 #endif /* !PERL_CORE */
884 #endif /* MULTIPLICITY */
886 #endif /* __perlapi_h__ */
890 close CAPIH or die "Error closing CAPIH: $!";
892 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
898 #if defined (MULTIPLICITY)
900 /* accessor functions for Perl variables (provides binary compatibility) */
908 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
909 { return &(aTHX->v); }
910 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
911 { return &(aTHX->v); }
913 #define PERLVARI(v,t,i) PERLVAR(v,t)
914 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
917 #include "intrpvar.h"
921 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
922 { return &(PL_##v); }
923 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
924 { return &(PL_##v); }
926 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
927 { return (const t *)&(PL_##v); }
928 #include "perlvars.h"
937 #endif /* MULTIPLICITY */
942 close(CAPI) or die "Error closing CAPI: $!";
944 # functions that take va_list* for implementing vararg functions
945 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
946 # XXX %vfuncs currently unused
948 Perl_croak Perl_vcroak
950 Perl_warner Perl_vwarner
953 Perl_load_module Perl_vload_module
956 Perl_newSVpvf Perl_vnewSVpvf
957 Perl_sv_setpvf Perl_sv_vsetpvf
958 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
959 Perl_sv_catpvf Perl_sv_vcatpvf
960 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
961 Perl_dump_indent Perl_dump_vindent
962 Perl_default_protect Perl_vdefault_protect
965 # ex: set ts=8 sts=4 sw=4 noet: