From: Nicholas Clark Date: Thu, 24 Apr 2008 17:04:58 +0000 (+0000) Subject: Stop File::Copy truncating destination files if passed 3 named X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=671637fed42237fcb843f592c249ac1359521292;p=p5sagit%2Fp5-mst-13.2.git 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. p4raw-id: //depot/perl@33740 --- diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 1520e0a..41a8fa2 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -23,7 +23,7 @@ sub mv; # 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 @@ sub copy { 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 @@ sub copy { my $closefrom = 0; my $closeto = 0; - my ($size, $status, $r, $buf); + my ($status, $r, $buf); local($\) = ''; my $from_h; @@ -162,6 +168,14 @@ sub copy { $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; @@ -173,15 +187,6 @@ sub copy { $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); diff --git a/lib/File/Copy.t b/lib/File/Copy.t index 84abfd5..e2f1101 100755 --- a/lib/File/Copy.t +++ b/lib/File/Copy.t @@ -1,4 +1,4 @@ -#!./perl +#!./perl -w BEGIN { if( $ENV{PERL_CORE} ) { @@ -11,7 +11,7 @@ use Test::More; 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 @@ for my $cross_partition_test (0..1) { } # 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 = ; close(F); @@ -77,7 +77,7 @@ for my $cross_partition_test (0..1) { 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 = ; close(R); @@ -86,10 +86,10 @@ for my $cross_partition_test (0..1) { 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 = ; close(R); + open(R, "copy-$$") or die $!; $foo = ; close(R); is $foo, "ok\n", 'copy(fn, fh): same contents'; unlink "file-$$" or die "unlink: $!"; @@ -108,7 +108,7 @@ for my $cross_partition_test (0..1) { ok move("copy-$$", "file-$$"), 'move'; ok -e "file-$$", ' destination exists'; ok !-e "copy-$$", ' source does not'; - open(R, "file-$$") or die; $foo = ; close(R); + open(R, "file-$$") or die $!; $foo = ; close(R); is $foo, "ok\n", 'contents preserved'; TODO: { @@ -121,7 +121,7 @@ for my $cross_partition_test (0..1) { } # 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 = ; close(R); is $foo, "ok\n", 'copy(fn, dir): same contents'; @@ -129,7 +129,7 @@ for my $cross_partition_test (0..1) { # Do it twice to ensure copying over the same file works. copy "file-$$", "lib"; - open(R, "lib/file-$$") or die; $foo = ; close(R); + open(R, "lib/file-$$") or die $!; $foo = ; close(R); is $foo, "ok\n", 'copy over the same file works'; unlink "lib/file-$$" or die "unlink: $!"; @@ -164,8 +164,8 @@ for my $cross_partition_test (0..1) { 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 @@ for my $cross_partition_test (0..1) { 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 = ; + close(F); + is $foo, $copy_msg, "nor change the destination's contents"; + + unlink "file-$$" or die $!; + unlink "copy-$$" or die $!; }