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