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.
24 if ($file eq 'embed.h') {
25 $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004';
26 } elsif ($file eq 'embedvar.h') {
27 $years = '1999, 2000, 2001, 2002, 2003, 2004';
28 } elsif ($file eq 'global.sym') {
29 $years = '1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004';
30 } elsif ($file eq 'perlapi.c') {
31 $years = '1999, 2000, 2001';
32 } elsif ($file eq 'perlapi.h') {
33 $years = '1999, 2000, 2001, 2002, 2003, 2004';
34 } elsif ($file eq 'proto.h') {
35 $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004';
38 $years =~ s/1999,/1999,\n / if length $years > 40;
44 Copyright (C) $years, by Larry Wall and others
46 You may distribute under the terms of either the GNU General Public
47 License or the Artistic License, as specified in the README file.
49 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
50 This file is built by embed.pl from data in embed.fnc, embed.pl,
51 pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
52 Any changes made here will be lost!
54 Edit those files and run 'make regen_headers' to effect changes.
58 $warning .= <<EOW if $file eq 'perlapi.c';
60 Up to the threshold of the door there mounted a flight of twenty-seven
61 broad stairs, hewn by some unknown art of the same black stone. This
62 was the only entrance to the tower.
67 if ($file =~ m:\.[ch]$:) {
68 $warning =~ s:^: * :gm;
69 $warning =~ s: +$::gm;
74 $warning =~ s:^:# :gm;
75 $warning =~ s: +$::gm;
80 open IN, "embed.fnc" or die $!;
82 # walk table providing an array of components in each line to
83 # subroutine, printing the result
86 my $filename = shift || '-';
88 defined $leader or $leader = do_not_edit ($filename);
92 if (ref $filename) { # filehandle
96 safer_unlink $filename;
97 open F, ">$filename" or die "Can't open $filename: $!";
101 print $F $leader if $leader;
102 seek IN, 0, 0; # so we may restart
115 @args = split /\s*\|\s*/, $_;
117 my @outs = &{$function}(@args);
118 print $F @outs; # $function->(@args) is not 5.003
120 print $F $trailer if $trailer;
121 unless (ref $filename) {
122 close $F or die "Error closing $filename: $!";
126 sub munge_c_files () {
129 warn "\@ARGV empty, nothing to do\n";
134 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
139 # if (/^#\s*include\s+"perl.h"/) {
140 # my $file = uc $ARGV;
142 # print "#define PERL_IN_$file\n";
148 # if (exists $functions->{$f}) {
149 # my $flags = $functions->{$f}[0];
150 # $repl = "Perl_$repl" if $flags =~ /p/;
151 # unless ($flags =~ /n/) {
153 # $repl .= "_ " if @{$functions->{$f}} > 3;
155 # warn("$ARGV:$.:$repl\n");
159 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
163 if (exists $functions->{$f}) {
165 warn("$ARGV:$.:$`#$repl#$'");
170 close ARGV if eof; # restart $.
178 my $wrote_protected = 0;
187 my ($flags,$retval,$func,@args) = @_;
188 $ret .= '/* ' if $flags =~ /m/;
190 $retval = "STATIC $retval";
194 $retval = "PERL_CALLCONV $retval";
196 $func = "Perl_$func";
199 $ret .= "$retval\t$func(";
200 unless ($flags =~ /n/) {
202 $ret .= "_ " if @args;
205 $ret .= join ", ", @args;
208 $ret .= "void" if $flags =~ /n/;
211 $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
212 if( $flags =~ /f/ ) {
213 my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
214 my $args = scalar @args;
215 $ret .= sprintf "\n\t__attribute__format__(__printf__,%s%d,%s%d)",
216 $prefix, $args - 1, $prefix, $args;
219 $ret .= ' */' if $flags =~ /m/;
225 # generates global.sym (API export list), and populates %global with global symbols
226 sub write_global_sym {
229 my ($flags,$retval,$func,@args) = @_;
230 if ($flags =~ /[AX]/ && $flags !~ /[xm]/
231 || $flags =~ /b/) { # public API, so export
232 $func = "Perl_$func" if $flags =~ /[pbX]/;
239 walk_table(\&write_protos, "proto.h", undef);
240 walk_table(\&write_global_sym, "global.sym", undef);
242 # XXX others that may need adding
246 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
248 tainting tainted stack_base stack_sp sv_arenaroot
250 curstash DBsub DBsingle DBassertion debstash
264 my ($syms, $file) = @_;
266 open(FILE, "< $file")
267 or die "embed.pl: Can't open $file: $!\n";
269 s/[ \t]*#.*//; # Delete comments.
270 if (/^\s*(\S+)\s*$/) {
272 warn "duplicate symbol $sym while processing $file\n"
273 if exists $$syms{$sym};
280 # Perl_pp_* and Perl_ck_* are in pp.sym
281 readsyms my %ppsym, 'pp.sym';
283 sub readvars(\%$$@) {
284 my ($syms, $file,$pre,$keep_pre) = @_;
286 open(FILE, "< $file")
287 or die "embed.pl: Can't open $file: $!\n";
289 s/[ \t]*#.*//; # Delete comments.
290 if (/PERLVARA?I?C?\($pre(\w+)/) {
292 $sym = $pre . $sym if $keep_pre;
293 warn "duplicate symbol $sym while processing $file\n"
294 if exists $$syms{$sym};
295 $$syms{$sym} = $pre || 1;
304 readvars %intrp, 'intrpvar.h','I';
305 readvars %thread, 'thrdvar.h','T';
306 readvars %globvar, 'perlvars.h','G';
309 foreach $sym (sort keys %thread) {
310 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
319 my ($from, $to) = @_;
320 my $t = int(length($from) / 8);
321 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
324 sub bincompat_var ($$) {
325 my ($pfx, $sym) = @_;
326 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
327 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
331 my ($sym,$pre,$ptr) = @_;
332 hide("PL_$sym", "($ptr$pre$sym)");
337 return hide("PL_$pre$sym", "PL_$sym");
340 safer_unlink 'embed.h';
341 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
344 print EM do_not_edit ("embed.h"), <<'END';
346 /* (Doing namespace management portably in C is really gross.) */
348 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
349 * (like warn instead of Perl_warn) for the API are not defined.
350 * Not defining the short forms is a good thing for cleaner embedding. */
352 #ifndef PERL_NO_SHORT_NAMES
354 /* Hide global symbols */
356 #if !defined(PERL_IMPLICIT_CONTEXT)
364 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
367 my ($flags,$retval,$func,@args) = @_;
368 unless ($flags =~ /[om]/) {
370 $ret .= hide($func,"S_$func");
372 elsif ($flags =~ /p/) {
373 $ret .= hide($func,"Perl_$func");
376 if ($ret ne '' && $flags !~ /A/) {
378 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
380 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
387 for $sym (sort keys %ppsym) {
389 print EM hide($sym, "Perl_$sym");
394 #else /* PERL_IMPLICIT_CONTEXT */
404 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
407 my ($flags,$retval,$func,@args) = @_;
408 unless ($flags =~ /[om]/) {
409 my $args = scalar @args;
410 if ($args and $args[$args-1] =~ /\.\.\./) {
411 # we're out of luck for varargs functions under CPP
413 elsif ($flags =~ /n/) {
415 $ret .= hide($func,"S_$func");
417 elsif ($flags =~ /p/) {
418 $ret .= hide($func,"Perl_$func");
422 my $alist = join(",", @az[0..$args-1]);
423 $ret = "#define $func($alist)";
424 my $t = int(length($ret) / 8);
425 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
427 $ret .= "S_$func(aTHX";
429 elsif ($flags =~ /p/) {
430 $ret .= "Perl_$func(aTHX";
432 $ret .= "_ " if $alist;
433 $ret .= $alist . ")\n";
436 unless ($flags =~ /A/) {
438 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
440 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
447 for $sym (sort keys %ppsym) {
449 if ($sym =~ /^ck_/) {
450 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
452 elsif ($sym =~ /^pp_/) {
453 print EM hide("$sym()", "Perl_$sym(aTHX)");
456 warn "Illegal symbol '$sym' in pp.sym";
462 #endif /* PERL_IMPLICIT_CONTEXT */
464 #endif /* #ifndef PERL_NO_SHORT_NAMES */
470 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
474 #if !defined(PERL_CORE)
475 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
476 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
479 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
481 /* Compatibility for various misnamed functions. All functions
482 in the API that begin with "perl_" (not "Perl_") take an explicit
483 interpreter context pointer.
484 The following are not like that, but since they had a "perl_"
485 prefix in previous versions, we provide compatibility macros.
487 # define perl_atexit(a,b) call_atexit(a,b)
488 # define perl_call_argv(a,b,c) call_argv(a,b,c)
489 # define perl_call_pv(a,b) call_pv(a,b)
490 # define perl_call_method(a,b) call_method(a,b)
491 # define perl_call_sv(a,b) call_sv(a,b)
492 # define perl_eval_sv(a,b) eval_sv(a,b)
493 # define perl_eval_pv(a,b) eval_pv(a,b)
494 # define perl_require_pv(a) require_pv(a)
495 # define perl_get_sv(a,b) get_sv(a,b)
496 # define perl_get_av(a,b) get_av(a,b)
497 # define perl_get_hv(a,b) get_hv(a,b)
498 # define perl_get_cv(a,b) get_cv(a,b)
499 # define perl_init_i18nl10n(a) init_i18nl10n(a)
500 # define perl_init_i18nl14n(a) init_i18nl14n(a)
501 # define perl_new_ctype(a) new_ctype(a)
502 # define perl_new_collate(a) new_collate(a)
503 # define perl_new_numeric(a) new_numeric(a)
505 /* varargs functions can't be handled with CPP macros. :-(
506 This provides a set of compatibility functions that don't take
507 an extra argument but grab the context pointer using the macro
510 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
511 # define croak Perl_croak_nocontext
512 # define deb Perl_deb_nocontext
513 # define die Perl_die_nocontext
514 # define form Perl_form_nocontext
515 # define load_module Perl_load_module_nocontext
516 # define mess Perl_mess_nocontext
517 # define newSVpvf Perl_newSVpvf_nocontext
518 # define sv_catpvf Perl_sv_catpvf_nocontext
519 # define sv_setpvf Perl_sv_setpvf_nocontext
520 # define warn Perl_warn_nocontext
521 # define warner Perl_warner_nocontext
522 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
523 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
526 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
528 #if !defined(PERL_IMPLICIT_CONTEXT)
529 /* undefined symbols, point them back at the usual ones */
530 # define Perl_croak_nocontext Perl_croak
531 # define Perl_die_nocontext Perl_die
532 # define Perl_deb_nocontext Perl_deb
533 # define Perl_form_nocontext Perl_form
534 # define Perl_load_module_nocontext Perl_load_module
535 # define Perl_mess_nocontext Perl_mess
536 # define Perl_newSVpvf_nocontext Perl_newSVpvf
537 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
538 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
539 # define Perl_warn_nocontext Perl_warn
540 # define Perl_warner_nocontext Perl_warner
541 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
542 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
547 close(EM) or die "Error closing EM: $!";
549 safer_unlink 'embedvar.h';
550 open(EM, '> embedvar.h')
551 or die "Can't create embedvar.h: $!\n";
554 print EM do_not_edit ("embedvar.h"), <<'END';
556 /* (Doing namespace management portably in C is really gross.) */
559 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
562 2) MULTIPLICITY # supported for compatibility
563 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
565 All other combinations of these flags are errors.
567 only #3 is supported directly, while #2 is a special
568 case of #3 (supported by redefining vTHX appropriately).
571 #if defined(MULTIPLICITY)
572 /* cases 2 and 3 above */
574 # if defined(PERL_IMPLICIT_CONTEXT)
577 # define vTHX PERL_GET_INTERP
582 for $sym (sort keys %thread) {
583 print EM multon($sym,'T','vTHX->');
588 /* cases 2 and 3 above */
592 for $sym (sort keys %intrp) {
593 print EM multon($sym,'I','vTHX->');
598 #else /* !MULTIPLICITY */
604 for $sym (sort keys %intrp) {
605 print EM multoff($sym,'I');
612 for $sym (sort keys %thread) {
613 print EM multoff($sym,'T');
618 #endif /* MULTIPLICITY */
620 #if defined(PERL_GLOBAL_STRUCT)
624 for $sym (sort keys %globvar) {
625 print EM multon($sym,'G','PL_Vars.');
630 #else /* !PERL_GLOBAL_STRUCT */
634 for $sym (sort keys %globvar) {
635 print EM multoff($sym,'G');
640 #endif /* PERL_GLOBAL_STRUCT */
642 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
646 for $sym (sort @extvars) {
647 print EM hide($sym,"PL_$sym");
652 #endif /* PERL_POLLUTE */
655 close(EM) or die "Error closing EM: $!";
657 safer_unlink 'perlapi.h';
658 safer_unlink 'perlapi.c';
659 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
661 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
664 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
666 /* declare accessor functions for Perl variables */
667 #ifndef __perlapi_h__
668 #define __perlapi_h__
670 #if defined (MULTIPLICITY)
678 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
679 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
680 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
681 #define PERLVARI(v,t,i) PERLVAR(v,t)
682 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
685 #include "intrpvar.h"
686 #include "perlvars.h"
695 #if defined(PERL_CORE)
697 /* accessor functions for Perl variables (provide binary compatibility) */
699 /* these need to be mentioned here, or most linkers won't put them in
700 the perl executable */
702 #ifndef PERL_NO_FORCE_LINK
707 EXT void *PL_force_link_funcs[];
709 EXT void *PL_force_link_funcs[] = {
714 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
715 #define PERLVARA(v,n,t) PERLVAR(v,t)
716 #define PERLVARI(v,t,i) PERLVAR(v,t)
717 #define PERLVARIC(v,t,i) PERLVAR(v,t)
720 #include "intrpvar.h"
721 #include "perlvars.h"
732 #endif /* PERL_NO_FORCE_LINK */
734 #else /* !PERL_CORE */
738 foreach $sym (sort keys %intrp) {
739 print CAPIH bincompat_var('I',$sym);
742 foreach $sym (sort keys %thread) {
743 print CAPIH bincompat_var('T',$sym);
746 foreach $sym (sort keys %globvar) {
747 print CAPIH bincompat_var('G',$sym);
752 #endif /* !PERL_CORE */
753 #endif /* MULTIPLICITY */
755 #endif /* __perlapi_h__ */
758 close CAPIH or die "Error closing CAPIH: $!";
760 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
766 #if defined (MULTIPLICITY)
768 /* accessor functions for Perl variables (provides binary compatibility) */
776 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
777 { return &(aTHX->v); }
778 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
779 { return &(aTHX->v); }
781 #define PERLVARI(v,t,i) PERLVAR(v,t)
782 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
785 #include "intrpvar.h"
789 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
790 { return &(PL_##v); }
791 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
792 { return &(PL_##v); }
794 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
795 { return (const t *)&(PL_##v); }
796 #include "perlvars.h"
805 #endif /* MULTIPLICITY */
808 close(CAPI) or die "Error closing CAPI: $!";
810 # functions that take va_list* for implementing vararg functions
811 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
812 # XXX %vfuncs currently unused
814 Perl_croak Perl_vcroak
816 Perl_warner Perl_vwarner
819 Perl_load_module Perl_vload_module
822 Perl_newSVpvf Perl_vnewSVpvf
823 Perl_sv_setpvf Perl_sv_vsetpvf
824 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
825 Perl_sv_catpvf Perl_sv_vcatpvf
826 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
827 Perl_dump_indent Perl_dump_vindent
828 Perl_default_protect Perl_vdefault_protect