In Perl_vms_start_glob, when we don't have any matches and thus

[p5sagit/p5-mst-13.2.git] / lib / File / Copy.pm

diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm
index d87c191..1520e0a 100644 (file)
--- 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.09';
+$VERSION = '2.11';
 
 require Exporter;
 @ISA = qw(Exporter);
@@ -64,6 +64,14 @@ sub _catname {
     return File::Spec->catfile($to, basename($from));
 }
 
+# _eq($from, $to) tells whether $from and $to are identical
+# works for strings and references
+sub _eq {
+    return $_[0] == $_[1] if ref $_[0] && ref $_[1];
+    return $_[0] eq $_[1] if !ref $_[0] && !ref $_[1];
+    return "";
+}
+
 sub copy {
     croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
       unless(@_ == 2 || @_ == 3);
@@ -82,7 +90,7 @@ sub copy {
                             || UNIVERSAL::isa($to, 'IO::Handle'))
                         : (ref(\$to) eq 'GLOB'));
 
-    if ($from eq $to) { # works for references, too
+    if (_eq($from, $to)) { # works for references, too
        carp("'$from' and '$to' are identical (not copied)");
         # The "copy" was a success as the source and destination contain
         # the same data.
@@ -90,7 +98,7 @@ sub copy {
     }
 
     if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
-       !($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) {
+       !($^O eq 'MSWin32' || $^O eq 'os2')) {
        my @fs = stat($from);
        if (@fs) {
            my @ts = stat($to);
@@ -114,7 +122,28 @@ sub copy {
        && !($from_a_handle && $^O eq 'NetWare')
        )
     {
-       return syscopy($from, $to);
+       my $copy_to = $to;
+
+        if ($^O eq 'VMS' && -e $from) {
+
+            if (! -d $to && ! -d $from) {
+
+                # VMS has sticky defaults on extensions, which means that
+                # if there is a null extension on the destination file, it
+                # will inherit the extension of the source file
+                # So add a '.' for a null extension.
+
+                $copy_to = VMS::Filespec::vmsify($to);
+                my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
+                $file = $file . '.' unless ($file =~ /(?<!\^)\./);
+                $copy_to = File::Spec->catpath($vol, $dirs, $file);
+
+                # Get rid of the old versions to be like UNIX
+                1 while unlink $copy_to;
+            }
+        }
+
+        return syscopy($from, $copy_to);
     }
 
     my $closefrom = 0;
@@ -207,13 +236,34 @@ sub move {
       # will not rename with overwrite
       unlink $to;
     }
-    return 1 if rename $from, $to;
+
+    my $rename_to = $to;
+    if (-$^O eq 'VMS' && -e $from) {
+
+        if (! -d $to && ! -d $from) {
+            # VMS has sticky defaults on extensions, which means that
+            # if there is a null extension on the destination file, it
+            # will inherit the extension of the source file
+            # So add a '.' for a null extension.
+
+            $rename_to = VMS::Filespec::vmsify($to);
+            my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
+            $file = $file . '.' unless ($file =~ /(?<!\^)\./);
+            $rename_to = File::Spec->catpath($vol, $dirs, $file);
+
+            # Get rid of the old versions to be like UNIX
+            1 while unlink $rename_to;
+        }
+    }
+
+    return 1 if rename $from, $rename_to;
 
     # Did rename return an error even though it succeeded, because $to
     # is on a remote NFS file system, and NFS lost the server's ack?
     return 1 if defined($fromsz) && !-e $from &&           # $from disappeared
                 (($tosz2,$tomt2) = (stat($to))[7,9]) &&    # $to's there
-                ($tosz1 != $tosz2 or $tomt1 != $tomt2) &&  #   and changed
+                  ((!defined $tosz1) ||                           #  not before or
+                  ($tosz1 != $tosz2 or $tomt1 != $tomt2)) &&  #   was changed
                 $tosz2 == $fromsz;                         # it's all there
 
     ($tosz1,$tomt1) = (stat($to))[7,9];  # just in case rename did something
@@ -336,9 +386,9 @@ filehandle to a file, use C<binmode> on the filehandle.
 
 An optional third parameter can be used to specify the buffer
 size used for copying. This is the number of bytes from the
-first file, that wil be held in memory at any given time, before
+first file, that will be held in memory at any given time, before
 being written to the second file. The default buffer size depends
-upon the file, but will generally be the whole file (up to 2Mb), or
+upon the file, but will generally be the whole file (up to 2MB), or
 1k for filehandles that do not reference files (eg. sockets).
 
 You may use the syntax C<use File::Copy "cp"> to get at the
@@ -376,7 +426,7 @@ this calls C<Win32::CopyFile>.
 On Mac OS (Classic), C<syscopy> calls C<Mac::MoreFiles::FSpFileCopy>,
 if available.
 
-B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>
+B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
 
 If both arguments to C<copy> are not file handles,
 then C<copy> will perform a "system copy" of
@@ -457,7 +507,7 @@ E.g.
   copy("file1", ":tmp:file1"); # ok, partial path
   copy("file1", "DataHD:");    # creates DataHD:file1
 
-  move("MacintoshHD:fileA", "DataHD:fileB"); # moves (don't copies) files from one
+  move("MacintoshHD:fileA", "DataHD:fileB"); # moves (doesn't copy) files from one
                                              # volume to another
 
 =back