Change 33944 by [EMAIL PROTECTED] on 2008/05/28 18:24:46
Integrate:
[ 33488]
Subject: [PATCH] Correct misleading example in perlsyn.pod
(given/when/default)
From: Paul Fenwick <[EMAIL PROTECTED]>
Date: Wed, 12 Mar 2008 13:19:15 +1100
Message-ID: <[EMAIL PROTECTED]>
[ 33537]
Subject: Re: [patch] refine make regen to be more selective
From: Jim Cromie <[EMAIL PROTECTED]>
Message-ID: <[EMAIL PROTECTED]>
Date: Tue, 11 Mar 2008 18:16:14 -0600
[ 33538]
Rename safer_rename() to rename_if_different(), to accurately describe
what it does. Use File::Compare rather than Digest::MD5, as the files
are small enough to simply read in. (File::Compare dates from 5.004)
Remove safer_rename_always(), which isn't used.
DRY by replacing the cargo-culted "open or die" with a new function
safer_open(), which uses Gensym (5.002) to create an anonymous file
handle, and opens and binmodes the file, or dies.
This necessitates replacing bareword file handles with lexicals in all
the callers.
Correct the names of files in close or die constructions.
[ 33539]
Drag autodoc.pl and overload.pl into the age of safer_open().
Thanks to the wisdom of london.pm, stuff the filename into the SCALAR
slot of the typeglob created in safer_open(), so that ...
Add safer_close(), that will die (with the filename) if the close
fails.
[ 33544]
Subject: [PATCH] Double warning with perl -we '\&$x'
From: "Vincent Pit" <[EMAIL PROTECTED]>
Date: Thu, 20 Mar 2008 12:06:47 +0100 (CET)
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.10/perl/autodoc.pl#2 integrate
... //depot/maint-5.10/perl/embed.pl#2 integrate
... //depot/maint-5.10/perl/keywords.pl#2 integrate
... //depot/maint-5.10/perl/opcode.pl#4 integrate
... //depot/maint-5.10/perl/overload.pl#2 integrate
... //depot/maint-5.10/perl/pod/perlsyn.pod#3 integrate
... //depot/maint-5.10/perl/reentr.pl#2 integrate
... //depot/maint-5.10/perl/regcomp.pl#3 integrate
... //depot/maint-5.10/perl/regen.pl#3 integrate
... //depot/maint-5.10/perl/regen_lib.pl#2 integrate
... //depot/maint-5.10/perl/sv.c#16 integrate
... //depot/maint-5.10/perl/t/lib/warnings/9uninit#5 integrate
... //depot/maint-5.10/perl/warnings.pl#2 integrate
Differences ...
==== //depot/maint-5.10/perl/autodoc.pl#2 (text) ====
Index: perl/autodoc.pl
--- perl/autodoc.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/autodoc.pl 2008-05-28 11:24:46.000000000 -0700
@@ -33,7 +33,7 @@
}
else {
safer_unlink $filename;
- open F, ">$filename" or die "Can't open $filename: $!";
+ $F = safer_open($filename);
binmode F;
$F = \*F;
}
@@ -183,9 +183,7 @@
}
safer_unlink "pod/perlapi.pod";
-open (DOC, ">pod/perlapi.pod") or
- die "Can't create pod/perlapi.pod: $!\n";
-binmode DOC;
+my $doc = safer_open("pod/perlapi.pod");
walk_table { # load documented functions into appropriate hash
if (@_ > 1) {
@@ -211,7 +209,7 @@
}
}
return "";
-} \*DOC;
+} $doc;
for (sort keys %docfuncs) {
# Have you used a full for apidoc or just a func name?
@@ -219,9 +217,9 @@
warn "Unable to place $_!\n";
}
-readonly_header(\*DOC);
+readonly_header($doc);
-print DOC <<'_EOB_';
+print $doc <<'_EOB_';
=head1 NAME
perlapi - autogenerated documentation for the perl public API
@@ -248,15 +246,15 @@
# case insensitive sort, with fallback for determinacy
for $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %apidocs) {
my $section = $apidocs{$key};
- print DOC "\n=head1 $key\n\n=over 8\n\n";
+ print $doc "\n=head1 $key\n\n=over 8\n\n";
# Again, fallback for determinacy
for my $key (sort { uc($a) cmp uc($b) || $a cmp $b } keys %$section) {
- docout(\*DOC, $key, $section->{$key});
+ docout($doc, $key, $section->{$key});
}
- print DOC "\n=back\n";
+ print $doc "\n=back\n";
}
-print DOC <<'_EOE_';
+print $doc <<'_EOE_';
=head1 AUTHORS
@@ -278,16 +276,14 @@
_EOE_
-readonly_footer(\*DOC);
+readonly_footer($doc);
-close(DOC) or die "Error closing pod/perlapi.pod: $!";
+safer_close($doc);
safer_unlink "pod/perlintern.pod";
-open(GUTS, ">pod/perlintern.pod") or
- die "Unable to create pod/perlintern.pod: $!\n";
-binmode GUTS;
-readonly_header(\*GUTS);
-print GUTS <<'END';
+my $guts = safer_open("pod/perlintern.pod");
+readonly_header($guts);
+print $guts <<'END';
=head1 NAME
perlintern - autogenerated documentation of purely B<internal>
@@ -305,14 +301,14 @@
for $key (sort { uc($a) cmp uc($b); } keys %gutsdocs) {
my $section = $gutsdocs{$key};
- print GUTS "\n=head1 $key\n\n=over 8\n\n";
+ print $guts "\n=head1 $key\n\n=over 8\n\n";
for my $key (sort { uc($a) cmp uc($b); } keys %$section) {
- docout(\*GUTS, $key, $section->{$key});
+ docout($guts, $key, $section->{$key});
}
- print GUTS "\n=back\n";
+ print $guts "\n=back\n";
}
-print GUTS <<'END';
+print $guts <<'END';
=head1 AUTHORS
@@ -325,6 +321,6 @@
perlguts(1), perlapi(1)
END
-readonly_footer(\*GUTS);
+readonly_footer($guts);
-close GUTS or die "Error closing pod/perlintern.pod: $!";
+safer_close($guts);
==== //depot/maint-5.10/perl/embed.pl#2 (xtext) ====
Index: perl/embed.pl
--- perl/embed.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/embed.pl 2008-05-28 11:24:46.000000000 -0700
@@ -79,15 +79,12 @@
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
@@ -111,7 +108,8 @@
}
print $F $trailer if $trailer;
unless (ref $filename) {
- close $F or die "Error closing $filename: $!";
+ safer_close($F);
+ rename_if_different("$filename-new", $filename);
}
}
@@ -376,11 +374,9 @@
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.) */
@@ -444,18 +440,18 @@
# 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 */
@@ -522,26 +518,26 @@
# 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 */
@@ -549,7 +545,7 @@
END
-print EM <<'END';
+print $em <<'END';
/* Compatibility stubs. Compile extensions with -DPERL_NOCOMPAT to
disable them.
@@ -629,14 +625,12 @@
/* 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.) */
@@ -665,10 +659,10 @@
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 */
@@ -677,14 +671,14 @@
END
for $sym (sort keys %intrp) {
- print EM multoff($sym,'I');
+ print $em multoff($sym,'I');
}
-print EM <<'END';
+print $em <<'END';
END
-print EM <<'END';
+print $em <<'END';
#endif /* MULTIPLICITY */
@@ -693,21 +687,21 @@
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 */
@@ -716,26 +710,23 @@
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__
@@ -840,14 +831,14 @@
EOT
foreach $sym (sort keys %intrp) {
- print CAPIH bincompat_var('I',$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 */
@@ -856,9 +847,10 @@
/* 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"
@@ -937,7 +929,8 @@
/* 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
==== //depot/maint-5.10/perl/keywords.pl#2 (xtext) ====
Index: perl/keywords.pl
--- perl/keywords.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/keywords.pl 2008-05-28 11:24:46.000000000 -0700
@@ -2,10 +2,9 @@
use strict;
require 'regen_lib.pl';
-safer_unlink ("keywords.h");
-open(KW, ">keywords.h") || die "Can't create keywords.h: $!\n";
-binmode KW;
-select KW;
+
+my $kw = safer_open("keywords.h-new");
+select $kw;
print <<EOM;
/* -*- buffer-read-only: t -*-
@@ -35,9 +34,11 @@
print &tab(5, "#define KEY_$keyword"), $keynum++, "\n";
}
-print KW "\n/* ex: set ro: */\n";
+print $kw "\n/* ex: set ro: */\n";
+
+safer_close($kw);
-close KW or die "Error closing keywords.h: $!";
+rename_if_different("keywords.h-new", "keywords.h");
###########################################################################
sub tab {
==== //depot/maint-5.10/perl/opcode.pl#4 (xtext) ====
Index: perl/opcode.pl
--- perl/opcode.pl#3~33942~ 2008-05-27 18:21:26.000000000 -0700
+++ perl/opcode.pl 2008-05-28 11:24:46.000000000 -0700
@@ -8,11 +8,9 @@
my $opcode_new = 'opcode.h-new';
my $opname_new = 'opnames.h-new';
-open(OC, ">$opcode_new") || die "Can't create $opcode_new: $!\n";
-binmode OC;
-open(ON, ">$opname_new") || die "Can't create $opname_new: $!\n";
-binmode ON;
-select OC;
+my $oc = safer_open($opcode_new);
+my $on = safer_open($opname_new);
+select $oc;
# Read data.
@@ -126,7 +124,7 @@
END
-print ON <<"END";
+print $on <<"END";
/* -*- buffer-read-only: t -*-
*
* opnames.h
@@ -148,13 +146,13 @@
my $i = 0;
for (@ops) {
- print ON "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n";
+ print $on "\t", &tab(3,"OP_\U$_,"), "/* ", $i++, " */\n";
}
-print ON "\t", &tab(3,"OP_max"), "\n";
-print ON "} opcode;\n";
-print ON "\n#define MAXO ", scalar @ops, "\n";
-print ON "#define OP_phoney_INPUT_ONLY -1\n";
-print ON "#define OP_phoney_OUTPUT_ONLY -2\n\n";
+print $on "\t", &tab(3,"OP_max"), "\n";
+print $on "} opcode;\n";
+print $on "\n#define MAXO ", scalar @ops, "\n";
+print $on "#define OP_phoney_INPUT_ONLY -1\n";
+print $on "#define OP_phoney_OUTPUT_ONLY -2\n\n";
# Emit op names and descriptions.
@@ -388,40 +386,35 @@
END
if (keys %OP_IS_SOCKET) {
- print ON "\n#define OP_IS_SOCKET(op) \\\n\t(";
- print ON join(" || \\\n\t ",
+ print $on "\n#define OP_IS_SOCKET(op) \\\n\t(";
+ print $on join(" || \\\n\t ",
map { "(op) == OP_" . uc() } sort keys %OP_IS_SOCKET);
- print ON ")\n\n";
+ print $on ")\n\n";
}
if (keys %OP_IS_FILETEST) {
- print ON "\n#define OP_IS_FILETEST(op) \\\n\t(";
- print ON join(" || \\\n\t ",
+ print $on "\n#define OP_IS_FILETEST(op) \\\n\t(";
+ print $on join(" || \\\n\t ",
map { "(op) == OP_" . uc() } sort keys %OP_IS_FILETEST);
- print ON ")\n\n";
+ print $on ")\n\n";
}
-print OC "/* ex: set ro: */\n";
-print ON "/* ex: set ro: */\n";
+print $oc "/* ex: set ro: */\n";
+print $on "/* ex: set ro: */\n";
-close OC or die "Error closing opcode.h: $!";
-close ON or die "Error closing opnames.h: $!";
+safer_close($oc);
+safer_close($on);
-foreach ('opcode.h', 'opnames.h') {
- safer_rename_silent $_, "$_-old";
-}
-safer_rename $opcode_new, 'opcode.h';
-safer_rename $opname_new, 'opnames.h';
+rename_if_different $opcode_new, 'opcode.h';
+rename_if_different $opname_new, 'opnames.h';
my $pp_proto_new = 'pp_proto.h-new';
my $pp_sym_new = 'pp.sym-new';
-open PP, ">$pp_proto_new" or die "Error creating $pp_proto_new: $!";
-binmode PP;
-open PPSYM, ">$pp_sym_new" or die "Error creating $pp_sym_new: $!";
-binmode PPSYM;
+my $pp = safer_open($pp_proto_new);
+my $ppsym = safer_open($pp_sym_new);
-print PP <<"END";
+print $pp <<"END";
/* -*- buffer-read-only: t -*-
!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
This file is built by opcode.pl from its data. Any changes made here
@@ -430,7 +423,7 @@
END
-print PPSYM <<"END";
+print $ppsym <<"END";
# -*- buffer-read-only: t -*-
#
# !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
@@ -442,30 +435,27 @@
for (sort keys %ckname) {
- print PP "PERL_CKDEF(Perl_$_)\n";
- print PPSYM "Perl_$_\n";
+ print $pp "PERL_CKDEF(Perl_$_)\n";
+ print $ppsym "Perl_$_\n";
#OP *\t", &tab(3,$_),"(OP* o);\n";
}
-print PP "\n\n";
+print $pp "\n\n";
for (@ops) {
next if /^i_(pre|post)(inc|dec)$/;
next if /^custom$/;
- print PP "PERL_PPDEF(Perl_pp_$_)\n";
- print PPSYM "Perl_pp_$_\n";
+ print $pp "PERL_PPDEF(Perl_pp_$_)\n";
+ print $ppsym "Perl_pp_$_\n";
}
-print PP "\n/* ex: set ro: */\n";
-print PPSYM "\n# ex: set ro:\n";
+print $pp "\n/* ex: set ro: */\n";
+print $ppsym "\n# ex: set ro:\n";
-close PP or die "Error closing pp_proto.h: $!";
-close PPSYM or die "Error closing pp.sym: $!";
+safer_close($pp);
+safer_close($ppsym);
-foreach ('pp_proto.h', 'pp.sym') {
- safer_rename_silent $_, "$_-old";
-}
-safer_rename $pp_proto_new, 'pp_proto.h';
-safer_rename $pp_sym_new, 'pp.sym';
+rename_if_different $pp_proto_new, 'pp_proto.h';
+rename_if_different $pp_sym_new, 'pp.sym';
END {
foreach ('opcode.h', 'opnames.h', 'pp_proto.h', 'pp.sym') {
==== //depot/maint-5.10/perl/overload.pl#2 (text) ====
Index: perl/overload.pl
--- perl/overload.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/overload.pl 2008-05-28 11:24:46.000000000 -0700
@@ -22,10 +22,8 @@
}
safer_unlink ('overload.h', 'overload.c');
-die "overload.h: $!" unless open(C, ">overload.c");
-binmode C;
-die "overload.h: $!" unless open(H, ">overload.h");
-binmode H;
+my $c = safer_open("overload.c");
+my $h = safer_open("overload.h");
sub print_header {
my $file = shift;
@@ -46,10 +44,10 @@
EOF
}
-select C;
+select $c;
print_header('overload.c');
-select H;
+select $h;
print_header('overload.h');
print <<'EOF';
@@ -67,7 +65,7 @@
EOF
-print C <<'EOF';
+print $c <<'EOF';
#define AMG_id2name(id) (PL_AMG_names[id]+1)
#define AMG_id2namelen(id) (PL_AMG_namelens[id]-1)
@@ -77,10 +75,10 @@
my $last = pop @names;
-print C " $_,\n" foreach map { length $_ } @names;
+print $c " $_,\n" foreach map { length $_ } @names;
my $lastlen = length $last;
-print C <<"EOT";
+print $c <<"EOT";
$lastlen
};
@@ -92,15 +90,15 @@
overload.pm. */
EOT
-print C " \"$_\",\n" foreach map { s/(["\\"])/\\$1/g; $_ } @names;
+print $c " \"$_\",\n" foreach map { s/(["\\"])/\\$1/g; $_ } @names;
-print C <<"EOT";
+print $c <<"EOT";
"$last"
};
EOT
-close H or die $!;
-close C or die $!;
+safer_close($h);
+safer_close($c);
__DATA__
# Fallback should be the first
==== //depot/maint-5.10/perl/pod/perlsyn.pod#3 (text) ====
Index: perl/pod/perlsyn.pod
--- perl/pod/perlsyn.pod#2~33123~ 2008-01-30 03:45:08.000000000 -0800
+++ perl/pod/perlsyn.pod 2008-05-28 11:24:46.000000000 -0700
@@ -634,7 +634,7 @@
given($foo) {
when (/x/) { say '$foo contains an x'; continue }
when (/y/) { say '$foo contains a y' }
- default { say '$foo contains neither an x nor a y' }
+ default { say '$foo does not contain a y' }
}
=head3 Switching in a loop
==== //depot/maint-5.10/perl/reentr.pl#2 (text) ====
Index: perl/reentr.pl
--- perl/reentr.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/reentr.pl 2008-05-28 11:24:46.000000000 -0700
@@ -13,7 +13,7 @@
use strict;
use Getopt::Std;
my %opts;
-getopts('U', \%opts);
+getopts('Uv', \%opts);
my %map = (
V => "void",
@@ -40,10 +40,9 @@
# Example #3: S_CBI means type func_r(const char*, char*, int)
-safer_unlink 'reentr.h';
-die "reentr.h: $!" unless open(H, ">reentr.h");
-binmode H;
-select H;
+# safer_unlink 'reentr.h';
+my $h = safer_open("reentr.h-new");
+select $h;
print <<EOF;
/* -*- buffer-read-only: t -*-
*
@@ -332,7 +331,7 @@
# Prepare to continue writing the reentr.h.
-select H;
+select $h;
{
# Write out all the known prototype signatures.
@@ -788,14 +787,14 @@
/* ex: set ro: */
EOF
-close(H);
+safer_close($h);
+rename_if_different('reentr.h-new', 'reentr.h');
# Prepare to write the reentr.c.
-safer_unlink 'reentr.c';
-die "reentr.c: $!" unless open(C, ">reentr.c");
-binmode C;
-select C;
+# safer_unlink 'reentr.c';
+my $c = safer_open("reentr.c-new");
+select $c;
print <<EOF;
/* -*- buffer-read-only: t -*-
*
@@ -1085,6 +1084,9 @@
/* ex: set ro: */
EOF
+safer_close($c);
+rename_if_different('reentr.c-new', 'reentr.c');
+
__DATA__
asctime S |time |const struct tm|B_SB|B_SBI|I_SB|I_SBI
crypt CC |crypt |struct crypt_data|B_CCS|B_CCD|D=CRYPTD*
==== //depot/maint-5.10/perl/regcomp.pl#3 (text) ====
Index: perl/regcomp.pl
--- perl/regcomp.pl#2~33136~ 2008-01-30 11:55:32.000000000 -0800
+++ perl/regcomp.pl 2008-05-28 11:24:46.000000000 -0700
@@ -68,11 +68,9 @@
unlink $tmp_h if -f $tmp_h;
-open OUT, ">$tmp_h";
-#*OUT=\*STDOUT;
-binmode OUT;
+my $out = safer_open($tmp_h);
-printf OUT <<EOP,
+printf $out <<EOP,
/* -*- buffer-read-only: t -*-
!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
This file is built by regcomp.pl from regcomp.sym.
@@ -92,16 +90,16 @@
for ($ind=1; $ind <= $lastregop ; $ind++) {
my $oind = $ind - 1;
- printf OUT "#define\t%*s\t%d\t/* %#04x %s */\n",
+ printf $out "#define\t%*s\t%d\t/* %#04x %s */\n",
-$width, $name[$ind], $ind-1, $ind-1, $rest[$ind];
}
-print OUT "\t/* ------------ States ------------- */\n";
+print $out "\t/* ------------ States ------------- */\n";
for ( ; $ind <= $tot ; $ind++) {
- printf OUT "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n",
+ printf $out "#define\t%*s\t(REGNODE_MAX + %d)\t/* %s */\n",
-$width, $name[$ind], $ind - $lastregop, $rest[$ind];
}
-print OUT <<EOP;
+print $out <<EOP;
/* PL_regkind[] What type of regop or state is this. */
@@ -113,13 +111,13 @@
$ind = 0;
while (++$ind <= $tot) {
- printf OUT "\t%*s\t/* %*s */\n",
+ printf $out "\t%*s\t/* %*s */\n",
-1-$twidth, "$type[$ind],", -$width, $name[$ind];
- print OUT "\t/* ------------ States ------------- */\n"
+ print $out "\t/* ------------ States ------------- */\n"
if $ind == $lastregop and $lastregop != $tot;
}
-print OUT <<EOP;
+print $out <<EOP;
};
#endif
@@ -134,11 +132,11 @@
my $size = 0;
$size = "EXTRA_SIZE(struct regnode_$args[$ind])" if $args[$ind];
- printf OUT "\t%*s\t/* %*s */\n",
+ printf $out "\t%*s\t/* %*s */\n",
-37, "$size,",-$rwidth,$name[$ind];
}
-print OUT <<EOP;
+print $out <<EOP;
};
/* reg_off_by_arg[] - Which argument holds the offset to the next node */
@@ -150,11 +148,11 @@
while (++$ind <= $lastregop) {
my $size = $longj[$ind] || 0;
- printf OUT "\t%d,\t/* %*s */\n",
+ printf $out "\t%d,\t/* %*s */\n",
$size, -$rwidth, $name[$ind]
}
-print OUT <<EOP;
+print $out <<EOP;
};
#endif /* REG_COMP_C */
@@ -173,17 +171,17 @@
while (++$ind <= $tot) {
my $size = $longj[$ind] || 0;
- printf OUT "\t%*s\t/* $sym%#04x */\n",
+ printf $out "\t%*s\t/* $sym%#04x */\n",
-3-$width,qq("$name[$ind]",), $ind - $ofs;
if ($ind == $lastregop and $lastregop != $tot) {
- print OUT "\t/* ------------ States ------------- */\n";
+ print $out "\t/* ------------ States ------------- */\n";
$ofs = $lastregop;
$sym = 'REGNODE_MAX +';
}
}
-print OUT <<EOP;
+print $out <<EOP;
};
#endif /* DOINIT */
@@ -211,20 +209,20 @@
}
}
my %vrxf=reverse %rxfv;
-printf OUT "\t/* Bits in extflags defined: %032b */\n",$val;
+printf $out "\t/* Bits in extflags defined: %032b */\n",$val;
for (0..31) {
my $n=$vrxf{2**$_}||"UNUSED_BIT_$_";
$n=~s/^RXf_(PMf_)?//;
- printf OUT qq(\t%-20s/* 0x%08x */\n),
+ printf $out qq(\t%-20s/* 0x%08x */\n),
qq("$n",),2**$_;
}
-print OUT <<EOP;
+print $out <<EOP;
};
#endif /* DOINIT */
/* ex: set ro: */
EOP
-close OUT or die "close $tmp_h: $!";
+safer_close($out);
-safer_rename $tmp_h, 'regnodes.h';
+rename_if_different $tmp_h, 'regnodes.h';
==== //depot/maint-5.10/perl/regen.pl#3 (text) ====
Index: perl/regen.pl
--- perl/regen.pl#2~33731~ 2008-04-22 12:31:58.000000000 -0700
+++ perl/regen.pl 2008-05-28 11:24:46.000000000 -0700
@@ -13,8 +13,8 @@
require 'regen_lib.pl';
# keep warnings.pl in sync with the CPAN distribution by not requiring core
-# changes
-safer_unlink ("warnings.h", "lib/warnings.pm");
+# changes. Um, what ?
+# safer_unlink ("warnings.h", "lib/warnings.pm");
my %gen = (
'autodoc.pl' => [qw[pod/perlapi.pod pod/perlintern.pod]],
==== //depot/maint-5.10/perl/regen_lib.pl#2 (text) ====
Index: perl/regen_lib.pl
--- perl/regen_lib.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/regen_lib.pl 2008-05-28 11:24:46.000000000 -0700
@@ -2,6 +2,8 @@
use strict;
use vars qw($Is_W32 $Is_OS2 $Is_Cygwin $Is_NetWare $Needs_Write);
use Config; # Remember, this is running using an existing perl
+use File::Compare;
+use Symbol;
# Common functions needed by the regen scripts
@@ -38,8 +40,31 @@
rename $from, $to;
}
-sub safer_rename {
+sub rename_if_different {
my ($from, $to) = @_;
+
+ if (compare($from, $to) == 0) {
+ warn "no changes between '$from' & '$to'\n";
+ safer_unlink($from);
+ return;
+ }
+ warn "changed '$from' to '$to'\n";
safer_rename_silent($from, $to) or die "renaming $from to $to: $!";
}
+
+# Saf*er*, but not totally safe. And assumes always open for output.
+sub safer_open {
+ my $name = shift;
+ my $fh = gensym;
+ open $fh, ">$name" or die "Can't create $name: $!";
+ *{$fh}->{SCALAR} = $name;
+ binmode $fh;
+ $fh;
+}
+
+sub safer_close {
+ my $fh = shift;
+ close $fh or die 'Error closing ' . *{$fh}->{SCALAR} . ": $!";
+}
+
1;
==== //depot/maint-5.10/perl/sv.c#16 (text) ====
Index: perl/sv.c
--- perl/sv.c#15~33942~ 2008-05-27 18:21:26.000000000 -0700
+++ perl/sv.c 2008-05-28 11:24:46.000000000 -0700
@@ -7635,7 +7635,7 @@
LEAVE;
if (!GvCVu(gv))
Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"",
- SVfARG(sv));
+ SVfARG(SvOK(sv) ? sv : &PL_sv_no));
}
return GvCVu(gv);
}
==== //depot/maint-5.10/perl/t/lib/warnings/9uninit#5 (text) ====
Index: perl/t/lib/warnings/9uninit
--- perl/t/lib/warnings/9uninit#4~33942~ 2008-05-27 18:21:26.000000000
-0700
+++ perl/t/lib/warnings/9uninit 2008-05-28 11:24:46.000000000 -0700
@@ -1064,8 +1064,6 @@
reset $g1;
EXPECT
Use of uninitialized value $m1 in subroutine dereference at - line 5.
-Use of uninitialized value $m1 in subroutine dereference at - line 5.
-Use of uninitialized value $g1 in subroutine dereference at - line 6.
Use of uninitialized value $g1 in subroutine dereference at - line 6.
Use of uninitialized value $m1 in splice at - line 9.
Use of uninitialized value $g1 in splice at - line 9.
==== //depot/maint-5.10/perl/warnings.pl#2 (text) ====
Index: perl/warnings.pl
--- perl/warnings.pl#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/warnings.pl 2008-05-28 11:24:46.000000000 -0700
@@ -3,7 +3,8 @@
$VERSION = '1.02_02';
BEGIN {
- push @INC, './lib';
+ require 'regen_lib.pl';
+ push @INC, './lib';
}
use strict ;
@@ -248,14 +249,10 @@
exit ;
}
-unlink "warnings.h";
-unlink "lib/warnings.pm";
-open(WARN, ">warnings.h") || die "Can't create warnings.h: $!\n";
-binmode WARN;
-open(PM, ">lib/warnings.pm") || die "Can't create lib/warnings.pm: $!\n";
-binmode PM;
+my $warn = safer_open("warnings.h-new");
+my $pm = safer_open("lib/warnings.pm-new");
-print WARN <<'EOM' ;
+print $warn <<'EOM' ;
/* -*- buffer-read-only: t -*-
!!!!!!! DO NOT EDIT THIS FILE !!!!!!!
This file is built by warnings.pl
@@ -307,19 +304,19 @@
my $last_ver = 0;
foreach $k (sort { $a <=> $b } keys %ValueToName) {
my ($name, $version) = @{ $ValueToName{$k} };
- print WARN "\n/* Warnings Categories added in Perl $version */\n\n"
+ print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
if $last_ver != $version ;
- print WARN tab(5, "#define WARN_$name"), "$k\n" ;
+ print $warn tab(5, "#define WARN_$name"), "$k\n" ;
$last_ver = $version ;
}
-print WARN "\n" ;
+print $warn "\n" ;
-print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
+print $warn tab(5, '#define WARNsize'), "$warn_size\n" ;
#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) ,
"\"\n" ;
-print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) ,
"\"\n" ;
-print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) ,
"\"\n" ;
+print $warn tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) ,
"\"\n" ;
+print $warn tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) ,
"\"\n" ;
-print WARN <<'EOM';
+print $warn <<'EOM';
#define isLEXWARN_on (PL_curcop->cop_warnings != pWARN_STD)
#define isLEXWARN_off (PL_curcop->cop_warnings == pWARN_STD)
@@ -364,68 +361,70 @@
/* ex: set ro: */
EOM
-close WARN ;
+safer_close $warn;
+rename_if_different("warnings.h-new", "warnings.h");
while (<DATA>) {
last if /^KEYWORDS$/ ;
- print PM $_ ;
+ print $pm $_ ;
}
#$list{'all'} = [ $offset .. 8 * ($warn_size/2) - 1 ] ;
$last_ver = 0;
-print PM "our %Offsets = (\n" ;
+print $pm "our %Offsets = (\n" ;
foreach my $k (sort { $a <=> $b } keys %ValueToName) {
my ($name, $version) = @{ $ValueToName{$k} };
$name = lc $name;
$k *= 2 ;
if ( $last_ver != $version ) {
- print PM "\n";
- print PM tab(4, " # Warnings Categories added in Perl $version");
- print PM "\n\n";
+ print $pm "\n";
+ print $pm tab(4, " # Warnings Categories added in Perl $version");
+ print $pm "\n\n";
}
- print PM tab(4, " '$name'"), "=> $k,\n" ;
+ print $pm tab(4, " '$name'"), "=> $k,\n" ;
$last_ver = $version;
}
-print PM " );\n\n" ;
+print $pm " );\n\n" ;
-print PM "our %Bits = (\n" ;
+print $pm "our %Bits = (\n" ;
foreach $k (sort keys %list) {
my $v = $list{$k} ;
my @list = sort { $a <=> $b } @$v ;
- print PM tab(4, " '$k'"), '=> "',
+ print $pm tab(4, " '$k'"), '=> "',
# mkHex($warn_size, @list),
mkHex($warn_size, map $_ * 2 , @list),
'", # [', mkRange(@list), "]\n" ;
}
-print PM " );\n\n" ;
+print $pm " );\n\n" ;
-print PM "our %DeadBits = (\n" ;
+print $pm "our %DeadBits = (\n" ;
foreach $k (sort keys %list) {
my $v = $list{$k} ;
my @list = sort { $a <=> $b } @$v ;
- print PM tab(4, " '$k'"), '=> "',
+ print $pm tab(4, " '$k'"), '=> "',
# mkHex($warn_size, @list),
mkHex($warn_size, map $_ * 2 + 1 , @list),
'", # [', mkRange(@list), "]\n" ;
}
-print PM " );\n\n" ;
-print PM '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
-print PM '$LAST_BIT = ' . "$index ;\n" ;
-print PM '$BYTES = ' . "$warn_size ;\n" ;
+print $pm " );\n\n" ;
+print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ;
+print $pm '$LAST_BIT = ' . "$index ;\n" ;
+print $pm '$BYTES = ' . "$warn_size ;\n" ;
while (<DATA>) {
- print PM $_ ;
+ print $pm $_ ;
}
-print PM "# ex: set ro:\n";
-close PM ;
+print $pm "# ex: set ro:\n";
+safer_close $pm;
+rename_if_different("lib/warnings.pm-new", "lib/warnings.pm");
__END__
# -*- buffer-read-only: t -*-
End of Patch.
