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