On Tue, Jul 12, 2005 at 06:19:48PM -0400, Randy W. Sims wrote:
> Michael G Schwern via RT wrote:
> >The attached patch changes copy() so that it carps instead of croaking
> >when its asked to copy identical files. This is better because asking
> >to copy identical files is not an error (and the operation suceeds) its
> >just dubious.
>
> Shouldn't it be fatal if the destination is a link? If the user expects
> to copy over a link in order to edit the copy, it would issue a warning
> and merrily trash the original file.
That was the original behavior before the link check and croak was put in.
The link check still remains. copy() simply warns and returns true rather
than trash the original file.
An alternative behavior is for copy() to unlink the destination if it is a
link and then copy() the source. This runs counter to what cp does and the
behavior of copy() generally honoring links.
Finally, copy could warn and return false in the view that if failed to
make a real copy of the file. It certainly shouldn't die, leave the error
handling to the caller.
I'm liking the final choice. Here's another patch.
--
Michael G Schwern [EMAIL PROTECTED] http://www.pobox.com/~schwern
ROCKS FALL! EVERYONE DIES!
http://www.somethingpositive.net/sp05032002.shtml
--- lib/File/Copy.pm 2005/07/12 21:28:49 1.1
+++ lib/File/Copy.pm 2005/07/12 22:50:36
@@ -37,6 +37,11 @@
goto &Carp::croak;
}
+sub carp {
+ require Carp;
+ goto &Carp::carp;
+}
+
my $macfiles;
if ($^O eq 'MacOS') {
$macfiles = eval { require Mac::MoreFiles };
@@ -78,7 +83,10 @@
: (ref(\$to) eq 'GLOB'));
if ($from eq $to) { # works for references, too
- croak("'$from' and '$to' are identical (not copied)");
+ carp("'$from' and '$to' are identical (not copied)");
+ # The "copy" was a success as the source and destination contain
+ # the same data.
+ return 1;
}
if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
@@ -87,7 +95,8 @@
if (@fs) {
my @ts = stat($to);
if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) {
- croak("'$from' and '$to' are identical (not copied)");
+ carp("'$from' and '$to' are identical (not copied)");
+ return 0;
}
}
}
@@ -182,7 +191,10 @@
}
sub move {
+ croak("Usage: move(FROM, TO) ") unless @_ == 2;
+
my($from,$to) = @_;
+
my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts);
if (-d $to && ! -d $from) {
@@ -209,6 +221,7 @@
{
local $@;
eval {
+ local $SIG{__DIE__};
copy($from,$to) or die;
my($atime, $mtime) = (stat($from))[8,9];
utime($atime, $mtime, $to);
--- lib/File/Copy.t 2005/07/12 21:30:56 1.1
+++ lib/File/Copy.t 2005/07/12 22:50:43
@@ -9,7 +9,7 @@
my $TB = Test::More->builder;
-plan tests => 48;
+plan tests => 60;
# We're going to override rename() later on but Perl has to see an override
# at compile time to honor it.
@@ -19,6 +19,16 @@
use File::Copy;
use Config;
+
+foreach my $code ("copy()", "copy('arg')", "copy('arg', 'arg', 'arg', 'arg')",
+ "move()", "move('arg')", "move('arg', 'arg', 'arg')"
+ )
+{
+ eval $code;
+ like $@, qr/^Usage: /;
+}
+
+
for my $cross_partition_test (0..1) {
{
# Simulate a cross-partition copy/move by forcing rename to
@@ -92,7 +102,7 @@
# The destination file will reflect the same difficulties.
my $mtime = (stat("copy-$$"))[9];
- ok move "copy-$$", "file-$$", 'move';
+ 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);
@@ -114,9 +124,14 @@
is $foo, "ok\n";
unlink "lib/file-$$" or die "unlink: $!";
- eval { copy("file-$$", "file-$$") };
- like $@, qr/are identical/;
- ok -s "file-$$";
+ {
+ my $warnings = '';
+ local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+ ok copy("file-$$", "file-$$");
+
+ like $warnings, qr/are identical/;
+ ok -s "file-$$";
+ }
move "file-$$", "lib";
open(R, "lib/file-$$") or die "open lib/file-$$: $!"; $foo = <R>; close(R);
@@ -131,8 +146,12 @@
print F "dummy content\n";
close F;
symlink("file-$$", "symlink-$$") or die $!;
- eval { copy("file-$$", "symlink-$$") };
- like $@, qr/are identical/;
+
+ my $warnings = '';
+ local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+ ok !copy("file-$$", "symlink-$$");
+
+ like $warnings, qr/are identical/;
ok !-z "file-$$",
'rt.perl.org 5196: copying to itself would truncate the file';
@@ -147,8 +166,12 @@
print F "dummy content\n";
close F;
link("file-$$", "hardlink-$$") or die $!;
- eval { copy("file-$$", "hardlink-$$") };
- like $@, qr/are identical/;
+
+ my $warnings = '';
+ local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
+ ok !copy("file-$$", "hardlink-$$");
+
+ like $warnings, qr/are identical/;
ok ! -z "file-$$",
'rt.perl.org 5196: copying to itself would truncate the file';
