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?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)
351 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
354 my ($flags,$retval,$func,@args) = @_;
355 unless ($flags =~ /[om]/) {
357 $ret .= hide($func,"S_$func");
359 elsif ($flags =~ /p/) {
360 $ret .= hide($func,"Perl_$func");
363 if ($ret ne '' && $flags !~ /A/) {
365 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
367 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
374 for $sym (sort keys %ppsym) {
376 print EM hide($sym, "Perl_$sym");
381 #else /* PERL_IMPLICIT_CONTEXT */
391 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
394 my ($flags,$retval,$func,@args) = @_;
395 unless ($flags =~ /[om]/) {
396 my $args = scalar @args;
397 if ($args and $args[$args-1] =~ /\.\.\./) {
398 # we're out of luck for varargs functions under CPP
400 elsif ($flags =~ /n/) {
402 $ret .= hide($func,"S_$func");
404 elsif ($flags =~ /p/) {
405 $ret .= hide($func,"Perl_$func");
409 my $alist = join(",", @az[0..$args-1]);
410 $ret = "#define $func($alist)";
411 my $t = int(length($ret) / 8);
412 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
414 $ret .= "S_$func(aTHX";
416 elsif ($flags =~ /p/) {
417 $ret .= "Perl_$func(aTHX";
419 $ret .= "_ " if $alist;
420 $ret .= $alist . ")\n";
423 unless ($flags =~ /A/) {
425 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
427 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
434 for $sym (sort keys %ppsym) {
436 if ($sym =~ /^ck_/) {
437 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
439 elsif ($sym =~ /^pp_/) {
440 print EM hide("$sym()", "Perl_$sym(aTHX)");
443 warn "Illegal symbol '$sym' in pp.sym";
449 #endif /* PERL_IMPLICIT_CONTEXT */
451 #endif /* #ifndef PERL_NO_SHORT_NAMES */
457 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
461 #if !defined(PERL_CORE)
462 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
463 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
466 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
468 /* Compatibility for various misnamed functions. All functions
469 in the API that begin with "perl_" (not "Perl_") take an explicit
470 interpreter context pointer.
471 The following are not like that, but since they had a "perl_"
472 prefix in previous versions, we provide compatibility macros.
474 # define perl_atexit(a,b) call_atexit(a,b)
475 # define perl_call_argv(a,b,c) call_argv(a,b,c)
476 # define perl_call_pv(a,b) call_pv(a,b)
477 # define perl_call_method(a,b) call_method(a,b)
478 # define perl_call_sv(a,b) call_sv(a,b)
479 # define perl_eval_sv(a,b) eval_sv(a,b)
480 # define perl_eval_pv(a,b) eval_pv(a,b)
481 # define perl_require_pv(a) require_pv(a)
482 # define perl_get_sv(a,b) get_sv(a,b)
483 # define perl_get_av(a,b) get_av(a,b)
484 # define perl_get_hv(a,b) get_hv(a,b)
485 # define perl_get_cv(a,b) get_cv(a,b)
486 # define perl_init_i18nl10n(a) init_i18nl10n(a)
487 # define perl_init_i18nl14n(a) init_i18nl14n(a)
488 # define perl_new_ctype(a) new_ctype(a)
489 # define perl_new_collate(a) new_collate(a)
490 # define perl_new_numeric(a) new_numeric(a)
492 /* varargs functions can't be handled with CPP macros. :-(
493 This provides a set of compatibility functions that don't take
494 an extra argument but grab the context pointer using the macro
497 #if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
498 # define croak Perl_croak_nocontext
499 # define deb Perl_deb_nocontext
500 # define die Perl_die_nocontext
501 # define form Perl_form_nocontext
502 # define load_module Perl_load_module_nocontext
503 # define mess Perl_mess_nocontext
504 # define newSVpvf Perl_newSVpvf_nocontext
505 # define sv_catpvf Perl_sv_catpvf_nocontext
506 # define sv_setpvf Perl_sv_setpvf_nocontext
507 # define warn Perl_warn_nocontext
508 # define warner Perl_warner_nocontext
509 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
510 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
513 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
515 #if !defined(PERL_IMPLICIT_CONTEXT)
516 /* undefined symbols, point them back at the usual ones */
517 # define Perl_croak_nocontext Perl_croak
518 # define Perl_die_nocontext Perl_die
519 # define Perl_deb_nocontext Perl_deb
520 # define Perl_form_nocontext Perl_form
521 # define Perl_load_module_nocontext Perl_load_module
522 # define Perl_mess_nocontext Perl_mess
523 # define Perl_newSVpvf_nocontext Perl_newSVpvf
524 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
525 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
526 # define Perl_warn_nocontext Perl_warn
527 # define Perl_warner_nocontext Perl_warner
528 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
529 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
534 close(EM) or die "Error closing EM: $!";
536 safer_unlink 'embedvar.h';
537 open(EM, '> embedvar.h')
538 or die "Can't create embedvar.h: $!\n";
541 print EM do_not_edit ("embedvar.h"), <<'END';
543 /* (Doing namespace management portably in C is really gross.) */
546 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
549 2) MULTIPLICITY # supported for compatibility
550 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
552 All other combinations of these flags are errors.
554 only #3 is supported directly, while #2 is a special
555 case of #3 (supported by redefining vTHX appropriately).
558 #if defined(MULTIPLICITY)
559 /* cases 2 and 3 above */
561 # if defined(PERL_IMPLICIT_CONTEXT)
564 # define vTHX PERL_GET_INTERP
569 for $sym (sort keys %thread) {
570 print EM multon($sym,'T','vTHX->');
575 /* cases 2 and 3 above */
579 for $sym (sort keys %intrp) {
580 print EM multon($sym,'I','vTHX->');
585 #else /* !MULTIPLICITY */
591 for $sym (sort keys %intrp) {
592 print EM multoff($sym,'I');
599 for $sym (sort keys %thread) {
600 print EM multoff($sym,'T');
605 #endif /* MULTIPLICITY */
607 #if defined(PERL_GLOBAL_STRUCT)
611 for $sym (sort keys %globvar) {
612 print EM multon($sym,'G','PL_Vars.');
617 #else /* !PERL_GLOBAL_STRUCT */
621 for $sym (sort keys %globvar) {
622 print EM multoff($sym,'G');
627 #endif /* PERL_GLOBAL_STRUCT */
629 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
633 for $sym (sort @extvars) {
634 print EM hide($sym,"PL_$sym");
639 #endif /* PERL_POLLUTE */
642 close(EM) or die "Error closing EM: $!";
644 safer_unlink 'perlapi.h';
645 safer_unlink 'perlapi.c';
646 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
648 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
651 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
653 /* declare accessor functions for Perl variables */
654 #ifndef __perlapi_h__
655 #define __perlapi_h__
657 #if defined (MULTIPLICITY)
665 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
666 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
667 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
668 #define PERLVARI(v,t,i) PERLVAR(v,t)
669 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
672 #include "intrpvar.h"
673 #include "perlvars.h"
682 #if defined(PERL_CORE)
684 /* accessor functions for Perl variables (provide binary compatibility) */
686 /* these need to be mentioned here, or most linkers won't put them in
687 the perl executable */
689 #ifndef PERL_NO_FORCE_LINK
694 EXT void *PL_force_link_funcs[];
696 EXT void *PL_force_link_funcs[] = {
701 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
702 #define PERLVARA(v,n,t) PERLVAR(v,t)
703 #define PERLVARI(v,t,i) PERLVAR(v,t)
704 #define PERLVARIC(v,t,i) PERLVAR(v,t)
707 #include "intrpvar.h"
708 #include "perlvars.h"
719 #endif /* PERL_NO_FORCE_LINK */
721 #else /* !PERL_CORE */
725 foreach $sym (sort keys %intrp) {
726 print CAPIH bincompat_var('I',$sym);
729 foreach $sym (sort keys %thread) {
730 print CAPIH bincompat_var('T',$sym);
733 foreach $sym (sort keys %globvar) {
734 print CAPIH bincompat_var('G',$sym);
739 #endif /* !PERL_CORE */
740 #endif /* MULTIPLICITY */
742 #endif /* __perlapi_h__ */
745 close CAPIH or die "Error closing CAPIH: $!";
747 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
753 #if defined (MULTIPLICITY)
755 /* accessor functions for Perl variables (provides binary compatibility) */
763 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
764 { return &(aTHX->v); }
765 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
766 { return &(aTHX->v); }
768 #define PERLVARI(v,t,i) PERLVAR(v,t)
769 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
772 #include "intrpvar.h"
776 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
777 { return &(PL_##v); }
778 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
779 { return &(PL_##v); }
781 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
782 { return (const t *)&(PL_##v); }
783 #include "perlvars.h"
792 #endif /* MULTIPLICITY */
795 close(CAPI) or die "Error closing CAPI: $!";
797 # functions that take va_list* for implementing vararg functions
798 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
799 # XXX %vfuncs currently unused
801 Perl_croak Perl_vcroak
803 Perl_warner Perl_vwarner
806 Perl_load_module Perl_vload_module
809 Perl_newSVpvf Perl_vnewSVpvf
810 Perl_sv_setpvf Perl_sv_vsetpvf
811 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
812 Perl_sv_catpvf Perl_sv_vcatpvf
813 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
814 Perl_dump_indent Perl_dump_vindent
815 Perl_default_protect Perl_vdefault_protect