summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/File/Copy.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Copy.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/File/Copy.pm156
1 files changed, 32 insertions, 124 deletions
diff --git a/Master/tlpkg/tlperl/lib/File/Copy.pm b/Master/tlpkg/tlperl/lib/File/Copy.pm
index 19a5838c0a8..95fb4e18f34 100644
--- a/Master/tlpkg/tlperl/lib/File/Copy.pm
+++ b/Master/tlpkg/tlperl/lib/File/Copy.pm
@@ -22,7 +22,7 @@ sub syscopy;
sub cp;
sub mv;
-$VERSION = '2.26';
+$VERSION = '2.30';
require Exporter;
@ISA = qw(Exporter);
@@ -41,44 +41,6 @@ sub carp {
goto &Carp::carp;
}
-# Look up the feature settings on VMS using VMS::Feature when available.
-
-my $use_vms_feature = 0;
-BEGIN {
- if ($^O eq 'VMS') {
- if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
- $use_vms_feature = 1;
- }
- }
-}
-
-# Need to look up the UNIX report mode. This may become a dynamic mode
-# in the future.
-sub _vms_unix_rpt {
- my $unix_rpt;
- if ($use_vms_feature) {
- $unix_rpt = VMS::Feature::current("filename_unix_report");
- } else {
- my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
- $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
- }
- return $unix_rpt;
-}
-
-# Need to look up the EFS character set mode. This may become a dynamic
-# mode in the future.
-sub _vms_efs {
- my $efs;
- if ($use_vms_feature) {
- $efs = VMS::Feature::current("efs_charset");
- } else {
- my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
- $efs = $env_efs =~ /^[ET1]/i;
- }
- return $efs;
-}
-
-
sub _catname {
my($from, $to) = @_;
if (not defined &basename) {
@@ -158,50 +120,21 @@ sub copy {
&& !($from_a_handle && $^O eq 'NetWare')
)
{
- my $copy_to = $to;
-
- if ($^O eq 'VMS' && -e $from) {
-
- if (! -d $to && ! -d $from) {
-
- my $vms_efs = _vms_efs();
- my $unix_rpt = _vms_unix_rpt();
- my $unix_mode = 0;
- my $from_unix = 0;
- $from_unix = 1 if ($from =~ /^\.\.?$/);
- my $from_vms = 0;
- $from_vms = 1 if ($from =~ m#[\[<\]]#);
-
- # Need to know if we are in Unix mode.
- if ($from_vms == $from_unix) {
- $unix_mode = $unix_rpt;
- } else {
- $unix_mode = $from_unix;
- }
-
- # 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.
-
- # In unix_rpt mode, the trailing dot should not be added.
-
- if ($vms_efs) {
- $copy_to = $to;
- } else {
- $copy_to = VMS::Filespec::vmsify($to);
- }
- my ($vol, $dirs, $file) = File::Spec->splitpath($copy_to);
- $file = $file . '.'
- unless (($file =~ /(?<!\^)\./) || $unix_rpt);
- $copy_to = File::Spec->catpath($vol, $dirs, $file);
-
- # Get rid of the old versions to be like UNIX
- 1 while unlink $copy_to;
- }
+ if ($^O eq 'VMS' && -e $from
+ && ! -d $to && ! -d $from) {
+
+ # VMS natively inherits path components from the source of a
+ # copy, but we want the Unixy behavior of inheriting from
+ # the current working directory. Also, default in a trailing
+ # dot for null file types.
+
+ $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
+
+ # Get rid of the old versions to be like UNIX
+ 1 while unlink $to;
}
- return syscopy($from, $copy_to) || 0;
+ return syscopy($from, $to) || 0;
}
my $closefrom = 0;
@@ -331,49 +264,21 @@ sub _move {
unlink $to;
}
- my $rename_to = $to;
- if (-$^O eq 'VMS' && -e $from) {
-
- if (! -d $to && ! -d $from) {
-
- my $vms_efs = _vms_efs();
- my $unix_rpt = _vms_unix_rpt();
- my $unix_mode = 0;
- my $from_unix = 0;
- $from_unix = 1 if ($from =~ /^\.\.?$/);
- my $from_vms = 0;
- $from_vms = 1 if ($from =~ m#[\[<\]]#);
-
- # Need to know if we are in Unix mode.
- if ($from_vms == $from_unix) {
- $unix_mode = $unix_rpt;
- } else {
- $unix_mode = $from_unix;
- }
-
- # 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.
-
- # In unix_rpt mode, the trailing dot should not be added.
-
- if ($vms_efs) {
- $rename_to = $to;
- } else {
- $rename_to = VMS::Filespec::vmsify($to);
- }
- my ($vol, $dirs, $file) = File::Spec->splitpath($rename_to);
- $file = $file . '.'
- unless (($file =~ /(?<!\^)\./) || $unix_rpt);
- $rename_to = File::Spec->catpath($vol, $dirs, $file);
+ if ($^O eq 'VMS' && -e $from
+ && ! -d $to && ! -d $from) {
+
+ # VMS natively inherits path components from the source of a
+ # copy, but we want the Unixy behavior of inheriting from
+ # the current working directory. Also, default in a trailing
+ # dot for null file types.
+
+ $to = VMS::Filespec::rmsexpand(VMS::Filespec::vmsify($to), '.');
# Get rid of the old versions to be like UNIX
- 1 while unlink $rename_to;
- }
+ 1 while unlink $to;
}
- return 1 if rename $from, $rename_to;
+ return 1 if rename $from, $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?
@@ -435,9 +340,9 @@ File::Copy - Copy files or filehandles
use File::Copy;
- copy("file1","file2") or die "Copy failed: $!";
+ copy("sourcefile","destinationfile") or die "Copy failed: $!";
copy("Copy.pm",\*STDOUT);
- move("/dev1/fileA","/dev2/fileB");
+ move("/dev1/sourcefile","/dev2/destinationfile");
use File::Copy "cp";
@@ -461,8 +366,11 @@ argument may be a string, a FileHandle reference or a FileHandle
glob. Obviously, if the first argument is a filehandle of some
sort, it will be read from, and if it is a file I<name> it will
be opened for reading. Likewise, the second argument will be
-written to (and created if need be). Trying to copy a file on top
-of itself is an error.
+written to. If the second argument does not exist but the parent
+directory does exist, then it will be created. Trying to copy
+a file into a non-existent directory is an error.
+Trying to copy a file on top of itself is also an error.
+C<copy> will not overwrite read-only files.
If the destination (second argument) already exists and is a directory,
and the source (first argument) is not a filehandle, then the source