$F = $filename;
}
else {
- $F = safer_open("$filename-new");
+ $F = safer_open("$filename-new", $filename);
print $F do_not_edit ($filename);
}
foreach (@embed) {
}
print $F $trailer if $trailer;
unless (ref $filename) {
- safer_close($F);
- rename_if_different("$filename-new", $filename);
+ close_and_rename($F);
}
}
# generate proto.h
{
- my $pr = safer_open('proto.h-new');
+ my $pr = safer_open('proto.h-new', 'proto.h');
print $pr do_not_edit ("proto.h"), "START_EXTERN_C\n";
my $ret;
/* ex: set ro: */
EOF
- safer_close($pr);
- rename_if_different('proto.h-new', 'proto.h');
+ close_and_rename($pr);
}
# generates global.sym (API export list)
return hide("PL_$pre$sym", "PL_$sym");
}
-my $em = safer_open('embed.h-new');
+my $em = safer_open('embed.h-new', 'embed.h');
print $em do_not_edit ("embed.h"), <<'END';
/* (Doing namespace management portably in C is really gross.) */
/* ex: set ro: */
END
-safer_close($em);
-rename_if_different('embed.h-new', 'embed.h');
+close_and_rename($em);
-$em = safer_open('embedvar.h-new');
+$em = safer_open('embedvar.h-new', 'embedvar.h');
print $em do_not_edit ("embedvar.h"), <<'END';
/* (Doing namespace management portably in C is really gross.) */
/* ex: set ro: */
END
-safer_close($em);
-rename_if_different('embedvar.h-new', 'embedvar.h');
+close_and_rename($em);
-my $capi = safer_open('perlapi.c-new');
-my $capih = safer_open('perlapi.h-new');
+my $capi = safer_open('perlapi.c-new', 'perlapi.c');
+my $capih = safer_open('perlapi.h-new', 'perlapi.h');
print $capih do_not_edit ("perlapi.h"), <<'EOT';
/* declare accessor functions for Perl variables */
/* ex: set ro: */
EOT
-safer_close($capih);
-rename_if_different('perlapi.h-new', 'perlapi.h');
+close_and_rename($capih);
my $warning = do_not_edit ("perlapi.c");
$warning =~ s! \*/\n! *
/* ex: set ro: */
EOT
-safer_close($capi);
-rename_if_different('perlapi.c-new', 'perlapi.c');
+close_and_rename($capi);
# ex: set ts=8 sts=4 sw=4 noet:
require 'regen/regen_lib.pl';
-my $kw = safer_open("keywords.h-new");
+my $kw = safer_open('keywords.h-new', 'keywords.h');
select $kw;
print read_only_top(lang => 'C', by => 'regen/keywords.pl', from => 'its data',
print $kw "\n/* ex: set ro: */\n";
-safer_close($kw);
-
-rename_if_different("keywords.h-new", "keywords.h");
+close_and_rename($kw);
###########################################################################
sub tab {
require 'regen/regen_lib.pl';
}
-my $opcode_new = 'opcode.h-new';
-my $opname_new = 'opnames.h-new';
-my $oc = safer_open($opcode_new);
-my $on = safer_open($opname_new);
+my $oc = safer_open('opcode.h-new', 'opcode.h');
+my $on = safer_open('opnames.h-new', 'opnames.h');
select $oc;
# Read data.
foreach ($oc, $on) {
print $_ "/* ex: set ro: */\n";
- safer_close($_);
+ close_and_rename($_);
}
-rename_if_different $opcode_new, 'opcode.h';
-rename_if_different $opname_new, 'opnames.h';
-
-my $pp_proto_new = 'pp_proto.h-new';
-
-my $pp = safer_open($pp_proto_new);
+my $pp = safer_open('pp_proto.h-new', 'pp_proto.h');
print $pp read_only_top(lang => 'C', by => 'opcode.pl', from => 'its data');
}
print $pp "\n/* ex: set ro: */\n";
-safer_close($pp);
-
-rename_if_different $pp_proto_new, 'pp_proto.h';
+close_and_rename($pp);
###########################################################################
sub tab {
push @names, $name;
}
-my $c = safer_open("overload.c-new");
-my $h = safer_open("overload.h-new");
+my $c = safer_open('overload.c-new', 'overload.c');
+my $h = safer_open('overload.h-new', 'overload.h');
mkdir("lib/overload", 0777) unless -d 'lib/overload';
-my $p = safer_open('lib/overload/numbers.pm-new');
+my $p = safer_open('lib/overload/numbers.pm-new', 'lib/overload/numbers.pm');
select $p;
};
EOT
-safer_close($h);
-safer_close($c);
-safer_close($p);
-rename_if_different("overload.c-new", "overload.c");
-rename_if_different("overload.h-new","overload.h");
-rename_if_different('lib/overload/numbers.pm-new', 'lib/overload/numbers.pm');
+close_and_rename($h);
+close_and_rename($c);
+close_and_rename($p);
__DATA__
# Fallback should be the first
# Example #3: S_CBI means type func_r(const char*, char*, int)
-my $h = safer_open("reentr.h-new");
+my $h = safer_open('reentr.h-new', 'reentr.h');
select $h;
print read_only_top(lang => 'C', by => 'regen/reentr.pl',
from => 'data in regen/reentr.pl',
/* ex: set ro: */
EOF
-safer_close($h);
-rename_if_different('reentr.h-new', 'reentr.h');
+close_and_rename($h);
# Prepare to write the reentr.c.
-my $c = safer_open("reentr.c-new");
+my $c = safer_open('reentr.c-new', 'reentr.c');
select $c;
my $top = read_only_top(lang => 'C', by => 'regen/reentr.pl',
from => 'data in regen/reentr.pl',
/* ex: set ro: */
EOF
-safer_close($c);
-rename_if_different('reentr.c-new', 'reentr.c');
+close_and_rename($c);
__DATA__
asctime S |time |const struct tm|B_SB|B_SBI|I_SB|I_SBI
EOP
}
-my $tmp_h = 'regnodes.h-new';
-
-my $out = safer_open($tmp_h);
+my $out = safer_open('regnodes.h-new', 'regnodes.h');
print $out read_only_top(lang => 'C', by => 'regen/regcomp.pl',
from => 'regcomp.sym');
print $out <<EOP;
/* ex: set ro: */
EOP
-safer_close($out);
-
-rename_if_different $tmp_h, 'regnodes.h';
+close_and_rename($out);
# Saf*er*, but not totally safe. And assumes always open for output.
sub safer_open {
- my $name = shift;
+ my ($name, $final_name) = @_;
if (-f $name) {
unlink $name or die "$name exists but can't unlink: $!";
}
my $fh = gensym;
open $fh, ">$name" or die "Can't create $name: $!";
*{$fh}->{name} = $name;
+ *{$fh}->{final_name} = $final_name if defined $final_name;
binmode $fh;
$fh;
}
return $cooked;
}
+sub close_and_rename {
+ my $fh = shift;
+ my $name = *{$fh}->{name};
+ die "No final name specified at open time for $name"
+ unless *{$fh}->{final_name};
+ safer_close($fh);
+ rename_if_different($name, *{$fh}->{final_name});
+}
+
1;
exit ;
}
-my $warn = safer_open("warnings.h-new");
-my $pm = safer_open("lib/warnings.pm-new");
+my $warn = safer_open('warnings.h-new', 'warnings.h');
+my $pm = safer_open('lib/warnings.pm-new', 'lib/warnings.pm');
print $pm read_only_top(lang => 'Perl', by => 'regen/warnings.pl');
print $warn read_only_top(lang => 'C', by => 'regen/warnings.pl'), <<'EOM';
/* ex: set ro: */
EOM
-safer_close $warn;
-rename_if_different("warnings.h-new", "warnings.h");
+close_and_rename($warn);
while (<DATA>) {
last if /^KEYWORDS$/ ;
}
print $pm "# ex: set ro:\n";
-safer_close $pm;
-rename_if_different("lib/warnings.pm-new", "lib/warnings.pm");
+close_and_rename($pm);
__END__
package warnings;