Change 33878 by [EMAIL PROTECTED] on 2008/05/20 10:00:06
Integrate:
[ 33740]
Stop File::Copy truncating destination files if passed 3 named
arguments by accident. In Copy.t, ensure that all file system calls
die with $! if they fail.
[ 33793]
Subject: [PATCH lib/File/Copy.pm] Use 3-arg open.
From: Abigail <[EMAIL PROTECTED]>
Date: Tue, 6 May 2008 17:38:28 +0200
Message-ID: <[EMAIL PROTECTED]>
Affected files ...
... //depot/maint-5.10/perl/lib/File/Copy.pm#2 integrate
... //depot/maint-5.10/perl/lib/File/Copy.t#2 integrate
Differences ...
==== //depot/maint-5.10/perl/lib/File/Copy.pm#2 (text) ====
Index: perl/lib/File/Copy.pm
--- perl/lib/File/Copy.pm#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/lib/File/Copy.pm 2008-05-20 03:00:06.000000000 -0700
@@ -23,7 +23,7 @@
# package has not yet been updated to work with Perl 5.004, and so it
# would be a Bad Thing for the CPAN module to grab it and replace this
# module. Therefore, we set this module's version higher than 2.0.
-$VERSION = '2.11';
+$VERSION = '2.12';
require Exporter;
@ISA = qw(Exporter);
@@ -79,6 +79,12 @@
my $from = shift;
my $to = shift;
+ my $size;
+ if (@_) {
+ $size = shift(@_) + 0;
+ croak("Bad buffer size for copy: $size\n") unless ($size > 0);
+ }
+
my $from_a_handle = (ref($from)
? (ref($from) eq 'GLOB'
|| UNIVERSAL::isa($from, 'GLOB')
@@ -148,7 +154,7 @@
my $closefrom = 0;
my $closeto = 0;
- my ($size, $status, $r, $buf);
+ my ($status, $r, $buf);
local($\) = '';
my $from_h;
@@ -157,31 +163,30 @@
} else {
$from = _protect($from) if $from =~ /^\s/s;
$from_h = \do { local *FH };
- open($from_h, "< $from\0") or goto fail_open1;
+ open $from_h, "<", $from or goto fail_open1;
binmode $from_h or die "($!,$^E)";
$closefrom = 1;
}
+ # Seems most logical to do this here, in case future changes would want to
+ # make this croak for some reason.
+ unless (defined $size) {
+ $size = tied(*$from_h) ? 0 : -s $from_h || 0;
+ $size = 1024 if ($size < 512);
+ $size = $Too_Big if ($size > $Too_Big);
+ }
+
my $to_h;
if ($to_a_handle) {
$to_h = $to;
} else {
$to = _protect($to) if $to =~ /^\s/s;
$to_h = \do { local *FH };
- open($to_h,"> $to\0") or goto fail_open2;
+ open $to_h, ">", $to or goto fail_open2;
binmode $to_h or die "($!,$^E)";
$closeto = 1;
}
- if (@_) {
- $size = shift(@_) + 0;
- croak("Bad buffer size for copy: $size\n") unless ($size > 0);
- } else {
- $size = tied(*$from_h) ? 0 : -s $from_h || 0;
- $size = 1024 if ($size < 512);
- $size = $Too_Big if ($size > $Too_Big);
- }
-
$! = 0;
for (;;) {
my ($r, $w, $t);
==== //depot/maint-5.10/perl/lib/File/Copy.t#2 (xtext) ====
Index: perl/lib/File/Copy.t
--- perl/lib/File/Copy.t#1~32694~ 2007-12-22 01:23:09.000000000 -0800
+++ perl/lib/File/Copy.t 2008-05-20 03:00:06.000000000 -0700
@@ -1,4 +1,4 @@
-#!./perl
+#!./perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
@@ -11,7 +11,7 @@
my $TB = Test::More->builder;
-plan tests => 60;
+plan tests => 70;
# We're going to override rename() later on but Perl has to see an override
# at compile time to honor it.
@@ -40,14 +40,14 @@
}
# First we create a file
- open(F, ">file-$$") or die;
+ open(F, ">file-$$") or die $!;
binmode F; # for DOSISH platforms, because test 3 copies to stdout
printf F "ok\n";
close F;
copy "file-$$", "copy-$$";
- open(F, "copy-$$") or die;
+ open(F, "copy-$$") or die $!;
$foo = <F>;
close(F);
@@ -77,7 +77,7 @@
require IO::File;
$fh = IO::File->new(">copy-$$") or die "Cannot open copy-$$:$!";
- binmode $fh or die;
+ binmode $fh or die $!;
copy("file-$$",$fh);
$fh->close or die "close: $!";
open(R, "copy-$$") or die; $foo = <R>; close(R);
@@ -86,10 +86,10 @@
require FileHandle;
my $fh = FileHandle->new(">copy-$$") or die "Cannot open copy-$$:$!";
- binmode $fh or die;
+ binmode $fh or die $!;
copy("file-$$",$fh);
$fh->close;
- open(R, "copy-$$") or die; $foo = <R>; close(R);
+ open(R, "copy-$$") or die $!; $foo = <R>; close(R);
is $foo, "ok\n", 'copy(fn, fh): same contents';
unlink "file-$$" or die "unlink: $!";
@@ -108,7 +108,7 @@
ok move("copy-$$", "file-$$"), 'move';
ok -e "file-$$", ' destination exists';
ok !-e "copy-$$", ' source does not';
- open(R, "file-$$") or die; $foo = <R>; close(R);
+ open(R, "file-$$") or die $!; $foo = <R>; close(R);
is $foo, "ok\n", 'contents preserved';
TODO: {
@@ -121,7 +121,7 @@
}
# trick: create lib/ if not exists - not needed in Perl core
- unless (-d 'lib') { mkdir 'lib' or die; }
+ unless (-d 'lib') { mkdir 'lib' or die $!; }
copy "file-$$", "lib";
open(R, "lib/file-$$") or die $!; $foo = <R>; close(R);
is $foo, "ok\n", 'copy(fn, dir): same contents';
@@ -129,7 +129,7 @@
# Do it twice to ensure copying over the same file works.
copy "file-$$", "lib";
- open(R, "lib/file-$$") or die; $foo = <R>; close(R);
+ open(R, "lib/file-$$") or die $!; $foo = <R>; close(R);
is $foo, "ok\n", 'copy over the same file works';
unlink "lib/file-$$" or die "unlink: $!";
@@ -164,8 +164,8 @@
ok !-z "file-$$",
'rt.perl.org 5196: copying to itself would truncate the file';
- unlink "symlink-$$";
- unlink "file-$$";
+ unlink "symlink-$$" or die $!;
+ unlink "file-$$" or die $!;
}
SKIP: {
@@ -185,9 +185,41 @@
ok ! -z "file-$$",
'rt.perl.org 5196: copying to itself would truncate the file';
- unlink "hardlink-$$";
- unlink "file-$$";
+ unlink "hardlink-$$" or die $!;
+ unlink "file-$$" or die $!;
}
+
+ open(F, ">file-$$") or die $!;
+ binmode F;
+ print F "this is file\n";
+ close F;
+
+ my $copy_msg = "this is copy\n";
+ open(F, ">copy-$$") or die $!;
+ binmode F;
+ print F $copy_msg;
+ close F;
+
+ my @warnings;
+ local $SIG{__WARN__} = sub { push @warnings, join '', @_ };
+
+ # pie-$$ so that we force a non-constant, else the numeric conversion (of 0)
+ # is cached and we don't get a warning the second time round
+ is eval { copy("file-$$", "copy-$$", "pie-$$"); 1 }, undef,
+ "a bad buffer size fails to copy";
+ like $@, qr/Bad buffer size for copy/, "with a helpful error message";
+ unless (is scalar @warnings, 1, "There is 1 warning") {
+ diag $_ foreach @warnings;
+ }
+
+ is -s "copy-$$", length $copy_msg, "but does not truncate the destination";
+ open(F, "copy-$$") or die $!;
+ $foo = <F>;
+ close(F);
+ is $foo, $copy_msg, "nor change the destination's contents";
+
+ unlink "file-$$" or die $!;
+ unlink "copy-$$" or die $!;
}
End of Patch.
