3 require 5.003; # keep this compatible, an old perl is all we may have before
7 # See database of global and static function prototypes in embed.fnc
8 # This is used to generate prototype headers under various configurations,
9 # export symbols lists for different platforms, and macros to provide an
10 # implicit interpreter context argument.
20 Copyright (c) 1997-2002, Larry Wall
22 You may distribute under the terms of either the GNU General Public
23 License or the Artistic License, as specified in the README file.
25 !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
26 This file is built by embed.pl from data in embed.fnc, embed.pl,
27 pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
28 Any changes made here will be lost!
30 Edit those files and run 'make regen_headers' to effect changes.
34 if ($file =~ m:\.[ch]$:) {
35 $warning =~ s:^: * :gm;
36 $warning =~ s: +$::gm;
41 $warning =~ s:^:# :gm;
42 $warning =~ s: +$::gm;
47 open IN, "embed.fnc" or die $!;
49 # walk table providing an array of components in each line to
50 # subroutine, printing the result
53 my $filename = shift || '-';
55 defined $leader or $leader = do_not_edit ($filename);
59 if (ref $filename) { # filehandle
64 open F, ">$filename" or die "Can't open $filename: $!";
67 print $F $leader if $leader;
68 seek IN, 0, 0; # so we may restart
81 @args = split /\s*\|\s*/, $_;
83 my @outs = &{$function}(@args);
84 print $F @outs; # $function->(@args) is not 5.003
86 print $F $trailer if $trailer;
87 close $F unless ref $filename;
90 sub munge_c_files () {
93 warn "\@ARGV empty, nothing to do\n";
98 $functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
103 # if (/^#\s*include\s+"perl.h"/) {
104 # my $file = uc $ARGV;
106 # print "#define PERL_IN_$file\n";
112 # if (exists $functions->{$f}) {
113 # my $flags = $functions->{$f}[0];
114 # $repl = "Perl_$repl" if $flags =~ /p/;
115 # unless ($flags =~ /n/) {
117 # $repl .= "_ " if @{$functions->{$f}} > 3;
119 # warn("$ARGV:$.:$repl\n");
123 s{(\b(\w+)[ \t]*\([ \t]*(?!aTHX))}
127 if (exists $functions->{$f}) {
129 warn("$ARGV:$.:$`#$repl#$'");
134 close ARGV if eof; # restart $.
142 my $wrote_protected = 0;
151 my ($flags,$retval,$func,@args) = @_;
152 $ret .= '/* ' if $flags =~ /m/;
154 $retval = "STATIC $retval";
158 $retval = "PERL_CALLCONV $retval";
160 $func = "Perl_$func";
163 $ret .= "$retval\t$func(";
164 unless ($flags =~ /n/) {
166 $ret .= "_ " if @args;
169 $ret .= join ", ", @args;
172 $ret .= "void" if $flags =~ /n/;
175 $ret .= " __attribute__((noreturn))" if $flags =~ /r/;
176 if( $flags =~ /f/ ) {
177 my $prefix = $flags =~ /n/ ? '' : 'pTHX_';
178 my $args = scalar @args;
179 $ret .= "\n#ifdef CHECK_FORMAT\n";
180 $ret .= sprintf " __attribute__((format(printf,%s%d,%s%d)))",
181 $prefix, $args - 1, $prefix, $args;
182 $ret .= "\n#endif\n";
185 $ret .= ' */' if $flags =~ /m/;
191 # generates global.sym (API export list), and populates %global with global symbols
192 sub write_global_sym {
195 my ($flags,$retval,$func,@args) = @_;
196 if ($flags =~ /A/ && $flags !~ /[xm]/) { # public API, so export
197 $func = "Perl_$func" if $flags =~ /p/;
204 walk_table(\&write_protos, "proto.h", "");
205 walk_table(\&write_global_sym, "global.sym", "");
207 # XXX others that may need adding
211 my @extvars = qw(sv_undef sv_yes sv_no na dowarn
213 tainting tainted stack_base stack_sp sv_arenaroot
215 curstash DBsub DBsingle debstash
229 my ($syms, $file) = @_;
231 open(FILE, "< $file")
232 or die "embed.pl: Can't open $file: $!\n";
234 s/[ \t]*#.*//; # Delete comments.
235 if (/^\s*(\S+)\s*$/) {
237 warn "duplicate symbol $sym while processing $file\n"
238 if exists $$syms{$sym};
245 # Perl_pp_* and Perl_ck_* are in pp.sym
246 readsyms my %ppsym, 'pp.sym';
248 sub readvars(\%$$@) {
249 my ($syms, $file,$pre,$keep_pre) = @_;
251 open(FILE, "< $file")
252 or die "embed.pl: Can't open $file: $!\n";
254 s/[ \t]*#.*//; # Delete comments.
255 if (/PERLVARA?I?C?\($pre(\w+)/) {
257 $sym = $pre . $sym if $keep_pre;
258 warn "duplicate symbol $sym while processing $file\n"
259 if exists $$syms{$sym};
260 $$syms{$sym} = $pre || 1;
269 readvars %intrp, 'intrpvar.h','I';
270 readvars %thread, 'thrdvar.h','T';
271 readvars %globvar, 'perlvars.h','G';
274 foreach $sym (sort keys %thread) {
275 warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
284 my ($from, $to) = @_;
285 my $t = int(length($from) / 8);
286 "#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
289 sub bincompat_var ($$) {
290 my ($pfx, $sym) = @_;
291 my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
292 undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
296 my ($sym,$pre,$ptr) = @_;
297 hide("PL_$sym", "($ptr$pre$sym)");
302 return hide("PL_$pre$sym", "PL_$sym");
306 open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
308 print EM do_not_edit ("embed.h"), <<'END';
310 /* (Doing namespace management portably in C is really gross.) */
312 /* NO_EMBED is no longer supported. i.e. EMBED is always active. */
314 /* Hide global symbols */
316 #if !defined(PERL_IMPLICIT_CONTEXT)
324 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
327 my ($flags,$retval,$func,@args) = @_;
328 unless ($flags =~ /[om]/) {
330 $ret .= hide($func,"S_$func");
332 elsif ($flags =~ /p/) {
333 $ret .= hide($func,"Perl_$func");
340 for $sym (sort keys %ppsym) {
342 print EM hide($sym, "Perl_$sym");
347 #else /* PERL_IMPLICIT_CONTEXT */
357 $ret .= "$arg\n" if $arg =~ /^#\s*(if|ifn?def|else|endif)\b/;
360 my ($flags,$retval,$func,@args) = @_;
361 unless ($flags =~ /[om]/) {
362 my $args = scalar @args;
363 if ($args and $args[$args-1] =~ /\.\.\./) {
364 # we're out of luck for varargs functions under CPP
366 elsif ($flags =~ /n/) {
368 $ret .= hide($func,"S_$func");
370 elsif ($flags =~ /p/) {
371 $ret .= hide($func,"Perl_$func");
375 my $alist = join(",", @az[0..$args-1]);
376 $ret = "#define $func($alist)";
377 my $t = int(length($ret) / 8);
378 $ret .= "\t" x ($t < 4 ? 4 - $t : 1);
380 $ret .= "S_$func(aTHX";
382 elsif ($flags =~ /p/) {
383 $ret .= "Perl_$func(aTHX";
385 $ret .= "_ " if $alist;
386 $ret .= $alist . ")\n";
393 for $sym (sort keys %ppsym) {
395 if ($sym =~ /^ck_/) {
396 print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
398 elsif ($sym =~ /^pp_/) {
399 print EM hide("$sym()", "Perl_$sym(aTHX)");
402 warn "Illegal symbol '$sym' in pp.sym";
408 #endif /* PERL_IMPLICIT_CONTEXT */
414 /* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
418 #if !defined(PERL_CORE)
419 # define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
420 # define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
423 #if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
425 /* Compatibility for various misnamed functions. All functions
426 in the API that begin with "perl_" (not "Perl_") take an explicit
427 interpreter context pointer.
428 The following are not like that, but since they had a "perl_"
429 prefix in previous versions, we provide compatibility macros.
431 # define perl_atexit(a,b) call_atexit(a,b)
432 # define perl_call_argv(a,b,c) call_argv(a,b,c)
433 # define perl_call_pv(a,b) call_pv(a,b)
434 # define perl_call_method(a,b) call_method(a,b)
435 # define perl_call_sv(a,b) call_sv(a,b)
436 # define perl_eval_sv(a,b) eval_sv(a,b)
437 # define perl_eval_pv(a,b) eval_pv(a,b)
438 # define perl_require_pv(a) require_pv(a)
439 # define perl_get_sv(a,b) get_sv(a,b)
440 # define perl_get_av(a,b) get_av(a,b)
441 # define perl_get_hv(a,b) get_hv(a,b)
442 # define perl_get_cv(a,b) get_cv(a,b)
443 # define perl_init_i18nl10n(a) init_i18nl10n(a)
444 # define perl_init_i18nl14n(a) init_i18nl14n(a)
445 # define perl_new_ctype(a) new_ctype(a)
446 # define perl_new_collate(a) new_collate(a)
447 # define perl_new_numeric(a) new_numeric(a)
449 /* varargs functions can't be handled with CPP macros. :-(
450 This provides a set of compatibility functions that don't take
451 an extra argument but grab the context pointer using the macro
454 #if defined(PERL_IMPLICIT_CONTEXT)
455 # define croak Perl_croak_nocontext
456 # define deb Perl_deb_nocontext
457 # define die Perl_die_nocontext
458 # define form Perl_form_nocontext
459 # define load_module Perl_load_module_nocontext
460 # define mess Perl_mess_nocontext
461 # define newSVpvf Perl_newSVpvf_nocontext
462 # define sv_catpvf Perl_sv_catpvf_nocontext
463 # define sv_setpvf Perl_sv_setpvf_nocontext
464 # define warn Perl_warn_nocontext
465 # define warner Perl_warner_nocontext
466 # define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
467 # define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
470 #endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
472 #if !defined(PERL_IMPLICIT_CONTEXT)
473 /* undefined symbols, point them back at the usual ones */
474 # define Perl_croak_nocontext Perl_croak
475 # define Perl_die_nocontext Perl_die
476 # define Perl_deb_nocontext Perl_deb
477 # define Perl_form_nocontext Perl_form
478 # define Perl_load_module_nocontext Perl_load_module
479 # define Perl_mess_nocontext Perl_mess
480 # define Perl_newSVpvf_nocontext Perl_newSVpvf
481 # define Perl_sv_catpvf_nocontext Perl_sv_catpvf
482 # define Perl_sv_setpvf_nocontext Perl_sv_setpvf
483 # define Perl_warn_nocontext Perl_warn
484 # define Perl_warner_nocontext Perl_warner
485 # define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
486 # define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
494 open(EM, '> embedvar.h')
495 or die "Can't create embedvar.h: $!\n";
497 print EM do_not_edit ("embedvar.h"), <<'END';
499 /* (Doing namespace management portably in C is really gross.) */
502 The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
505 2) MULTIPLICITY # supported for compatibility
506 3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
508 All other combinations of these flags are errors.
510 only #3 is supported directly, while #2 is a special
511 case of #3 (supported by redefining vTHX appropriately).
514 #if defined(MULTIPLICITY)
515 /* cases 2 and 3 above */
517 # if defined(PERL_IMPLICIT_CONTEXT)
520 # define vTHX PERL_GET_INTERP
525 for $sym (sort keys %thread) {
526 print EM multon($sym,'T','vTHX->');
531 /* cases 2 and 3 above */
535 for $sym (sort keys %intrp) {
536 print EM multon($sym,'I','vTHX->');
541 #else /* !MULTIPLICITY */
547 for $sym (sort keys %intrp) {
548 print EM multoff($sym,'I');
555 for $sym (sort keys %thread) {
556 print EM multoff($sym,'T');
561 #endif /* MULTIPLICITY */
563 #if defined(PERL_GLOBAL_STRUCT)
567 for $sym (sort keys %globvar) {
568 print EM multon($sym,'G','PL_Vars.');
573 #else /* !PERL_GLOBAL_STRUCT */
577 for $sym (sort keys %globvar) {
578 print EM multoff($sym,'G');
583 #endif /* PERL_GLOBAL_STRUCT */
585 #ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
589 for $sym (sort @extvars) {
590 print EM hide($sym,"PL_$sym");
595 #endif /* PERL_POLLUTE */
602 open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
603 open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
605 print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
607 /* declare accessor functions for Perl variables */
608 #ifndef __perlapi_h__
609 #define __perlapi_h__
611 #if defined (MULTIPLICITY)
619 #define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
620 #define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
621 EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
622 #define PERLVARI(v,t,i) PERLVAR(v,t)
623 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
626 #include "intrpvar.h"
627 #include "perlvars.h"
636 #if defined(PERL_CORE)
638 /* accessor functions for Perl variables (provide binary compatibility) */
640 /* these need to be mentioned here, or most linkers won't put them in
641 the perl executable */
643 #ifndef PERL_NO_FORCE_LINK
648 EXT void *PL_force_link_funcs[];
650 EXT void *PL_force_link_funcs[] = {
655 #define PERLVAR(v,t) (void*)Perl_##v##_ptr,
656 #define PERLVARA(v,n,t) PERLVAR(v,t)
657 #define PERLVARI(v,t,i) PERLVAR(v,t)
658 #define PERLVARIC(v,t,i) PERLVAR(v,t)
661 #include "intrpvar.h"
662 #include "perlvars.h"
673 #endif /* PERL_NO_FORCE_LINK */
675 #else /* !PERL_CORE */
679 foreach $sym (sort keys %intrp) {
680 print CAPIH bincompat_var('I',$sym);
683 foreach $sym (sort keys %thread) {
684 print CAPIH bincompat_var('T',$sym);
687 foreach $sym (sort keys %globvar) {
688 print CAPIH bincompat_var('G',$sym);
693 #endif /* !PERL_CORE */
694 #endif /* MULTIPLICITY */
696 #endif /* __perlapi_h__ */
701 print CAPI do_not_edit ("perlapi.c"), <<'EOT';
707 #if defined (MULTIPLICITY)
709 /* accessor functions for Perl variables (provides binary compatibility) */
717 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
718 { return &(aTHX->v); }
719 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
720 { return &(aTHX->v); }
722 #define PERLVARI(v,t,i) PERLVAR(v,t)
723 #define PERLVARIC(v,t,i) PERLVAR(v, const t)
726 #include "intrpvar.h"
730 #define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
731 { return &(PL_##v); }
732 #define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
733 { return &(PL_##v); }
735 #define PERLVARIC(v,t,i) const t* Perl_##v##_ptr(pTHX) \
736 { return (const t *)&(PL_##v); }
737 #include "perlvars.h"
746 #endif /* MULTIPLICITY */
751 # functions that take va_list* for implementing vararg functions
752 # NOTE: makedef.pl must be updated if you add symbols to %vfuncs
753 # XXX %vfuncs currently unused
755 Perl_croak Perl_vcroak
757 Perl_warner Perl_vwarner
760 Perl_load_module Perl_vload_module
763 Perl_newSVpvf Perl_vnewSVpvf
764 Perl_sv_setpvf Perl_sv_vsetpvf
765 Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
766 Perl_sv_catpvf Perl_sv_vcatpvf
767 Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
768 Perl_dump_indent Perl_dump_vindent
769 Perl_default_protect Perl_vdefault_protect