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';
26 } elsif ($file eq 'embedvar.h') {
27 $years = '1999, 2000, 2001, 2002, 2003';
28 } elsif ($file eq 'global.sym') {
29 $years = '1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003';
30 } elsif ($file eq 'perlapi.c') {
31 $years = '1999, 2000, 2001';
32 } elsif ($file eq 'perlapi.h') {
33 $years = '1999, 2000, 2001, 2002, 2003';
34 } elsif ($file eq 'proto.h') {
35 $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003';
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 if ($file =~ m:\.[ch]$:) {
59 $warning =~ s:^: * :gm;
60 $warning =~ s: +$::gm;
65 $warning =~ s:^:# :gm;
66 $warning =~ s: +$::gm;
71 open IN, "embed.fnc" or die $!;
73 # walk table providing an array of components in each line to
74 # subroutine, printing the result
77 my $filename = shift || '-';
79 defined $leader or $leader = do_not_edit ($filename);
83 if (ref $filename) { # filehandle
87 safer_unlink $filename;
88 open F, ">$filename" or die "Can't open $filename: $!";
91 print $F $leader if $leader;
92 seek IN, 0, 0; # so we may restart
105 @args = split /\s*\|\s*/, $_;
107 my @outs = &{$function}(@args);
108 print $F @outs; # $function->(@args) is not 5.003
110 print $F $trailer if $trailer;
111 unless (ref $filename) {
112 close $F or die "Error closing $filename: $!";
116 sub munge_c_files () {
119 warn "\@ARGV empty, nothing to do\n";
124 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
129 # if (/^#\s*include\s+"perl.h"/) {
130 # my $file = uc $ARGV;
132 # print "#define PERL_IN_$file\n";
138 # if (exists $functions->{$f}) {
139 # my $flags = $functions->{$f}[0];
140 # $repl = "Perl_$repl" if $flags =~ /p/;
141 # unless ($flags =~ /n/) {
143 # $repl .= "_ " if @{$functions->{$f}} > 3;
145 # warn("$ARGV:$.:$repl\n");
149 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
153 if (exists $functions->{$f}) {
155 warn("$ARGV:$.:$`#$repl#$'");
160 close ARGV if eof; # restart $.
168 my $wrote_protected = 0;
177 my ($flags,$retval,$func,@args) = @_;
178 $ret .= '/* ' if $flags =~ /m/;
180 $retval = "STATIC $retval";
184 $retval = "PERL_CALLCONV $retval";
186 $func = "Perl_$func";
189 $ret .= "$retval\t$func(";
190 unless ($flags =~ /n/) {
192 $ret .= "_ " if @args;
195 $ret .= join ", ", @args;
198 $ret .= "void" if $flags =~ /n/;
201 $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
202 if( $flags =~ /f/ ) {
203 my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
204 my $args = scalar @args;
205 $ret .= "\n#ifdef CHECK_FORMAT\n";
207 sprintf " __attribute__((__format__(__printf__,%s%d,%s%d)))",
208 $prefix, $args - 1, $prefix, $args;
209 $ret .= "\n#endif\n";
212 $ret .= ' */' if $flags =~ /m/;
218 # generates global.sym (API export list), and populates %global with global symbols
219 sub write_global_sym {
222 my ($flags,$retval,$func,@args) = @_;
223 if ($flags =~ /[AX]/ && $flags !~ /[xm]/
224 || $flags =~ /b/) { # public API, so export
225 $func = "Perl_$func" if $flags =~ /[pbX]/;
232 walk_table(\&write_protos, "proto.h", undef);
233 walk_table(\&write_global_sym, "global.sym", undef);
235 # XXX others that may need adding
239 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
241 tainting tainted stack_base stack_sp sv_arenaroot
243 curstash DBsub DBsingle DBassertion debstash
257 my ($syms, $file) = @_;
259 open(FILE, "< $file")
260 or die "embed.pl: Can't open $file: $!\n";
262 s/[ \t]*#.*//; # Delete comments.
263 if (/^\s*(\S+)\s*$/) {
265 warn "duplicate symbol $sym while processing $file\n"
266 if exists $$syms{$sym};
273 # Perl_pp_* and Perl_ck_* are in pp.sym
274 readsyms my %ppsym, 'pp.sym';
276 sub readvars(\%$$@) {
277 my ($syms, $file,$pre,$keep_pre) = @_;
279 open(FILE, "< $file")
280 or die "embed.pl: Can't open $file: $!\n";
282 s/[ \t]*#.*//; # Delete comments.
283 if (/PERLVARA?I?C?\($pre(\w+)/) {
285 $sym = $pre . $sym if $keep_pre;
286 warn "duplicate symbol $sym while processing $file\n"
287 if exists $$syms{$sym};
288 $$syms{$sym} = $pre || 1;
297 readvars %intrp, 'intrpvar.h','I';
298 readvars %thread, 'thrdvar.h','T';
299 readvars %globvar, 'perlvars.h','G';
302 foreach $sym (sort keys %thread) {
303 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
312 my ($from, $to) = @_;
313 my $t = int(length($from) / 8);
314 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
317 sub bincompat_var ($$) {
318 my ($pfx, $sym) = @_;
319 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
320 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
324 my ($sym,$pre,$ptr) = @_;
325 hide("PL_$sym", "($ptr$pre$sym)");
330 return hide("PL_$pre$sym", "PL_$sym");
333 safer_unlink 'embed.h';
334 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
336 print EM do_not_edit ("embed.h"), <<'END';
338 /* (Doing namespace management portably in C is really gross.) */
340 /* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
341 * (like warn instead of Perl_warn) for the API are not defined.
342 * Not defining the short forms is a good thing for cleaner embedding. */
344 #ifndef PERL_NO_SHORT_NAMES
346 /* Hide global symbols */
348 #if !defined(PERL_IMPLICIT_CONTEXT)
356 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
359 my ($flags,$retval,$func,@args) = @_;
360 unless ($flags =~ /[om]/) {
362 $ret .= hide($func,"S_$func");
364 elsif ($flags =~ /p/) {
365 $ret .= hide($func,"Perl_$func");
368 if ($ret ne '' && $flags !~ /A/) {
370 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
372 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
379 for $sym (sort keys %ppsym) {
381 print EM hide($sym, "Perl_$sym");
386 #else /* PERL_IMPLICIT_CONTEXT */
396 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
399 my ($flags,$retval,$func,@args) = @_;
400 unless ($flags =~ /[om]/) {
401 my $args = scalar @args;
402 if ($args and $args[$args-1] =~ /\.\.\./) {
403 # we're out of luck for varargs functions under CPP
405 elsif ($flags =~ /n/) {
407 $ret .= hide($func,"S_$func");
409 elsif ($flags =~ /p/) {
410 $ret .= hide($func,"Perl_$func");
414 my $alist = join(",", @az[0..$args-1]);
415 $ret = "#define $func($alist)";
416 my $t = int(length($ret) / 8);
417 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
419 $ret .= "S_$func(aTHX";
421 elsif ($flags =~ /p/) {
422 $ret .= "Perl_$func(aTHX";
424 $ret .= "_ " if $alist;
425 $ret .= $alist . ")\n";
428 unless ($flags =~ /A/) {
430 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
432 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
439 for $sym (sort keys %ppsym) {
441 if ($sym =~ /^ck_/) {
442 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
444 elsif ($sym =~ /^pp_/) {
445 print EM hide("$sym()", "Perl_$sym(aTHX)");
448 warn "Illegal symbol '$sym' in pp.sym";
454 #endif /* PERL_IMPLICIT_CONTEXT */
456 #endif /* #ifndef PERL_NO_SHORT_NAMES */
462 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
466 #if !defined(PERL_CORE)
467 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
468 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
471 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
473 /* Compatibility for various misnamed functions. All functions
474 in the API that begin with "perl_" (not "Perl_") take an explicit
475 interpreter context pointer.
476 The following are not like that, but since they had a "perl_"
477 prefix in previous versions, we provide compatibility macros.
479 # define perl_atexit(a,b) call_atexit(a,b)
480 # define perl_call_argv(a,b,c) call_argv(a,b,c)
481 # define perl_call_pv(a,b) call_pv(a,b)
482 # define perl_call_method(a,b) call_method(a,b)
483 # define perl_call_sv(a,b) call_sv(a,b)
484 # define perl_eval_sv(a,b) eval_sv(a,b)
485 # define perl_eval_pv(a,b) eval_pv(a,b)
486 # define perl_require_pv(a) require_pv(a)
487 # define perl_get_sv(a,b) get_sv(a,b)
488 # define perl_get_av(a,b) get_av(a,b)
489 # define perl_get_hv(a,b) get_hv(a,b)
490 # define perl_get_cv(a,b) get_cv(a,b)
491 # define perl_init_i18nl10n(a) init_i18nl10n(a)
492 # define perl_init_i18nl14n(a) init_i18nl14n(a)
493 # define perl_new_ctype(a) new_ctype(a)
494 # define perl_new_collate(a) new_collate(a)
495 # define perl_new_numeric(a) new_numeric(a)
497 /* varargs functions can't be handled with CPP macros. :-(
498 This provides a set of compatibility functions that don't take
499 an extra argument but grab the context pointer using the macro
502 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
503 # define croak Perl_croak_nocontext
504 # define deb Perl_deb_nocontext
505 # define die Perl_die_nocontext
506 # define form Perl_form_nocontext
507 # define load_module Perl_load_module_nocontext
508 # define mess Perl_mess_nocontext
509 # define newSVpvf Perl_newSVpvf_nocontext
510 # define sv_catpvf Perl_sv_catpvf_nocontext
511 # define sv_setpvf Perl_sv_setpvf_nocontext
512 # define warn Perl_warn_nocontext
513 # define warner Perl_warner_nocontext
514 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
515 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
518 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
520 #if !defined(PERL_IMPLICIT_CONTEXT)
521 /* undefined symbols, point them back at the usual ones */
522 # define Perl_croak_nocontext Perl_croak
523 # define Perl_die_nocontext Perl_die
524 # define Perl_deb_nocontext Perl_deb
525 # define Perl_form_nocontext Perl_form
526 # define Perl_load_module_nocontext Perl_load_module
527 # define Perl_mess_nocontext Perl_mess
528 # define Perl_newSVpvf_nocontext Perl_newSVpvf
529 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
530 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
531 # define Perl_warn_nocontext Perl_warn
532 # define Perl_warner_nocontext Perl_warner
533 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
534 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
539 close(EM) or die "Error closing EM: $!";
541 safer_unlink 'embedvar.h';
542 open(EM, '> embedvar.h')
543 or die "Can't create embedvar.h: $!\n";
545 print EM do_not_edit ("embedvar.h"), <<'END';
547 /* (Doing namespace management portably in C is really gross.) */
550 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
553 2) MULTIPLICITY # supported for compatibility
554 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
556 All other combinations of these flags are errors.
558 only #3 is supported directly, while #2 is a special
559 case of #3 (supported by redefining vTHX appropriately).
562 #if defined(MULTIPLICITY)
563 /* cases 2 and 3 above */
565 # if defined(PERL_IMPLICIT_CONTEXT)
568 # define vTHX PERL_GET_INTERP
573 for $sym (sort keys %thread) {
574 print EM multon($sym,'T','vTHX->');
579 /* cases 2 and 3 above */
583 for $sym (sort keys %intrp) {
584 print EM multon($sym,'I','vTHX->');
589 #else /* !MULTIPLICITY */
595 for $sym (sort keys %intrp) {
596 print EM multoff($sym,'I');
603 for $sym (sort keys %thread) {
604 print EM multoff($sym,'T');
609 #endif /* MULTIPLICITY */
611 #if defined(PERL_GLOBAL_STRUCT)
615 for $sym (sort keys %globvar) {
616 print EM multon($sym,'G','PL_Vars.');
621 #else /* !PERL_GLOBAL_STRUCT */
625 for $sym (sort keys %globvar) {
626 print EM multoff($sym,'G');
631 #endif /* PERL_GLOBAL_STRUCT */
633 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
637 for $sym (sort @extvars) {
638 print EM hide($sym,"PL_$sym");
643 #endif /* PERL_POLLUTE */
646 close(EM) or die "Error closing EM: $!";
648 safer_unlink 'perlapi.h';
649 safer_unlink 'perlapi.c';
650 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
651 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
653 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
655 /* declare accessor functions for Perl variables */
656 #ifndef __perlapi_h__
657 #define __perlapi_h__
659 #if defined (MULTIPLICITY)
667 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
668 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
669 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
670 #define PERLVARI(v,t,i) PERLVAR(v,t)
671 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
674 #include "intrpvar.h"
675 #include "perlvars.h"
684 #if defined(PERL_CORE)
686 /* accessor functions for Perl variables (provide binary compatibility) */
688 /* these need to be mentioned here, or most linkers won't put them in
689 the perl executable */
691 #ifndef PERL_NO_FORCE_LINK
696 EXT void *PL_force_link_funcs[];
698 EXT void *PL_force_link_funcs[] = {
703 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
704 #define PERLVARA(v,n,t) PERLVAR(v,t)
705 #define PERLVARI(v,t,i) PERLVAR(v,t)
706 #define PERLVARIC(v,t,i) PERLVAR(v,t)
709 #include "intrpvar.h"
710 #include "perlvars.h"
721 #endif /* PERL_NO_FORCE_LINK */
723 #else /* !PERL_CORE */
727 foreach $sym (sort keys %intrp) {
728 print CAPIH bincompat_var('I',$sym);
731 foreach $sym (sort keys %thread) {
732 print CAPIH bincompat_var('T',$sym);
735 foreach $sym (sort keys %globvar) {
736 print CAPIH bincompat_var('G',$sym);
741 #endif /* !PERL_CORE */
742 #endif /* MULTIPLICITY */
744 #endif /* __perlapi_h__ */
747 close CAPIH or die "Error closing CAPIH: $!";
749 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
755 #if defined (MULTIPLICITY)
757 /* accessor functions for Perl variables (provides binary compatibility) */
765 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
766 { return &(aTHX->v); }
767 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
768 { return &(aTHX->v); }
770 #define PERLVARI(v,t,i) PERLVAR(v,t)
771 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
774 #include "intrpvar.h"
778 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
779 { return &(PL_##v); }
780 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
781 { return &(PL_##v); }
783 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
784 { return (const t *)&(PL_##v); }
785 #include "perlvars.h"
794 #endif /* MULTIPLICITY */
797 close(CAPI) or die "Error closing CAPI: $!";
799 # functions that take va_list* for implementing vararg functions
800 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
801 # XXX %vfuncs currently unused
803 Perl_croak Perl_vcroak
805 Perl_warner Perl_vwarner
808 Perl_load_module Perl_vload_module
811 Perl_newSVpvf Perl_vnewSVpvf
812 Perl_sv_setpvf Perl_sv_vsetpvf
813 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
814 Perl_sv_catpvf Perl_sv_vcatpvf
815 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
816 Perl_dump_indent Perl_dump_vindent
817 Perl_default_protect Perl_vdefault_protect