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.

p4raw-id: //depot/perl@33538

diff --git a/embed.pl b/embed.pl
index 147c8e2..1da5f44 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -79,15 +79,12 @@ sub walk_table (&@) {
     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-new" or die "Can't open $filename: $!";
-       binmode F;
-       $F = \*F;
+       $F = safer_open("$filename-new");
     }
     print $F $leader if $leader;
     seek IN, 0, 0;             # so we may restart
@@ -112,7 +109,7 @@ sub walk_table (&@) {
     print $F $trailer if $trailer;
     unless (ref $filename) {
        close $F or die "Error closing $filename: $!";
-       safer_rename("$filename-new", $filename);
+       rename_if_different("$filename-new", $filename);
     }
 }
 
@@ -389,10 +386,9 @@ sub multoff ($$) {
     return hide("PL_$pre$sym", "PL_$sym");
 }
 
-open(EM, '> embed.h-new') 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.) */
 
@@ -456,18 +452,18 @@ walk_table {
     # 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 */
 
@@ -534,26 +530,26 @@ walk_table {
     # 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 */
 
@@ -561,7 +557,7 @@ print EM <<'END';
 
 END
 
-print EM <<'END';
+print $em <<'END';
 
 /* Compatibility stubs.  Compile extensions with -DPERL_NOCOMPAT to
    disable them.
@@ -641,14 +637,12 @@ print EM <<'END';
 /* ex: set ro: */
 END
 
-close(EM) or die "Error closing EM: $!";
-safer_rename('embed.h-new', 'embed.h');
+close($em) or die "Error closing EM: $!";
+rename_if_different('embed.h-new', 'embed.h');
 
-open(EM, '> embedvar.h-new')
-    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.) */
 
@@ -677,10 +671,10 @@ print EM do_not_edit ("embedvar.h"), <<'END';
 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 */
 
@@ -689,14 +683,14 @@ print EM <<'END';
 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 */
 
@@ -705,21 +699,21 @@ print EM <<'END';
 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 */
 
@@ -728,25 +722,23 @@ print EM <<'END';
 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_rename('embedvar.h-new', 'embedvar.h');
+close($em) or die "Error closing EM: $!";
+rename_if_different('embedvar.h-new', 'embedvar.h');
 
-open(CAPI, '> perlapi.c-new') or die "Can't create perlapi.c: $!\n";
-binmode CAPI;
-open(CAPIH, '> perlapi.h-new') 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__
@@ -851,14 +843,14 @@ END_EXTERN_C
 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 */
@@ -867,10 +859,10 @@ print CAPIH <<'EOT';
 
 /* ex: set ro: */
 EOT
-close CAPIH or die "Error closing CAPIH: $!";
-safer_rename('perlapi.h-new', 'perlapi.h');
+close $capih or die "Error closing 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"
@@ -949,8 +941,8 @@ END_EXTERN_C
 /* ex: set ro: */
 EOT
 
-close(CAPI) or die "Error closing CAPI: $!";
-safer_rename('perlapi.c-new', 'perlapi.c');
+close($capi) or die "Error closing 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

diff --git a/keywords.pl b/keywords.pl
index 8e7a678..3603570 100755 (executable)
--- a/keywords.pl
+++ b/keywords.pl
@@ -3,9 +3,8 @@ use strict;
 
 require 'regen_lib.pl';
 
-open(KW, ">keywords.h-new") || 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,11 +34,11 @@ while (<DATA>) {
     print &tab(5, "#define KEY_$keyword"), $keynum++, "\n";
 }
 
-print KW "\n/* ex: set ro: */\n";
+print $kw "\n/* ex: set ro: */\n";
 
-close KW or die "Error closing keywords.h: $!";
+close $kw or die "Error closing keywords.h-new: $!";
 
-safer_rename("keywords.h-new", "keywords.h");
+rename_if_different("keywords.h-new", "keywords.h");
 
 ###########################################################################
 sub tab {

diff --git a/opcode.pl b/opcode.pl
index 69ef23c..08c9e83 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -8,11 +8,9 @@ BEGIN {
 
 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.
 
@@ -128,7 +126,7 @@ PERL_PPDEF(Perl_unimplemented_op)
 
 END
 
-print ON <<"END";
+print $on <<"END";
 /* -*- buffer-read-only: t -*-
  *
  *    opnames.h
@@ -150,14 +148,14 @@ END
 
 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_\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.
 
@@ -395,7 +393,7 @@ END
 
 # Emit OP_IS_* macros
 
-print ON <<EO_OP_IS_COMMENT;
+print $on <<EO_OP_IS_COMMENT;
 
 /* the OP_IS_(SOCKET|FILETEST) macros are optimized to a simple range
     check because all the member OPs are contiguous in opcode.pl
@@ -419,42 +417,40 @@ sub gen_op_is_macro {
        my $last = pop @rest;   # @rest slurped, get its last
        die "Invalid range of ops: $first .. $last\n" unless $last;
 
-       print ON "#define $macname(op)  \\\n\t(";
+       print $on "#define $macname(op) \\\n\t(";
 
        # verify that op-ct matches 1st..last range (and fencepost)
        # (we know there are no dups)
        if ( $op_is->{$last} - $op_is->{$first} == scalar @rest + 1) {
            
            # contiguous ops -> optimized version
-           print ON "(op) >= OP_" . uc($first) . " && (op) <= OP_" . uc($last);
-           print ON ")\n\n";
+           print $on "(op) >= OP_" . uc($first) . " && (op) <= OP_" . uc($last);
+           print $on ")\n\n";
        }
        else {
-           print ON join(" || \\\n\t ",
+           print $on join(" || \\\n\t ",
                          map { "(op) == OP_" . uc() } sort keys %$op_is);
-           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: $!\n";
-close ON or die "Error closing opnames.h: $!\n";
+close $oc or die "Error closing $opcode_new: $!\n";
+close $on or die "Error closing $opname_new: $!\n";
 
-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: $!\n";
-binmode PP;
-open PPSYM, ">$pp_sym_new" or die "Error creating $pp_sym_new: $!\n";
-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
@@ -463,7 +459,7 @@ print PP <<"END";
 
 END
 
-print PPSYM <<"END";
+print $ppsym <<"END";
 # -*- buffer-read-only: t -*-
 #
 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
@@ -475,27 +471,27 @@ END
 
 
 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: $!\n";
-close PPSYM or die "Error closing pp.sym: $!\n";
+close $pp or die "Error closing pp_proto.h-new: $!\n";
+close $ppsym or die "Error closing pp.sym-new: $!\n";
 
-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') {

diff --git a/reentr.pl b/reentr.pl
index aea679d..be15c40 100644 (file)
--- a/reentr.pl
+++ b/reentr.pl
@@ -41,9 +41,8 @@ my %map = (
 
 
 # safer_unlink 'reentr.h';
-die "reentr.pl: $!" unless open(H, ">reentr.h-new");
-binmode H;
-select H;
+my $h = safer_open("reentr.h-new");
+select $h;
 print <<EOF;
 /* -*- buffer-read-only: t -*-
  *
@@ -332,7 +331,7 @@ close DATA;
 
 # Prepare to continue writing the reentr.h.
 
-select H;
+select $h;
 
 {
     # Write out all the known prototype signatures.
@@ -788,15 +787,14 @@ typedef struct {
 /* ex: set ro: */
 EOF
 
-close(H);
-safer_rename('reentr.h-new', 'reentr.h');
+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-new");
-binmode C;
-select C;
+my $c = safer_open("reentr.c-new");
+select $c;
 print <<EOF;
 /* -*- buffer-read-only: t -*-
  *
@@ -1091,8 +1089,8 @@ Perl_reentrant_retry(const char *f, ...)
 /* ex: set ro: */
 EOF
 
-close(C);
-safer_rename('reentr.c-new', 'reentr.c');
+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

diff --git a/regcomp.pl b/regcomp.pl
index defbb5f..b6fc11d 100644 (file)
--- a/regcomp.pl
+++ b/regcomp.pl
@@ -68,11 +68,9 @@ my $tmp_h = 'tmp_reg.h';
 
 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 @@ EOP
 
 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 @@ EOP
 
 $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 @@ while (++$ind <= $lastregop) {
   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 @@ $ind = 0;
 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 @@ my $sym = "";
 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 @@ while (<$fh>) {
     }
 }    
 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: $!";
+close $out or die "close $tmp_h: $!";
 
-safer_rename $tmp_h, 'regnodes.h';
+rename_if_different $tmp_h, 'regnodes.h';

diff --git a/regen_lib.pl b/regen_lib.pl
index 896a9ad..8249265 100644 (file)
--- a/regen_lib.pl
+++ b/regen_lib.pl
@@ -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
 
@@ -15,24 +17,6 @@ if ($Is_NetWare) {
 
 $Needs_Write = $Is_OS2 || $Is_W32 || $Is_Cygwin || $Is_NetWare;
 
-eval "use Digest::MD5 'md5'; 1;"
-    or warn "Digest::MD5 unavailable, doing unconditional regen\n";
-
-sub cksum {
-    my $pl = shift;
-    my ($buf, $cksum);
-    local *FH;
-    if (open(FH, $pl)) {
-       local $/;
-       $buf = <FH>;
-       $cksum = defined &md5 ? md5($buf) : 0;
-       close FH;
-    } else {
-       warn "$0: $pl: $!\n";
-    }
-    return $cksum;
-}
-
 sub safer_unlink {
   my @names = @_;
   my $cnt = 0;
@@ -56,18 +40,10 @@ sub safer_rename_silent {
   rename $from, $to;
 }
 
-sub safer_rename_always {
-  my ($from, $to) = @_;
-  safer_rename_silent($from, $to) or die "renaming $from to $to: $!";
-}
-
-sub safer_rename {
+sub rename_if_different {
   my ($from, $to) = @_;
 
-  my $fc = cksum($from);
-  my $tc = cksum($to);
-  
-  if ($fc and $fc eq $tc) {
+  if (compare($from, $to) == 0) {
       warn "no changes between '$from' & '$to'\n";
       safer_unlink($from);
       return;
@@ -75,4 +51,14 @@ sub safer_rename {
   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: $!";
+    binmode $fh;
+    $fh;
+}
+
 1;

diff --git a/warnings.pl b/warnings.pl
index b639fc6..669d13c 100644 (file)
--- a/warnings.pl
+++ b/warnings.pl
@@ -250,12 +250,10 @@ if (@ARGV && $ARGV[0] eq "tree")
     exit ;
 }
 
-open(WARN, ">warnings.h-new") || die "Can't create warnings.h: $!\n";
-open(PM, ">lib/warnings.pm-new") || die "Can't create lib/warnings.pm: $!\n";
-binmode WARN;
-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 +305,19 @@ my $k ;
 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,70 +362,70 @@ print WARN <<'EOM';
 /* ex: set ro: */
 EOM
 
-close WARN ;
-safer_rename("warnings.h-new", "warnings.h");
+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 ;
-safer_rename("lib/warnings.pm-new", "lib/warnings.pm");
+print $pm "# ex: set ro:\n";
+close $pm;
+rename_if_different("lib/warnings.pm-new", "lib/warnings.pm");
 
 __END__
 # -*- buffer-read-only: t -*-