3 require 5.003; # keep this compatible, an old perl is all we may have before
7 # Get function prototypes
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.
25 Copyright (c) 1997-2002, Larry Wall
27 You may distribute under the terms of either the GNU General Public
28 License or the Artistic License, as specified in the README file.
30 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
31 This file is built by embed.pl from data in embed.fnc, embed.pl,
32 pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
33 Any changes made here will be lost!
35 Edit those files and run 'make regen_headers' to effect changes.
39 if ($file =~ m:\.[ch]$:) {
40 $warning =~ s:^: * :gm;
41 $warning =~ s: +$::gm;
46 $warning =~ s:^:# :gm;
47 $warning =~ s: +$::gm;
52 open IN, "embed.fnc" or die $!;
54 # walk table providing an array of components in each line to
55 # subroutine, printing the result
58 my $filename = shift || '-';
60 defined $leader or $leader = do_not_edit ($filename);
64 if (ref $filename) { # filehandle
68 safer_unlink $filename;
69 open F, ">$filename" or die "Can't open $filename: $!";
72 print $F $leader if $leader;
73 seek IN, 0, 0; # so we may restart
86 @args = split /\s*\|\s*/, $_;
88 my @outs = &{$function}(@args);
89 print $F @outs; # $function->(@args) is not 5.003
91 print $F $trailer if $trailer;
92 unless (ref $filename) {
93 close $F or die "Error closing $filename: $!";
97 sub munge_c_files () {
100 warn "\@ARGV empty, nothing to do\n";
105 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
110 # if (/^#\s*include\s+"perl.h"/) {
111 # my $file = uc $ARGV;
113 # print "#define PERL_IN_$file\n";
119 # if (exists $functions->{$f}) {
120 # my $flags = $functions->{$f}[0];
121 # $repl = "Perl_$repl" if $flags =~ /p/;
122 # unless ($flags =~ /n/) {
124 # $repl .= "_ " if @{$functions->{$f}} > 3;
126 # warn("$ARGV:$.:$repl\n");
130 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
134 if (exists $functions->{$f}) {
136 warn("$ARGV:$.:$`#$repl#$'");
141 close ARGV if eof; # restart $.
149 my $wrote_protected = 0;
158 my ($flags,$retval,$func,@args) = @_;
159 $ret .= '/* ' if $flags =~ /m/;
161 $retval = "STATIC $retval";
165 $retval = "PERL_CALLCONV $retval";
167 $func = "Perl_$func";
170 $ret .= "$retval\t$func(";
171 unless ($flags =~ /n/) {
173 $ret .= "_ " if @args;
176 $ret .= join ", ", @args;
179 $ret .= "void" if $flags =~ /n/;
182 $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
183 if( $flags =~ /f/ ) {
184 my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
185 my $args = scalar @args;
186 $ret .= "\n#ifdef CHECK_FORMAT\n";
187 $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
188 $prefix, $args - 1, $prefix, $args;
189 $ret .= "\n#endif\n";
192 $ret .= ' */' if $flags =~ /m/;
198 # generates global.sym (API export list), and populates %global with global symbols
199 sub write_global_sym {
202 my ($flags,$retval,$func,@args) = @_;
203 if ($flags =~ /A/ && $flags !~ /[xm]/) { # public API, so export
204 $func = "Perl_$func" if $flags =~ /p/;
211 walk_table(\&write_protos, "proto.h", undef);
212 walk_table(\&write_global_sym, "global.sym", undef);
214 # XXX others that may need adding
218 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
220 tainting tainted stack_base stack_sp sv_arenaroot
222 curstash DBsub DBsingle debstash
236 my ($syms, $file) = @_;
238 open(FILE, "< $file")
239 or die "embed.pl: Can't open $file: $!\n";
241 s/[ \t]*#.*//; # Delete comments.
242 if (/^\s*(\S+)\s*$/) {
244 warn "duplicate symbol $sym while processing $file\n"
245 if exists $$syms{$sym};
252 # Perl_pp_* and Perl_ck_* are in pp.sym
253 readsyms my %ppsym, 'pp.sym';
255 sub readvars(\%$$@) {
256 my ($syms, $file,$pre,$keep_pre) = @_;
258 open(FILE, "< $file")
259 or die "embed.pl: Can't open $file: $!\n";
261 s/[ \t]*#.*//; # Delete comments.
262 if (/PERLVARA?I?C?\($pre(\w+)/) {
264 $sym = $pre . $sym if $keep_pre;
265 warn "duplicate symbol $sym while processing $file\n"
266 if exists $$syms{$sym};
267 $$syms{$sym} = $pre || 1;
276 readvars %intrp, 'intrpvar.h','I';
277 readvars %thread, 'thrdvar.h','T';
278 readvars %globvar, 'perlvars.h','G';
281 foreach $sym (sort keys %thread) {
282 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
291 my ($from, $to) = @_;
292 my $t = int(length($from) / 8);
293 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
296 sub bincompat_var ($$) {
297 my ($pfx, $sym) = @_;
298 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
299 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
303 my ($sym,$pre,$ptr) = @_;
304 hide("PL_$sym", "($ptr$pre$sym)");
309 return hide("PL_$pre$sym", "PL_$sym");
312 safer_unlink 'embed.h';
313 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
315 print EM do_not_edit ("embed.h"), <<'END';
317 /* (Doing namespace management portably in C is really gross.) */
319 /* NO_EMBED is no longer supported. i.e. EMBED is always active. */
321 /* Hide global symbols */
323 #if !defined(PERL_IMPLICIT_CONTEXT)
331 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
334 my ($flags,$retval,$func,@args) = @_;
335 unless ($flags =~ /[om]/) {
337 $ret .= hide($func,"S_$func");
339 elsif ($flags =~ /p/) {
340 $ret .= hide($func,"Perl_$func");
343 unless ($flags =~ /A/) {
345 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
347 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
354 for $sym (sort keys %ppsym) {
356 print EM hide($sym, "Perl_$sym");
361 #else /* PERL_IMPLICIT_CONTEXT */
371 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
374 my ($flags,$retval,$func,@args) = @_;
375 unless ($flags =~ /[om]/) {
376 my $args = scalar @args;
377 if ($args and $args[$args-1] =~ /\.\.\./) {
378 # we're out of luck for varargs functions under CPP
380 elsif ($flags =~ /n/) {
382 $ret .= hide($func,"S_$func");
384 elsif ($flags =~ /p/) {
385 $ret .= hide($func,"Perl_$func");
389 my $alist = join(",", @az[0..$args-1]);
390 $ret = "#define $func($alist)";
391 my $t = int(length($ret) / 8);
392 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
394 $ret .= "S_$func(aTHX";
396 elsif ($flags =~ /p/) {
397 $ret .= "Perl_$func(aTHX";
399 $ret .= "_ " if $alist;
400 $ret .= $alist . ")\n";
403 unless ($flags =~ /A/) {
405 $ret = "#if defined(PERL_CORE) || defined(PERL_EXT)\n$ret#endif\n";
407 $ret = "#ifdef PERL_CORE\n$ret#endif\n";
414 for $sym (sort keys %ppsym) {
416 if ($sym =~ /^ck_/) {
417 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
419 elsif ($sym =~ /^pp_/) {
420 print EM hide("$sym()", "Perl_$sym(aTHX)");
423 warn "Illegal symbol '$sym' in pp.sym";
429 #endif /* PERL_IMPLICIT_CONTEXT */
435 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
439 #if !defined(PERL_CORE)
440 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
441 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
444 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
446 /* Compatibility for various misnamed functions. All functions
447 in the API that begin with "perl_" (not "Perl_") take an explicit
448 interpreter context pointer.
449 The following are not like that, but since they had a "perl_"
450 prefix in previous versions, we provide compatibility macros.
452 # define perl_atexit(a,b) call_atexit(a,b)
453 # define perl_call_argv(a,b,c) call_argv(a,b,c)
454 # define perl_call_pv(a,b) call_pv(a,b)
455 # define perl_call_method(a,b) call_method(a,b)
456 # define perl_call_sv(a,b) call_sv(a,b)
457 # define perl_eval_sv(a,b) eval_sv(a,b)
458 # define perl_eval_pv(a,b) eval_pv(a,b)
459 # define perl_require_pv(a) require_pv(a)
460 # define perl_get_sv(a,b) get_sv(a,b)
461 # define perl_get_av(a,b) get_av(a,b)
462 # define perl_get_hv(a,b) get_hv(a,b)
463 # define perl_get_cv(a,b) get_cv(a,b)
464 # define perl_init_i18nl10n(a) init_i18nl10n(a)
465 # define perl_init_i18nl14n(a) init_i18nl14n(a)
466 # define perl_new_ctype(a) new_ctype(a)
467 # define perl_new_collate(a) new_collate(a)
468 # define perl_new_numeric(a) new_numeric(a)
470 /* varargs functions can't be handled with CPP macros. :-(
471 This provides a set of compatibility functions that don't take
472 an extra argument but grab the context pointer using the macro
475 #if defined(PERL_IMPLICIT_CONTEXT)
476 # define croak Perl_croak_nocontext
477 # define deb Perl_deb_nocontext
478 # define die Perl_die_nocontext
479 # define form Perl_form_nocontext
480 # define load_module Perl_load_module_nocontext
481 # define mess Perl_mess_nocontext
482 # define newSVpvf Perl_newSVpvf_nocontext
483 # define sv_catpvf Perl_sv_catpvf_nocontext
484 # define sv_setpvf Perl_sv_setpvf_nocontext
485 # define warn Perl_warn_nocontext
486 # define warner Perl_warner_nocontext
487 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
488 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
491 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
493 #if !defined(PERL_IMPLICIT_CONTEXT)
494 /* undefined symbols, point them back at the usual ones */
495 # define Perl_croak_nocontext Perl_croak
496 # define Perl_die_nocontext Perl_die
497 # define Perl_deb_nocontext Perl_deb
498 # define Perl_form_nocontext Perl_form
499 # define Perl_load_module_nocontext Perl_load_module
500 # define Perl_mess_nocontext Perl_mess
501 # define Perl_newSVpvf_nocontext Perl_newSVpvf
502 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
503 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
504 # define Perl_warn_nocontext Perl_warn
505 # define Perl_warner_nocontext Perl_warner
506 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
507 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
512 close(EM) or die "Error closing EM: $!";
514 safer_unlink 'embedvar.h';
515 open(EM, '> embedvar.h')
516 or die "Can't create embedvar.h: $!\n";
518 print EM do_not_edit ("embedvar.h"), <<'END';
520 /* (Doing namespace management portably in C is really gross.) */
523 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
526 2) MULTIPLICITY # supported for compatibility
527 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
529 All other combinations of these flags are errors.
531 only #3 is supported directly, while #2 is a special
532 case of #3 (supported by redefining vTHX appropriately).
535 #if defined(MULTIPLICITY)
536 /* cases 2 and 3 above */
538 # if defined(PERL_IMPLICIT_CONTEXT)
541 # define vTHX PERL_GET_INTERP
546 for $sym (sort keys %thread) {
547 print EM multon($sym,'T','vTHX->');
552 /* cases 2 and 3 above */
556 for $sym (sort keys %intrp) {
557 print EM multon($sym,'I','vTHX->');
562 #else /* !MULTIPLICITY */
568 for $sym (sort keys %intrp) {
569 print EM multoff($sym,'I');
576 for $sym (sort keys %thread) {
577 print EM multoff($sym,'T');
582 #endif /* MULTIPLICITY */
584 #if defined(PERL_GLOBAL_STRUCT)
588 for $sym (sort keys %globvar) {
589 print EM multon($sym,'G','PL_Vars.');
594 #else /* !PERL_GLOBAL_STRUCT */
598 for $sym (sort keys %globvar) {
599 print EM multoff($sym,'G');
604 #endif /* PERL_GLOBAL_STRUCT */
606 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
610 for $sym (sort @extvars) {
611 print EM hide($sym,"PL_$sym");
616 #endif /* PERL_POLLUTE */
619 close(EM) or die "Error closing EM: $!";
621 safer_unlink 'perlapi.h';
622 safer_unlink 'perlapi.c';
623 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
624 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
626 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
628 /* declare accessor functions for Perl variables */
629 #ifndef __perlapi_h__
630 #define __perlapi_h__
632 #if defined (MULTIPLICITY)
640 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
641 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
642 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
643 #define PERLVARI(v,t,i) PERLVAR(v,t)
644 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
647 #include "intrpvar.h"
648 #include "perlvars.h"
657 #if defined(PERL_CORE)
659 /* accessor functions for Perl variables (provide binary compatibility) */
661 /* these need to be mentioned here, or most linkers won't put them in
662 the perl executable */
664 #ifndef PERL_NO_FORCE_LINK
669 EXT void *PL_force_link_funcs[];
671 EXT void *PL_force_link_funcs[] = {
676 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
677 #define PERLVARA(v,n,t) PERLVAR(v,t)
678 #define PERLVARI(v,t,i) PERLVAR(v,t)
679 #define PERLVARIC(v,t,i) PERLVAR(v,t)
682 #include "intrpvar.h"
683 #include "perlvars.h"
694 #endif /* PERL_NO_FORCE_LINK */
696 #else /* !PERL_CORE */
700 foreach $sym (sort keys %intrp) {
701 print CAPIH bincompat_var('I',$sym);
704 foreach $sym (sort keys %thread) {
705 print CAPIH bincompat_var('T',$sym);
708 foreach $sym (sort keys %globvar) {
709 print CAPIH bincompat_var('G',$sym);
714 #endif /* !PERL_CORE */
715 #endif /* MULTIPLICITY */
717 #endif /* __perlapi_h__ */
720 close CAPIH or die "Error closing CAPIH: $!";
722 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
728 #if defined (MULTIPLICITY)
730 /* accessor functions for Perl variables (provides binary compatibility) */
738 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
739 { return &(aTHX->v); }
740 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
741 { return &(aTHX->v); }
743 #define PERLVARI(v,t,i) PERLVAR(v,t)
744 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
747 #include "intrpvar.h"
751 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
752 { return &(PL_##v); }
753 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
754 { return &(PL_##v); }
756 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
757 { return (const t *)&(PL_##v); }
758 #include "perlvars.h"
767 #endif /* MULTIPLICITY */
770 close(CAPI) or die "Error closing CAPI: $!";
772 # functions that take va_list* for implementing vararg functions
773 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
774 # XXX %vfuncs currently unused
776 Perl_croak Perl_vcroak
778 Perl_warner Perl_vwarner
781 Perl_load_module Perl_vload_module
784 Perl_newSVpvf Perl_vnewSVpvf
785 Perl_sv_setpvf Perl_sv_vsetpvf
786 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
787 Perl_sv_catpvf Perl_sv_vcatpvf
788 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
789 Perl_dump_indent Perl_dump_vindent
790 Perl_default_protect Perl_vdefault_protect