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");
347 for $sym (sort keys %ppsym) {
349 print EM hide($sym, "Perl_$sym");
354 #else /* 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]/) {
369 my $args = scalar @args;
370 if ($args and $args[$args-1] =~ /\.\.\./) {
371 # we're out of luck for varargs functions under CPP
373 elsif ($flags =~ /n/) {
375 $ret .= hide($func,"S_$func");
377 elsif ($flags =~ /p/) {
378 $ret .= hide($func,"Perl_$func");
382 my $alist = join(",", @az[0..$args-1]);
383 $ret = "#define $func($alist)";
384 my $t = int(length($ret) / 8);
385 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
387 $ret .= "S_$func(aTHX";
389 elsif ($flags =~ /p/) {
390 $ret .= "Perl_$func(aTHX";
392 $ret .= "_ " if $alist;
393 $ret .= $alist . ")\n";
400 for $sym (sort keys %ppsym) {
402 if ($sym =~ /^ck_/) {
403 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
405 elsif ($sym =~ /^pp_/) {
406 print EM hide("$sym()", "Perl_$sym(aTHX)");
409 warn "Illegal symbol '$sym' in pp.sym";
415 #endif /* PERL_IMPLICIT_CONTEXT */
421 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
425 #if !defined(PERL_CORE)
426 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
427 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
430 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
432 /* Compatibility for various misnamed functions. All functions
433 in the API that begin with "perl_" (not "Perl_") take an explicit
434 interpreter context pointer.
435 The following are not like that, but since they had a "perl_"
436 prefix in previous versions, we provide compatibility macros.
438 # define perl_atexit(a,b) call_atexit(a,b)
439 # define perl_call_argv(a,b,c) call_argv(a,b,c)
440 # define perl_call_pv(a,b) call_pv(a,b)
441 # define perl_call_method(a,b) call_method(a,b)
442 # define perl_call_sv(a,b) call_sv(a,b)
443 # define perl_eval_sv(a,b) eval_sv(a,b)
444 # define perl_eval_pv(a,b) eval_pv(a,b)
445 # define perl_require_pv(a) require_pv(a)
446 # define perl_get_sv(a,b) get_sv(a,b)
447 # define perl_get_av(a,b) get_av(a,b)
448 # define perl_get_hv(a,b) get_hv(a,b)
449 # define perl_get_cv(a,b) get_cv(a,b)
450 # define perl_init_i18nl10n(a) init_i18nl10n(a)
451 # define perl_init_i18nl14n(a) init_i18nl14n(a)
452 # define perl_new_ctype(a) new_ctype(a)
453 # define perl_new_collate(a) new_collate(a)
454 # define perl_new_numeric(a) new_numeric(a)
456 /* varargs functions can't be handled with CPP macros. :-(
457 This provides a set of compatibility functions that don't take
458 an extra argument but grab the context pointer using the macro
461 #if defined(PERL_IMPLICIT_CONTEXT)
462 # define croak Perl_croak_nocontext
463 # define deb Perl_deb_nocontext
464 # define die Perl_die_nocontext
465 # define form Perl_form_nocontext
466 # define load_module Perl_load_module_nocontext
467 # define mess Perl_mess_nocontext
468 # define newSVpvf Perl_newSVpvf_nocontext
469 # define sv_catpvf Perl_sv_catpvf_nocontext
470 # define sv_setpvf Perl_sv_setpvf_nocontext
471 # define warn Perl_warn_nocontext
472 # define warner Perl_warner_nocontext
473 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
474 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
477 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
479 #if !defined(PERL_IMPLICIT_CONTEXT)
480 /* undefined symbols, point them back at the usual ones */
481 # define Perl_croak_nocontext Perl_croak
482 # define Perl_die_nocontext Perl_die
483 # define Perl_deb_nocontext Perl_deb
484 # define Perl_form_nocontext Perl_form
485 # define Perl_load_module_nocontext Perl_load_module
486 # define Perl_mess_nocontext Perl_mess
487 # define Perl_newSVpvf_nocontext Perl_newSVpvf
488 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
489 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
490 # define Perl_warn_nocontext Perl_warn
491 # define Perl_warner_nocontext Perl_warner
492 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
493 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
498 close(EM) or die "Error closing EM: $!";
500 safer_unlink 'embedvar.h';
501 open(EM, '> embedvar.h')
502 or die "Can't create embedvar.h: $!\n";
504 print EM do_not_edit ("embedvar.h"), <<'END';
506 /* (Doing namespace management portably in C is really gross.) */
509 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
512 2) MULTIPLICITY # supported for compatibility
513 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
515 All other combinations of these flags are errors.
517 only #3 is supported directly, while #2 is a special
518 case of #3 (supported by redefining vTHX appropriately).
521 #if defined(MULTIPLICITY)
522 /* cases 2 and 3 above */
524 # if defined(PERL_IMPLICIT_CONTEXT)
527 # define vTHX PERL_GET_INTERP
532 for $sym (sort keys %thread) {
533 print EM multon($sym,'T','vTHX->');
538 /* cases 2 and 3 above */
542 for $sym (sort keys %intrp) {
543 print EM multon($sym,'I','vTHX->');
548 #else /* !MULTIPLICITY */
554 for $sym (sort keys %intrp) {
555 print EM multoff($sym,'I');
562 for $sym (sort keys %thread) {
563 print EM multoff($sym,'T');
568 #endif /* MULTIPLICITY */
570 #if defined(PERL_GLOBAL_STRUCT)
574 for $sym (sort keys %globvar) {
575 print EM multon($sym,'G','PL_Vars.');
580 #else /* !PERL_GLOBAL_STRUCT */
584 for $sym (sort keys %globvar) {
585 print EM multoff($sym,'G');
590 #endif /* PERL_GLOBAL_STRUCT */
592 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
596 for $sym (sort @extvars) {
597 print EM hide($sym,"PL_$sym");
602 #endif /* PERL_POLLUTE */
605 close(EM) or die "Error closing EM: $!";
607 safer_unlink 'perlapi.h';
608 safer_unlink 'perlapi.c';
609 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
610 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
612 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
614 /* declare accessor functions for Perl variables */
615 #ifndef __perlapi_h__
616 #define __perlapi_h__
618 #if defined (MULTIPLICITY)
626 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
627 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
628 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
629 #define PERLVARI(v,t,i) PERLVAR(v,t)
630 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
633 #include "intrpvar.h"
634 #include "perlvars.h"
643 #if defined(PERL_CORE)
645 /* accessor functions for Perl variables (provide binary compatibility) */
647 /* these need to be mentioned here, or most linkers won't put them in
648 the perl executable */
650 #ifndef PERL_NO_FORCE_LINK
655 EXT void *PL_force_link_funcs[];
657 EXT void *PL_force_link_funcs[] = {
662 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
663 #define PERLVARA(v,n,t) PERLVAR(v,t)
664 #define PERLVARI(v,t,i) PERLVAR(v,t)
665 #define PERLVARIC(v,t,i) PERLVAR(v,t)
668 #include "intrpvar.h"
669 #include "perlvars.h"
680 #endif /* PERL_NO_FORCE_LINK */
682 #else /* !PERL_CORE */
686 foreach $sym (sort keys %intrp) {
687 print CAPIH bincompat_var('I',$sym);
690 foreach $sym (sort keys %thread) {
691 print CAPIH bincompat_var('T',$sym);
694 foreach $sym (sort keys %globvar) {
695 print CAPIH bincompat_var('G',$sym);
700 #endif /* !PERL_CORE */
701 #endif /* MULTIPLICITY */
703 #endif /* __perlapi_h__ */
706 close CAPIH or die "Error closing CAPIH: $!";
708 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
714 #if defined (MULTIPLICITY)
716 /* accessor functions for Perl variables (provides binary compatibility) */
724 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
725 { return &(aTHX->v); }
726 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
727 { return &(aTHX->v); }
729 #define PERLVARI(v,t,i) PERLVAR(v,t)
730 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
733 #include "intrpvar.h"
737 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
738 { return &(PL_##v); }
739 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
740 { return &(PL_##v); }
742 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
743 { return (const t *)&(PL_##v); }
744 #include "perlvars.h"
753 #endif /* MULTIPLICITY */
756 close(CAPI) or die "Error closing CAPI: $!";
758 # functions that take va_list* for implementing vararg functions
759 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
760 # XXX %vfuncs currently unused
762 Perl_croak Perl_vcroak
764 Perl_warner Perl_vwarner
767 Perl_load_module Perl_vload_module
770 Perl_newSVpvf Perl_vnewSVpvf
771 Perl_sv_setpvf Perl_sv_vsetpvf
772 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
773 Perl_sv_catpvf Perl_sv_vcatpvf
774 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
775 Perl_dump_indent Perl_dump_vindent
776 Perl_default_protect Perl_vdefault_protect