{
my $file = shift;
- my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006';
+ my $years = '1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007';
$years =~ s/1999,/1999,\n / if length $years > 40;
!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
This file is built by embed.pl from data in embed.fnc, embed.pl,
-pp.sym, intrpvar.h, perlvars.h and thrdvar.h.
+pp.sym, intrpvar.h, and perlvars.h.
Any changes made here will be lost!
Edit those files and run 'make regen_headers' to effect changes.
defined $leader or $leader = do_not_edit ($filename);
my $trailer = shift;
my $F;
- local *F;
if (ref $filename) { # filehandle
$F = $filename;
}
else {
- safer_unlink $filename if $filename ne '/dev/null';
- open F, ">$filename" or die "Can't open $filename: $!";
- binmode F;
- $F = \*F;
+ # safer_unlink $filename if $filename ne '/dev/null';
+ $F = safer_open("$filename-new");
}
print $F $leader if $leader;
seek IN, 0, 0; # so we may restart
}
print $F $trailer if $trailer;
unless (ref $filename) {
- close $F or die "Error closing $filename: $!";
+ safer_close($F);
+ rename_if_different("$filename-new", $filename);
}
}
$ret .= "$arg\n";
}
else {
- my ($flags,$retval,$func,@args) = @_;
+ my ($flags,$retval,$plain_func,@args) = @_;
my @nonnull;
my $has_context = ( $flags !~ /n/ );
my $never_returns = ( $flags =~ /r/ );
my $commented_out = ( $flags =~ /m/ );
my $is_malloc = ( $flags =~ /a/ );
my $can_ignore = ( $flags !~ /R/ ) && !$is_malloc;
+ my @names_of_nn;
+ my $func;
my $splint_flags = "";
if ( $SPLINT && !$commented_out ) {
if ($flags =~ /s/) {
$retval = "STATIC $splint_flags$retval";
- $func = "S_$func";
+ $func = "S_$plain_func";
}
else {
$retval = "PERL_CALLCONV $splint_flags$retval";
- if ($flags =~ /p/) {
- $func = "Perl_$func";
+ if ($flags =~ /[bp]/) {
+ $func = "Perl_$plain_func";
+ } else {
+ $func = $plain_func;
}
}
$ret .= "$retval\t$func(";
my $temp_arg = $arg;
$temp_arg =~ s/\*//g;
$temp_arg =~ s/\s*\bstruct\b\s*/ /g;
- if ( ($temp_arg ne "...") && ($temp_arg !~ /\w+\s+\w+/) ) {
- warn "$func: $arg doesn't have a name\n";
+ if ( ($temp_arg ne "...")
+ && ($temp_arg !~ /\w+\s+(\w+)(?:\[\d+\])?\s*$/) ) {
+ warn "$func: $arg ($n) doesn't have a name\n";
}
if ( $SPLINT && $nullok && !$commented_out ) {
$arg = '/*@null@*/ ' . $arg;
}
+ if (defined $1 && $nn) {
+ push @names_of_nn, $1;
+ }
}
$ret .= join ", ", @args;
}
push @attrs, "__attribute__pure__";
}
if( $flags =~ /f/ ) {
- my $prefix = $has_context ? 'pTHX_' : '';
- my $args = scalar @args;
- push @attrs, sprintf "__attribute__format__(__printf__,%s%d,%s%d)",
- $prefix, $args - 1, $prefix, $args;
+ my $prefix = $has_context ? 'pTHX_' : '';
+ my $args = scalar @args;
+ my $pat = $args - 1;
+ my $macro = @nonnull && $nonnull[-1] == $pat
+ ? '__attribute__format__'
+ : '__attribute__format__null_ok__';
+ push @attrs, sprintf "%s(__printf__,%s%d,%s%d)", $macro,
+ $prefix, $pat, $prefix, $args;
}
if ( @nonnull ) {
my @pos = map { $has_context ? "pTHX_$_" : $_ } @nonnull;
}
$ret .= ";";
$ret = "/* $ret */" if $commented_out;
+ if (@names_of_nn) {
+ $ret .= "\n#define PERL_ARGS_ASSERT_\U$plain_func\E\t\\\n\t"
+ . join '; ', map "assert($_)", @names_of_nn;
+ }
$ret .= @attrs ? "\n\n" : "\n";
}
$ret;
s/[ \t]*#.*//; # Delete comments.
if (/^\s*(\S+)\s*$/) {
my $sym = $1;
- warn "duplicate symbol $sym while processing $file\n"
+ warn "duplicate symbol $sym while processing $file line $.\n"
if exists $$syms{$sym};
$$syms{$sym} = 1;
}
if (/PERLVARA?I?S?C?\($pre(\w+)/) {
my $sym = $1;
$sym = $pre . $sym if $keep_pre;
- warn "duplicate symbol $sym while processing $file\n"
+ warn "duplicate symbol $sym while processing $file line $.\n"
if exists $$syms{$sym};
$$syms{$sym} = $pre || 1;
}
}
my %intrp;
-my %thread;
my %globvar;
readvars %intrp, 'intrpvar.h','I';
-readvars %thread, 'thrdvar.h','T';
readvars %globvar, 'perlvars.h','G';
my $sym;
-foreach $sym (sort keys %thread) {
- warn "$sym in intrpvar.h as well as thrdvar.h\n" if exists $intrp{$sym};
-}
sub undefine ($) {
my ($sym) = @_;
return hide("PL_$pre$sym", "PL_$sym");
}
-safer_unlink 'embed.h';
-open(EM, '> embed.h') or die "Can't create embed.h: $!\n";
-binmode EM;
+my $em = safer_open('embed.h-new');
-print EM do_not_edit ("embed.h"), <<'END';
+print $em do_not_edit ("embed.h"), <<'END';
/* (Doing namespace management portably in C is really gross.) */
# Remember the new state.
$ifdef_state = $new_ifdef_state;
$ret;
-} \*EM, "";
+} $em, "";
if ($ifdef_state) {
- print EM "#endif\n";
+ print $em "#endif\n";
}
for $sym (sort keys %ppsym) {
$sym =~ s/^Perl_//;
- print EM hide($sym, "Perl_$sym");
+ print $em hide($sym, "Perl_$sym");
}
-print EM <<'END';
+print $em <<'END';
#else /* PERL_IMPLICIT_CONTEXT */
# Remember the new state.
$ifdef_state = $new_ifdef_state;
$ret;
-} \*EM, "";
+} $em, "";
if ($ifdef_state) {
- print EM "#endif\n";
+ print $em "#endif\n";
}
for $sym (sort keys %ppsym) {
$sym =~ s/^Perl_//;
if ($sym =~ /^ck_/) {
- print EM hide("$sym(a)", "Perl_$sym(aTHX_ a)");
+ print $em hide("$sym(a)", "Perl_$sym(aTHX_ a)");
}
elsif ($sym =~ /^pp_/) {
- print EM hide("$sym()", "Perl_$sym(aTHX)");
+ print $em hide("$sym()", "Perl_$sym(aTHX)");
}
else {
warn "Illegal symbol '$sym' in pp.sym";
}
}
-print EM <<'END';
+print $em <<'END';
#endif /* PERL_IMPLICIT_CONTEXT */
END
-print EM <<'END';
+print $em <<'END';
/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
disable them.
/* ex: set ro: */
END
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embed.h-new', 'embed.h');
-safer_unlink 'embedvar.h';
-open(EM, '> embedvar.h')
- or die "Can't create embedvar.h: $!\n";
-binmode EM;
+$em = safer_open('embedvar.h-new');
-print EM do_not_edit ("embedvar.h"), <<'END';
+print $em do_not_edit ("embedvar.h"), <<'END';
/* (Doing namespace management portably in C is really gross.) */
END
-for $sym (sort keys %thread) {
- print EM multon($sym,'T','vTHX->');
-}
-
-print EM <<'END';
-
-/* cases 2 and 3 above */
-
-END
-
for $sym (sort keys %intrp) {
- print EM multon($sym,'I','vTHX->');
+ print $em multon($sym,'I','vTHX->');
}
-print EM <<'END';
+print $em <<'END';
#else /* !MULTIPLICITY */
END
for $sym (sort keys %intrp) {
- print EM multoff($sym,'I');
+ print $em multoff($sym,'I');
}
-print EM <<'END';
+print $em <<'END';
END
-for $sym (sort keys %thread) {
- print EM multoff($sym,'T');
-}
-
-print EM <<'END';
+print $em <<'END';
#endif /* MULTIPLICITY */
END
for $sym (sort keys %globvar) {
- print EM multon($sym, 'G','my_vars->');
- print EM multon("G$sym",'', 'my_vars->');
+ print $em multon($sym, 'G','my_vars->');
+ print $em multon("G$sym",'', 'my_vars->');
}
-print EM <<'END';
+print $em <<'END';
#else /* !PERL_GLOBAL_STRUCT */
END
for $sym (sort keys %globvar) {
- print EM multoff($sym,'G');
+ print $em multoff($sym,'G');
}
-print EM <<'END';
+print $em <<'END';
#endif /* PERL_GLOBAL_STRUCT */
END
for $sym (sort @extvars) {
- print EM hide($sym,"PL_$sym");
+ print $em hide($sym,"PL_$sym");
}
-print EM <<'END';
+print $em <<'END';
#endif /* PERL_POLLUTE */
/* ex: set ro: */
END
-close(EM) or die "Error closing EM: $!";
+safer_close($em);
+rename_if_different('embedvar.h-new', 'embedvar.h');
-safer_unlink 'perlapi.h';
-safer_unlink 'perlapi.c';
-open(CAPI, '> perlapi.c') or die "Can't create perlapi.c: $!\n";
-binmode CAPI;
-open(CAPIH, '> perlapi.h') or die "Can't create perlapi.h: $!\n";
-binmode CAPIH;
+my $capi = safer_open('perlapi.c-new');
+my $capih = safer_open('perlapi.h-new');
-print CAPIH do_not_edit ("perlapi.h"), <<'EOT';
+print $capih do_not_edit ("perlapi.h"), <<'EOT';
/* declare accessor functions for Perl variables */
#ifndef __perlapi_h__
#define PERLVARISC(v,i) typedef const char PL_##v##_t[sizeof(i)]; \
EXTERN_C PL_##v##_t* Perl_##v##_ptr(pTHX);
-#include "thrdvar.h"
#include "intrpvar.h"
#include "perlvars.h"
#pragma message disable (nonstandcast)
#endif
-#include "thrdvar.h"
#include "intrpvar.h"
#include "perlvars.h"
EOT
foreach $sym (sort keys %intrp) {
- print CAPIH bincompat_var('I',$sym);
-}
-
-foreach $sym (sort keys %thread) {
- print CAPIH bincompat_var('T',$sym);
+ print $capih bincompat_var('I',$sym);
}
foreach $sym (sort keys %globvar) {
- print CAPIH bincompat_var('G',$sym);
+ print $capih bincompat_var('G',$sym);
}
-print CAPIH <<'EOT';
+print $capih <<'EOT';
#endif /* !PERL_CORE */
#endif /* MULTIPLICITY */
/* ex: set ro: */
EOT
-close CAPIH or die "Error closing CAPIH: $!";
+safer_close($capih);
+rename_if_different('perlapi.h-new', 'perlapi.h');
-print CAPI do_not_edit ("perlapi.c"), <<'EOT';
+print $capi do_not_edit ("perlapi.c"), <<'EOT';
#include "EXTERN.h"
#include "perl.h"
#define PERLVARISC(v,i) PL_##v##_t* Perl_##v##_ptr(pTHX) \
{ dVAR; PERL_UNUSED_CONTEXT; return &(aTHX->v); }
-#include "thrdvar.h"
#include "intrpvar.h"
#undef PERLVAR
/* ex: set ro: */
EOT
-close(CAPI) or die "Error closing CAPI: $!";
+safer_close($capi);
+rename_if_different('perlapi.c-new', 'perlapi.c');
# functions that take va_list* for implementing vararg functions
# NOTE: makedef.pl must be updated if you add symbols to %vfuncs