source: vendor/perl/5.8.8/embed.pl

Last change on this file was 3181, checked in by bird, 18 years ago

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