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