diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/File/Copy.pm')
| -rw-r--r-- | Master/tlpkg/tlperl/lib/File/Copy.pm | 156 |
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 |