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