perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

Commit	Line	Data
	1	#!/usr/bin/perl -w
	2
	3	require 5.003; # keep this compatible, an old perl is all we may have before
	4	# we build the new one
	5
	6	BEGIN {
	7	# Get function prototypes
	8	require 'regen_lib.pl';
	9	}
	10
	11	#
	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.
	16	#
	17
	18	sub do_not_edit ($)
	19	{
	20	my $file = shift;
	21
	22	my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005';
	23
	24	$years =~ s/1999,/1999,\n / if length $years > 40;
	25
	26	my $warning = <<EOW;
	27	-- buffer-read-only: t --
	28
	29	$file
	30
	31	Copyright (C) $years, by Larry Wall and others
	32
	33	You may distribute under the terms of either the GNU General Public
	34	License or the Artistic License, as specified in the README file.
	35
	36	!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
	37	This file is built by embed.pl from data in embed.fnc, embed.pl,
	38	pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
	39	Any changes made here will be lost!
	40
	41	Edit those files and run 'make regen_headers' to effect changes.
	42
	43	EOW
	44
	45	$warning .= <<EOW if $file eq 'perlapi.c';
	46
	47	Up to the threshold of the door there mounted a flight of twenty-seven
	48	broad stairs, hewn by some unknown art of the same black stone. This
	49	was the only entrance to the tower.
	50
	51
	52	EOW
	53
	54	if ($file =~ m:\.[ch]$:) {
	55	$warning =~ s:^: * :gm;
	56	$warning =~ s: +$::gm;
	57	$warning =~ s: :/:;
	58	$warning =~ s:$:/:;
	59	}
	60	else {
	61	$warning =~ s:^:# :gm;
	62	$warning =~ s: +$::gm;
	63	}
	64	$warning;
	65	} # do_not_edit
	66
	67	open IN, "embed.fnc" or die $!;
	68
	69	# walk table providing an array of components in each line to
	70	# subroutine, printing the result
	71	sub walk_table (&@) {
	72	my $function = shift;
	73	my $filename = shift \|\| '-';
	74	my $leader = shift;
	75	defined $leader or $leader = do_not_edit ($filename);
	76	my $trailer = shift;
	77	my $F;
	78	local *F;
	79	if (ref $filename) { # filehandle
	80	$F = $filename;
	81	}
	82	else {
	83	safer_unlink $filename if $filename ne '/dev/null';
	84	open F, ">$filename" or die "Can't open $filename: $!";
	85	binmode F;
	86	$F = \*F;
	87	}
	88	print $F $leader if $leader;
	89	seek IN, 0, 0; # so we may restart
	90	while (<IN>) {
	91	chomp;
	92	next if /^:/;
	93	while (s\|\\$\|\|) {
	94	$_ .= <IN>;
	95	chomp;
	96	}
	97	s/\s+$//;
	98	my @args;
	99	if (/^\s*(#\|$)/) {
	100	@args = $_;
	101	}
	102	else {
	103	@args = split /\s\\|\s/, $_;
	104	}
	105	my @outs = &{$function}(@args);
	106	print $F @outs; # $function->(@args) is not 5.003
	107	}
	108	print $F $trailer if $trailer;
	109	unless (ref $filename) {
	110	close $F or die "Error closing $filename: $!";
	111	}
	112	}
	113
	114	sub munge_c_files () {
	115	my $functions = {};
	116	unless (@ARGV) {
	117	warn "\@ARGV empty, nothing to do\n";
	118	return;
	119	}
	120	walk_table {
	121	if (@_ > 1) {
	122	$functions->{$_[2]} = \@_ if $_[@_-1] =~ /\.\.\./;
	123	}
	124	} '/dev/null', '', '';
	125	local $^I = '.bak';
	126	while (<>) {
	127	# if (/^#\s*include\s+"perl.h"/) {
	128	# my $file = uc $ARGV;
	129	# $file =~ s/\./_/g;
	130	# print "#define PERL_IN_$file\n";
	131	# }
	132	# s{^(\w+)\s*\(}
	133	# {
	134	# my $f = $1;
	135	# my $repl = "$f(";
	136	# if (exists $functions->{$f}) {
	137	# my $flags = $functions->{$f}[0];
	138	# $repl = "Perl_$repl" if $flags =~ /p/;
	139	# unless ($flags =~ /n/) {
	140	# $repl .= "pTHX";
	141	# $repl .= "_ " if @{$functions->{$f}} > 3;
	142	# }
	143	# warn("$ARGV:$.:$repl\n");
	144	# }
	145	# $repl;
	146	# }e;
	147	s{(\b(\w+)[ \t]\([ \t](?!aTHX))}
	148	{
	149	my $repl = $1;
	150	my $f = $2;
	151	if (exists $functions->{$f}) {
	152	$repl .= "aTHX_ ";
	153	warn("$ARGV:$.:$`#$repl#$'");
	154	}
	155	$repl;
	156	}eg;
	157	print;
	158	close ARGV if eof; # restart $.
	159	}
	160	exit;
	161	}
	162
	163	#munge_c_files();
	164
	165	# generate proto.h
	166	my $wrote_protected = 0;
	167
	168	sub write_protos {
	169	my $ret = "";
	170	if (@_ == 1) {
	171	my $arg = shift;
	172	$ret .= "$arg\n";
	173	}
	174	else {
	175	my ($flags,$retval,$func,@args) = @_;
	176	my @nonnull;
	177	my $has_context = ( $flags !~ /n/ );
	178	$ret .= '/* ' if $flags =~ /m/;
	179	if ($flags =~ /s/) {
	180	$retval = "STATIC $retval";
	181	$func = "S_$func";
	182	}
	183	else {
	184	$retval = "PERL_CALLCONV $retval";
	185	if ($flags =~ /p/) {
	186	$func = "Perl_$func";
	187	}
	188	}
	189	$ret .= "$retval\t$func(";
	190	if ( $has_context ) {
	191	$ret .= @args ? "pTHX_ " : "pTHX";
	192	}
	193	if (@args) {
	194	my $n;
	195	for my $arg ( @args ) {
	196	++$n;
	197	push( @nonnull, $n ) if ( $arg =~ s/\s*\bNN\b\s+// );
	198	}
	199	$ret .= join ", ", @args;
	200	}
	201	else {
	202	$ret .= "void" if !$has_context;
	203	}
	204	$ret .= ")";
	205	my @attrs;
	206	if ( $flags =~ /r/ ) {
	207	push @attrs, "__attribute__noreturn__";
	208	}
	209	if ( $flags =~ /a/ ) {
	210	push @attrs, "__attribute__malloc__";
	211	$flags .= "R"; # All allocing must check return value
	212	}
	213	if ( $flags =~ /R/ ) {
	214	push @attrs, "__attribute__warn_unused_result__";
	215	}
	216	if ( $flags =~ /P/ ) {
	217	push @attrs, "__attribute__pure__";
	218	}
	219	if( $flags =~ /f/ ) {
	220	my $prefix = $has_context ? 'pTHX_' : '';
	221	my $args = scalar @args;
	222	push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
	223	$prefix, $args - 1, $prefix, $args;
	224	}
	225	if ( @nonnull ) {
	226	my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
	227	push @attrs, map { sprintf( "__attribute__nonnull__(%s)", $_ ) } @pos;
	228	}
	229	if ( @attrs ) {
	230	$ret .= "\n";
	231	$ret .= join( "\n", map { "\t\t\t$_" } @attrs );
	232	}
	233	$ret .= ";";
	234	$ret .= ' */' if $flags =~ /m/;
	235	$ret .= @attrs ? "\n\n" : "\n";
	236	}
	237	$ret;
	238	}
	239
	240	# generates global.sym (API export list), and populates %global with global symbols
	241	sub write_global_sym {
	242	my $ret = "";
	243	if (@_ > 1) {
	244	my ($flags,$retval,$func,@args) = @_;
	245	if ($flags =~ /[AX]/ && $flags !~ /[xm]/
	246	\|\| $flags =~ /b/) { # public API, so export
	247	$func = "Perl_$func" if $flags =~ /[pbX]/;
	248	$ret = "$func\n";
	249	}
	250	}
	251	$ret;
	252	}
	253
	254	walk_table(\&write_protos, "proto.h", undef, "/* ex: set ro: */\n");
	255	walk_table(\&write_global_sym, "global.sym", undef, "# ex: set ro:\n");
	256
	257	# XXX others that may need adding
	258	# warnhook
	259	# hints
	260	# copline
	261	my @extvars = qw(sv_undef sv_yes sv_no na dowarn
	262	curcop compiling
	263	tainting tainted stack_base stack_sp sv_arenaroot
	264	no_modify
	265	curstash DBsub DBsingle DBassertion debstash
	266	rsfp
	267	stdingv
	268	defgv
	269	errgv
	270	rsfp_filters
	271	perldb
	272	diehook
	273	dirty
	274	perl_destruct_level
	275	ppaddr
	276	);
	277
	278	sub readsyms (\%$) {
	279	my ($syms, $file) = @_;
	280	local (*FILE, $_);
	281	open(FILE, "< $file")
	282	or die "embed.pl: Can't open $file: $!\n";
	283	while (<FILE>) {
	284	s/[ \t]#.//; # Delete comments.
	285	if (/^\s(\S+)\s$/) {
	286	my $sym = $1;
	287	warn "duplicate symbol $sym while processing $file\n"
	288	if exists $$syms{$sym};
	289	$$syms{$sym} = 1;
	290	}
	291	}
	292	close(FILE);
	293	}
	294
	295	# Perl_pp_* and Perl_ck_* are in pp.sym
	296	readsyms my %ppsym, 'pp.sym';
	297
	298	sub readvars(\%$$@) {
	299	my ($syms, $file,$pre,$keep_pre) = @_;
	300	local (*FILE, $_);
	301	open(FILE, "< $file")
	302	or die "embed.pl: Can't open $file: $!\n";
	303	while (<FILE>) {
	304	s/[ \t]#.//; # Delete comments.
	305	if (/PERLVARA?I?S?C?\($pre(\w+)/) {
	306	my $sym = $1;
	307	$sym = $pre . $sym if $keep_pre;
	308	warn "duplicate symbol $sym while processing $file\n"
	309	if exists $$syms{$sym};
	310	$$syms{$sym} = $pre \|\| 1;
	311	}
	312	}
	313	close(FILE);
	314	}
	315
	316	my %intrp;
	317	my %thread;
	318
	319	readvars %intrp, 'intrpvar.h','I';
	320	readvars %thread, 'thrdvar.h','T';
	321	readvars %globvar, 'perlvars.h','G';
	322
	323	my $sym;
	324	foreach $sym (sort keys %thread) {
	325	warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
	326	}
	327
	328	sub undefine ($) {
	329	my ($sym) = @_;
	330	"#undef $sym\n";
	331	}
	332
	333	sub hide ($$) {
	334	my ($from, $to) = @_;
	335	my $t = int(length($from) / 8);
	336	"#define $from" . "\t" x ($t < 3 ? 3 - $t : 1) . "$to\n";
	337	}
	338
	339	sub bincompat_var ($$) {
	340	my ($pfx, $sym) = @_;
	341	my $arg = ($pfx eq 'G' ? 'NULL' : 'aTHX');
	342	undefine("PL_$sym") . hide("PL_$sym", "(*Perl_${pfx}${sym}_ptr($arg))");
	343	}
	344
	345	sub multon ($$$) {
	346	my ($sym,$pre,$ptr) = @_;
	347	hide("PL_$sym", "($ptr$pre$sym)");
	348	}
	349
	350	sub multoff ($$) {
	351	my ($sym,$pre) = @_;
	352	return hide("PL_$pre$sym", "PL_$sym");
	353	}
	354
	355	safer_unlink 'embed.h';
	356	open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
	357	binmode EM;
	358
	359	print EM do_not_edit ("embed.h"), <<'END';
	360
	361	/* (Doing namespace management portably in C is really gross.) */
	362
	363	/* By defining PERL_NO_SHORT_NAMES (not done by default) the short forms
	364	* (like warn instead of Perl_warn) for the API are not defined.
	365	* Not defining the short forms is a good thing for cleaner embedding. */
	366
	367	#ifndef PERL_NO_SHORT_NAMES
	368
	369	/* Hide global symbols */
	370
	371	#if !defined(PERL_IMPLICIT_CONTEXT)
	372
	373	END
	374
	375	# Try to elimiate lots of repeated
	376	# #ifdef PERL_CORE
	377	# foo
	378	# #endif
	379	# #ifdef PERL_CORE
	380	# bar
	381	# #endif
	382	# by tracking state and merging foo and bar into one block.
	383	my $ifdef_state = '';
	384
	385	walk_table {
	386	my $ret = "";
	387	my $new_ifdef_state = '';
	388	if (@_ == 1) {
	389	my $arg = shift;
	390	$ret .= "$arg\n" if $arg =~ /^#\s*(if\|ifn?def\|else\|endif)\b/;
	391	}
	392	else {
	393	my ($flags,$retval,$func,@args) = @_;
	394	unless ($flags =~ /[om]/) {
	395	if ($flags =~ /s/) {
	396	$ret .= hide($func,"S_$func");
	397	}
	398	elsif ($flags =~ /p/) {
	399	$ret .= hide($func,"Perl_$func");
	400	}
	401	}
	402	if ($ret ne '' && $flags !~ /A/) {
	403	if ($flags =~ /E/) {
	404	$new_ifdef_state
	405	= "#if defined(PERL_CORE) \|\| defined(PERL_EXT)\n";
	406	}
	407	else {
	408	$new_ifdef_state = "#ifdef PERL_CORE\n";
	409	}
	410
	411	if ($new_ifdef_state ne $ifdef_state) {
	412	$ret = $new_ifdef_state . $ret;
	413	}
	414	}
	415	}
	416	if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
	417	# Close the old one ahead of opening the new one.
	418	$ret = "#endif\n$ret";
	419	}
	420	# Remember the new state.
	421	$ifdef_state = $new_ifdef_state;
	422	$ret;
	423	} \*EM, "";
	424
	425	if ($ifdef_state) {
	426	print EM "#endif\n";
	427	}
	428
	429	for $sym (sort keys %ppsym) {
	430	$sym =~ s/^Perl_//;
	431	print EM hide($sym, "Perl_$sym");
	432	}
	433
	434	print EM <<'END';
	435
	436	#else /* PERL_IMPLICIT_CONTEXT */
	437
	438	END
	439
	440	my @az = ('a'..'z');
	441
	442	$ifdef_state = '';
	443	walk_table {
	444	my $ret = "";
	445	my $new_ifdef_state = '';
	446	if (@_ == 1) {
	447	my $arg = shift;
	448	$ret .= "$arg\n" if $arg =~ /^#\s*(if\|ifn?def\|else\|endif)\b/;
	449	}
	450	else {
	451	my ($flags,$retval,$func,@args) = @_;
	452	unless ($flags =~ /[om]/) {
	453	my $args = scalar @args;
	454	if ($args and $args[$args-1] =~ /\.\.\./) {
	455	# we're out of luck for varargs functions under CPP
	456	}
	457	elsif ($flags =~ /n/) {
	458	if ($flags =~ /s/) {
	459	$ret .= hide($func,"S_$func");
	460	}
	461	elsif ($flags =~ /p/) {
	462	$ret .= hide($func,"Perl_$func");
	463	}
	464	}
	465	else {
	466	my $alist = join(",", @az[0..$args-1]);
	467	$ret = "#define $func($alist)";
	468	my $t = int(length($ret) / 8);
	469	$ret .= "\t" x ($t < 4 ? 4 - $t : 1);
	470	if ($flags =~ /s/) {
	471	$ret .= "S_$func(aTHX";
	472	}
	473	elsif ($flags =~ /p/) {
	474	$ret .= "Perl_$func(aTHX";
	475	}
	476	$ret .= "_ " if $alist;
	477	$ret .= $alist . ")\n";
	478	}
	479	}
	480	unless ($flags =~ /A/) {
	481	if ($flags =~ /E/) {
	482	$new_ifdef_state
	483	= "#if defined(PERL_CORE) \|\| defined(PERL_EXT)\n";
	484	}
	485	else {
	486	$new_ifdef_state = "#ifdef PERL_CORE\n";
	487	}
	488
	489	if ($new_ifdef_state ne $ifdef_state) {
	490	$ret = $new_ifdef_state . $ret;
	491	}
	492	}
	493	}
	494	if ($ifdef_state && $new_ifdef_state ne $ifdef_state) {
	495	# Close the old one ahead of opening the new one.
	496	$ret = "#endif\n$ret";
	497	}
	498	# Remember the new state.
	499	$ifdef_state = $new_ifdef_state;
	500	$ret;
	501	} \*EM, "";
	502
	503	if ($ifdef_state) {
	504	print EM "#endif\n";
	505	}
	506
	507	for $sym (sort keys %ppsym) {
	508	$sym =~ s/^Perl_//;
	509	if ($sym =~ /^ck_/) {
	510	print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
	511	}
	512	elsif ($sym =~ /^pp_/) {
	513	print EM hide("$sym()", "Perl_$sym(aTHX)");
	514	}
	515	else {
	516	warn "Illegal symbol '$sym' in pp.sym";
	517	}
	518	}
	519
	520	print EM <<'END';
	521
	522	#endif /* PERL_IMPLICIT_CONTEXT */
	523
	524	#endif /* #ifndef PERL_NO_SHORT_NAMES */
	525
	526	END
	527
	528	print EM <<'END';
	529
	530	/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
	531	disable them.
	532	*/
	533
	534	#if !defined(PERL_CORE)
	535	# define sv_setptrobj(rv,ptr,name) sv_setref_iv(rv,name,PTR2IV(ptr))
	536	# define sv_setptrref(rv,ptr) sv_setref_iv(rv,Nullch,PTR2IV(ptr))
	537	#endif
	538
	539	#if !defined(PERL_CORE) && !defined(PERL_NOCOMPAT)
	540
	541	/* Compatibility for various misnamed functions. All functions
	542	in the API that begin with "perl_" (not "Perl_") take an explicit
	543	interpreter context pointer.
	544	The following are not like that, but since they had a "perl_"
	545	prefix in previous versions, we provide compatibility macros.
	546	*/
	547	# define perl_atexit(a,b) call_atexit(a,b)
	548	# define perl_call_argv(a,b,c) call_argv(a,b,c)
	549	# define perl_call_pv(a,b) call_pv(a,b)
	550	# define perl_call_method(a,b) call_method(a,b)
	551	# define perl_call_sv(a,b) call_sv(a,b)
	552	# define perl_eval_sv(a,b) eval_sv(a,b)
	553	# define perl_eval_pv(a,b) eval_pv(a,b)
	554	# define perl_require_pv(a) require_pv(a)
	555	# define perl_get_sv(a,b) get_sv(a,b)
	556	# define perl_get_av(a,b) get_av(a,b)
	557	# define perl_get_hv(a,b) get_hv(a,b)
	558	# define perl_get_cv(a,b) get_cv(a,b)
	559	# define perl_init_i18nl10n(a) init_i18nl10n(a)
	560	# define perl_init_i18nl14n(a) init_i18nl14n(a)
	561	# define perl_new_ctype(a) new_ctype(a)
	562	# define perl_new_collate(a) new_collate(a)
	563	# define perl_new_numeric(a) new_numeric(a)
	564
	565	/* varargs functions can't be handled with CPP macros. :-(
	566	This provides a set of compatibility functions that don't take
	567	an extra argument but grab the context pointer using the macro
	568	dTHX.
	569	*/
	570	#if defined(PERL_IMPLICIT_CONTEXT) && !defined(PERL_NO_SHORT_NAMES)
	571	# define croak Perl_croak_nocontext
	572	# define deb Perl_deb_nocontext
	573	# define die Perl_die_nocontext
	574	# define form Perl_form_nocontext
	575	# define load_module Perl_load_module_nocontext
	576	# define mess Perl_mess_nocontext
	577	# define newSVpvf Perl_newSVpvf_nocontext
	578	# define sv_catpvf Perl_sv_catpvf_nocontext
	579	# define sv_setpvf Perl_sv_setpvf_nocontext
	580	# define warn Perl_warn_nocontext
	581	# define warner Perl_warner_nocontext
	582	# define sv_catpvf_mg Perl_sv_catpvf_mg_nocontext
	583	# define sv_setpvf_mg Perl_sv_setpvf_mg_nocontext
	584	#endif
	585
	586	#endif /* !defined(PERL_CORE) && !defined(PERL_NOCOMPAT) */
	587
	588	#if !defined(PERL_IMPLICIT_CONTEXT)
	589	/* undefined symbols, point them back at the usual ones */
	590	# define Perl_croak_nocontext Perl_croak
	591	# define Perl_die_nocontext Perl_die
	592	# define Perl_deb_nocontext Perl_deb
	593	# define Perl_form_nocontext Perl_form
	594	# define Perl_load_module_nocontext Perl_load_module
	595	# define Perl_mess_nocontext Perl_mess
	596	# define Perl_newSVpvf_nocontext Perl_newSVpvf
	597	# define Perl_sv_catpvf_nocontext Perl_sv_catpvf
	598	# define Perl_sv_setpvf_nocontext Perl_sv_setpvf
	599	# define Perl_warn_nocontext Perl_warn
	600	# define Perl_warner_nocontext Perl_warner
	601	# define Perl_sv_catpvf_mg_nocontext Perl_sv_catpvf_mg
	602	# define Perl_sv_setpvf_mg_nocontext Perl_sv_setpvf_mg
	603	#endif
	604
	605	/* ex: set ro: */
	606	END
	607
	608	close(EM) or die "Error closing EM: $!";
	609
	610	safer_unlink 'embedvar.h';
	611	open(EM, '> embedvar.h')
	612	or die "Can't create embedvar.h: $!\n";
	613	binmode EM;
	614
	615	print EM do_not_edit ("embedvar.h"), <<'END';
	616
	617	/* (Doing namespace management portably in C is really gross.) */
	618
	619	/*
	620	The following combinations of MULTIPLICITY and PERL_IMPLICIT_CONTEXT
	621	are supported:
	622	1) none
	623	2) MULTIPLICITY # supported for compatibility
	624	3) MULTIPLICITY && PERL_IMPLICIT_CONTEXT
	625
	626	All other combinations of these flags are errors.
	627
	628	only #3 is supported directly, while #2 is a special
	629	case of #3 (supported by redefining vTHX appropriately).
	630	*/
	631
	632	#if defined(MULTIPLICITY)
	633	/* cases 2 and 3 above */
	634
	635	# if defined(PERL_IMPLICIT_CONTEXT)
	636	# define vTHX aTHX
	637	# else
	638	# define vTHX PERL_GET_INTERP
	639	# endif
	640
	641	END
	642
	643	for $sym (sort keys %thread) {
	644	print EM multon($sym,'T','vTHX->');
	645	}
	646
	647	print EM <<'END';
	648
	649	/* cases 2 and 3 above */
	650
	651	END
	652
	653	for $sym (sort keys %intrp) {
	654	print EM multon($sym,'I','vTHX->');
	655	}
	656
	657	print EM <<'END';
	658
	659	#else /* !MULTIPLICITY */
	660
	661	/* case 1 above */
	662
	663	END
	664
	665	for $sym (sort keys %intrp) {
	666	print EM multoff($sym,'I');
	667	}
	668
	669	print EM <<'END';
	670
	671	END
	672
	673	for $sym (sort keys %thread) {
	674	print EM multoff($sym,'T');
	675	}
	676
	677	print EM <<'END';
	678
	679	#endif /* MULTIPLICITY */
	680
	681	#if defined(PERL_GLOBAL_STRUCT)
	682
	683	END
	684
	685	for $sym (sort keys %globvar) {
	686	print EM multon($sym, 'G','my_vars->');
	687	print EM multon("G$sym",'', 'my_vars->');
	688	}
	689
	690	print EM <<'END';
	691
	692	#else /* !PERL_GLOBAL_STRUCT */
	693
	694	END
	695
	696	for $sym (sort keys %globvar) {
	697	print EM multoff($sym,'G');
	698	}
	699
	700	print EM <<'END';
	701
	702	#endif /* PERL_GLOBAL_STRUCT */
	703
	704	#ifdef PERL_POLLUTE /* disabled by default in 5.6.0 */
	705
	706	END
	707
	708	for $sym (sort @extvars) {
	709	print EM hide($sym,"PL_$sym");
	710	}
	711
	712	print EM <<'END';
	713
	714	#endif /* PERL_POLLUTE */
	715
	716	/* ex: set ro: */
	717	END
	718
	719	close(EM) or die "Error closing EM: $!";
	720
	721	safer_unlink 'perlapi.h';
	722	safer_unlink 'perlapi.c';
	723	open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
	724	binmode CAPI;
	725	open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
	726	binmode CAPIH;
	727
	728	print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
	729
	730	/* declare accessor functions for Perl variables */
	731	#ifndef __perlapi_h__
	732	#define __perlapi_h__
	733
	734	#if defined (MULTIPLICITY)
	735
	736	START_EXTERN_C
	737
	738	#undef PERLVAR
	739	#undef PERLVARA
	740	#undef PERLVARI
	741	#undef PERLVARIC
	742	#undef PERLVARISC
	743	#define PERLVAR(v,t) EXTERN_C t* Perl_##v##_ptr(pTHX);
	744	#define PERLVARA(v,n,t) typedef t PL_##v##_t[n]; \
	745	EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
	746	#define PERLVARI(v,t,i) PERLVAR(v,t)
	747	#define PERLVARIC(v,t,i) PERLVAR(v, const t)
	748	#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
	749	EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
	750
	751	#include "thrdvar.h"
	752	#include "intrpvar.h"
	753	#include "perlvars.h"
	754
	755	#undef PERLVAR
	756	#undef PERLVARA
	757	#undef PERLVARI
	758	#undef PERLVARIC
	759	#undef PERLVARISC
	760
	761	#ifndef PERL_GLOBAL_STRUCT
	762	EXTERN_C Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX);
	763	EXTERN_C Perl_check_t** Perl_Gcheck_ptr(pTHX);
	764	EXTERN_C unsigned char** Perl_Gfold_locale_ptr(pTHX);
	765	#define Perl_ppaddr_ptr Perl_Gppaddr_ptr
	766	#define Perl_check_ptr Perl_Gcheck_ptr
	767	#define Perl_fold_locale_ptr Perl_Gfold_locale_ptr
	768	#endif
	769
	770	END_EXTERN_C
	771
	772	#if defined(PERL_CORE)
	773
	774	/* accessor functions for Perl variables (provide binary compatibility) */
	775
	776	/* these need to be mentioned here, or most linkers won't put them in
	777	the perl executable */
	778
	779	#ifndef PERL_NO_FORCE_LINK
	780
	781	START_EXTERN_C
	782
	783	#ifndef DOINIT
	784	EXTCONST void * const PL_force_link_funcs[];
	785	#else
	786	EXTCONST void * const PL_force_link_funcs[] = {
	787	#undef PERLVAR
	788	#undef PERLVARA
	789	#undef PERLVARI
	790	#undef PERLVARIC
	791	#define PERLVAR(v,t) (void*)Perl_##v##_ptr,
	792	#define PERLVARA(v,n,t) PERLVAR(v,t)
	793	#define PERLVARI(v,t,i) PERLVAR(v,t)
	794	#define PERLVARIC(v,t,i) PERLVAR(v,t)
	795	#define PERLVARISC(v,i) PERLVAR(v,char)
	796
	797	#include "thrdvar.h"
	798	#include "intrpvar.h"
	799	#include "perlvars.h"
	800
	801	#undef PERLVAR
	802	#undef PERLVARA
	803	#undef PERLVARI
	804	#undef PERLVARIC
	805	#undef PERLVARISC
	806	};
	807	#endif /* DOINIT */
	808
	809	END_EXTERN_C
	810
	811	#endif /* PERL_NO_FORCE_LINK */
	812
	813	#else /* !PERL_CORE */
	814
	815	EOT
	816
	817	foreach $sym (sort keys %intrp) {
	818	print CAPIH bincompat_var('I',$sym);
	819	}
	820
	821	foreach $sym (sort keys %thread) {
	822	print CAPIH bincompat_var('T',$sym);
	823	}
	824
	825	foreach $sym (sort keys %globvar) {
	826	print CAPIH bincompat_var('G',$sym);
	827	}
	828
	829	print CAPIH <<'EOT';
	830
	831	#endif /* !PERL_CORE */
	832	#endif /* MULTIPLICITY */
	833
	834	#endif /* __perlapi_h__ */
	835
	836	/* ex: set ro: */
	837	EOT
	838	close CAPIH or die "Error closing CAPIH: $!";
	839
	840	print CAPI do_not_edit ("perlapi.c"), <<'EOT';
	841
	842	#include "EXTERN.h"
	843	#include "perl.h"
	844	#include "perlapi.h"
	845
	846	#if defined (MULTIPLICITY)
	847
	848	/* accessor functions for Perl variables (provides binary compatibility) */
	849	START_EXTERN_C
	850
	851	#undef PERLVAR
	852	#undef PERLVARA
	853	#undef PERLVARI
	854	#undef PERLVARIC
	855	#undef PERLVARISC
	856
	857	#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
	858	{ dVAR; return &(aTHX->v); }
	859	#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	860	{ dVAR; return &(aTHX->v); }
	861
	862	#define PERLVARI(v,t,i) PERLVAR(v,t)
	863	#define PERLVARIC(v,t,i) PERLVAR(v, const t)
	864	#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	865	{ dVAR; return &(aTHX->v); }
	866
	867	#include "thrdvar.h"
	868	#include "intrpvar.h"
	869
	870	#undef PERLVAR
	871	#undef PERLVARA
	872	#define PERLVAR(v,t) t* Perl_##v##_ptr(pTHX) \
	873	{ dVAR; return &(PL_##v); }
	874	#define PERLVARA(v,n,t) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	875	{ dVAR; return &(PL_##v); }
	876	#undef PERLVARIC
	877	#undef PERLVARISC
	878	#define PERLVARIC(v,t,i) \
	879	const t* Perl_##v##_ptr(pTHX) \
	880	{ return (const t *)&(PL_##v); }
	881	#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
	882	{ dVAR; return &(PL_##v); }
	883	#include "perlvars.h"
	884
	885	#undef PERLVAR
	886	#undef PERLVARA
	887	#undef PERLVARI
	888	#undef PERLVARIC
	889	#undef PERLVARISC
	890
	891	#ifndef PERL_GLOBAL_STRUCT
	892	/* A few evil special cases. Could probably macrofy this. */
	893	#undef PL_ppaddr
	894	#undef PL_check
	895	#undef PL_fold_locale
	896	Perl_ppaddr_t** Perl_Gppaddr_ptr(pTHX) {
	897	static const Perl_ppaddr_t* ppaddr_ptr = PL_ppaddr;
	898	return (Perl_ppaddr_t**)&ppaddr_ptr;
	899	}
	900	Perl_check_t** Perl_Gcheck_ptr(pTHX) {
	901	static const Perl_check_t* check_ptr = PL_check;
	902	return (Perl_check_t**)&check_ptr;
	903	}
	904	unsigned char** Perl_Gfold_locale_ptr(pTHX) {
	905	static const unsigned char* fold_locale_ptr = PL_fold_locale;
	906	return (unsigned char**)&fold_locale_ptr;
	907	}
	908	#endif
	909
	910	END_EXTERN_C
	911
	912	#endif /* MULTIPLICITY */
	913
	914	/* ex: set ro: */
	915	EOT
	916
	917	close(CAPI) or die "Error closing CAPI: $!";
	918
	919	# functions that take va_list* for implementing vararg functions
	920	# NOTE: makedef.pl must be updated if you add symbols to %vfuncs
	921	# XXX %vfuncs currently unused
	922	my %vfuncs = qw(
	923	Perl_croak Perl_vcroak
	924	Perl_warn Perl_vwarn
	925	Perl_warner Perl_vwarner
	926	Perl_die Perl_vdie
	927	Perl_form Perl_vform
	928	Perl_load_module Perl_vload_module
	929	Perl_mess Perl_vmess
	930	Perl_deb Perl_vdeb
	931	Perl_newSVpvf Perl_vnewSVpvf
	932	Perl_sv_setpvf Perl_sv_vsetpvf
	933	Perl_sv_setpvf_mg Perl_sv_vsetpvf_mg
	934	Perl_sv_catpvf Perl_sv_vcatpvf
	935	Perl_sv_catpvf_mg Perl_sv_vcatpvf_mg
	936	Perl_dump_indent Perl_dump_vindent
	937	Perl_default_protect Perl_vdefault_protect
	938	);