X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFile%2FCopy.pm;h=828473e2d3f097c97c6f22105b8ed3d06111f74e;hb=4b711db359c9778a062571f88eafc4dab0b9c81d;hp=5cea310265d43028f96cc62791b3f32f644b3db7;hpb=30c5452436ffebadaf1729c8166697074e67a6e9;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 5cea310..828473e 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -2,109 +2,265 @@ # source code has been placed in the public domain by the author. # Please be kind and preserve the documentation. # +# Additions copyright 1996 by Charles Bailey. Permission is granted +# to distribute the revised code under the same terms as Perl itself. package File::Copy; +use 5.006; +use strict; +use warnings; +use File::Spec; +use Config; +our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy); +sub copy; +sub syscopy; +sub cp; +sub mv; + +# Note that this module implements only *part* of the API defined by +# the File/Copy.pm module of the File-Tools-2.0 package. However, that +# 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.08_01'; + require Exporter; -use Carp; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); + +$Too_Big = 1024 * 1024 * 2; + +sub croak { + require Carp; + goto &Carp::croak; +} -@ISA=qw(Exporter); -@EXPORT=qw(copy); -@EXPORT_OK=qw(copy cp); +my $macfiles; +if ($^O eq 'MacOS') { + $macfiles = eval { require Mac::MoreFiles }; + warn 'Mac::MoreFiles could not be loaded; using non-native syscopy' + if $@ && $^W; +} + +sub _catname { + my($from, $to) = @_; + if (not defined &basename) { + require File::Basename; + import File::Basename 'basename'; + } -$File::Copy::VERSION = '1.5'; -$File::Copy::Too_Big = 1024 * 1024 * 2; + if ($^O eq 'MacOS') { + # a partial dir name that's valid only in the cwd (e.g. 'tmp') + $to = ':' . $to if $to !~ /:/; + } -sub VERSION { - # Version of File::Copy - return $File::Copy::VERSION; + return File::Spec->catfile($to, basename($from)); } sub copy { - croak("Usage: copy( file1, file2 [, buffersize]) ") + croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ") unless(@_ == 2 || @_ == 3); - if (($^O eq 'VMS' or $^O eq 'os2') && ref(\$_[1]) ne 'GLOB' && - !(defined ref $_[1] and (ref($_[1]) eq 'GLOB' || - ref($_[1]) eq 'FileHandle' || ref($_[1]) eq 'VMS::Stdio'))) - { return File::Copy::syscopy($_[0],$_[1]) } - my $from = shift; my $to = shift; - my $closefrom=0; - my $closeto=0; + + my $from_a_handle = (ref($from) + ? (ref($from) eq 'GLOB' + || UNIVERSAL::isa($from, 'GLOB') + || UNIVERSAL::isa($from, 'IO::Handle')) + : (ref(\$from) eq 'GLOB')); + my $to_a_handle = (ref($to) + ? (ref($to) eq 'GLOB' + || UNIVERSAL::isa($to, 'GLOB') + || UNIVERSAL::isa($to, 'IO::Handle')) + : (ref(\$to) eq 'GLOB')); + + if ($from eq $to) { # works for references, too + croak("'$from' and '$to' are identical (not copied)"); + } + + if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) && + !($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'vms')) { + my @fs = stat($from); + if (@fs) { + my @ts = stat($to); + if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1]) { + croak("'$from' and '$to' are identical (not copied)"); + } + } + } + + if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) { + $to = _catname($from, $to); + } + + if (defined &syscopy && !$Syscopy_is_copy + && !$to_a_handle + && !($from_a_handle && $^O eq 'os2' ) # OS/2 cannot handle handles + && !($from_a_handle && $^O eq 'mpeix') # and neither can MPE/iX. + && !($from_a_handle && $^O eq 'MSWin32') + && !($from_a_handle && $^O eq 'MacOS') + && !($from_a_handle && $^O eq 'NetWare') + ) + { + return syscopy($from, $to); + } + + my $closefrom = 0; + my $closeto = 0; my ($size, $status, $r, $buf); - local(*FROM, *TO); local($\) = ''; - if (ref(\$from) eq 'GLOB') { - *FROM = $from; - } elsif (defined ref $from and - (ref($from) eq 'GLOB' || ref($from) eq 'FileHandle' || - ref($from) eq 'VMS::Stdio')) { - *FROM = *$from; + my $from_h; + if ($from_a_handle) { + $from_h = $from; } else { - open(FROM,"<$from")||goto(fail_open1); - binmode FROM; + $from = _protect($from) if $from =~ /^\s/s; + $from_h = \do { local *FH }; + open($from_h, "< $from\0") or goto fail_open1; + binmode $from_h or die "($!,$^E)"; $closefrom = 1; } - if (ref(\$to) eq 'GLOB') { - *TO = $to; - } elsif (defined ref $to and - (ref($to) eq 'GLOB' || ref($to) eq 'FileHandle' || - ref($to) eq 'VMS::Stdio')) { - *TO = *$to; + my $to_h; + if ($to_a_handle) { + $to_h = $to; } else { - open(TO,">$to")||goto(fail_open2); - binmode TO; - $closeto=1; + $to = _protect($to) if $to =~ /^\s/s; + $to_h = \do { local *FH }; + open($to_h,"> $to\0") or goto fail_open2; + binmode $to_h or die "($!,$^E)"; + $closeto = 1; } if (@_) { $size = shift(@_) + 0; croak("Bad buffer size for copy: $size\n") unless ($size > 0); } else { - $size = -s FROM; + $size = tied(*$from_h) ? 0 : -s $from_h || 0; $size = 1024 if ($size < 512); - $size = $File::Copy::Too_Big if ($size > $File::Copy::Too_Big); + $size = $Too_Big if ($size > $Too_Big); } - $buf = ''; - while(defined($r = read(FROM,$buf,$size)) && $r > 0) { - if (syswrite (TO,$buf,$r) != $r) { - goto fail_inner; + $! = 0; + for (;;) { + my ($r, $w, $t); + defined($r = sysread($from_h, $buf, $size)) + or goto fail_inner; + last unless $r; + for ($w = 0; $w < $r; $w += $t) { + $t = syswrite($to_h, $buf, $r - $w, $w) + or goto fail_inner; } } - goto fail_inner unless(defined($r)); - close(TO) || goto fail_open2 if $closeto; - close(FROM) || goto fail_open1 if $closefrom; + + close($to_h) || goto fail_open2 if $closeto; + close($from_h) || goto fail_open1 if $closefrom; + # Use this idiom to avoid uninitialized value warning. return 1; - + # All of these contortions try to preserve error messages... fail_inner: if ($closeto) { $status = $!; $! = 0; - close TO; + close $to_h; $! = $status unless $!; } fail_open2: if ($closefrom) { $status = $!; $! = 0; - close FROM; + close $from_h; $! = $status unless $!; } fail_open1: return 0; } +sub move { + my($from,$to) = @_; + my($fromsz,$tosz1,$tomt1,$tosz2,$tomt2,$sts,$ossts); + + if (-d $to && ! -d $from) { + $to = _catname($from, $to); + } + + ($tosz1,$tomt1) = (stat($to))[7,9]; + $fromsz = -s $from; + if ($^O eq 'os2' and defined $tosz1 and defined $fromsz) { + # will not rename with overwrite + unlink $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? + 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 + $tosz2 == $fromsz; # it's all there + + ($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something + return 1 if copy($from,$to) && unlink($from); + ($sts,$ossts) = ($! + 0, $^E + 0); + + ($tosz2,$tomt2) = ((stat($to))[7,9],0,0) if defined $tomt1; + unlink($to) if !defined($tomt1) or $tomt1 != $tomt2 or $tosz1 != $tosz2; + ($!,$^E) = ($sts,$ossts); + return 0; +} *cp = \© +*mv = \&move; + + +if ($^O eq 'MacOS') { + *_protect = sub { MacPerl::MakeFSSpec($_[0]) }; +} else { + *_protect = sub { "./$_[0]" }; +} + # &syscopy is an XSUB under OS/2 -*syscopy = ($^O eq 'VMS' ? \&rmscopy : \©) unless $^O eq 'os2'; +unless (defined &syscopy) { + if ($^O eq 'VMS') { + *syscopy = \&rmscopy; + } elsif ($^O eq 'mpeix') { + *syscopy = sub { + return 0 unless @_ == 2; + # Use the MPE cp program in order to + # preserve MPE file attributes. + return system('/bin/cp', '-f', $_[0], $_[1]) == 0; + }; + } elsif ($^O eq 'MSWin32') { + *syscopy = sub { + return 0 unless @_ == 2; + return Win32::CopyFile(@_, 1); + }; + } elsif ($macfiles) { + *syscopy = sub { + my($from, $to) = @_; + my($dir, $toname); + + return 0 unless -e $from; + + if ($to =~ /(.*:)([^:]+):?$/) { + ($dir, $toname) = ($1, $2); + } else { + ($dir, $toname) = (":", $to); + } + + unlink($to); + Mac::MoreFiles::FSpFileCopy($from, $dir, $toname, 1); + }; + } else { + $Syscopy_is_copy = 1; + *syscopy = \© + } +} 1; @@ -116,29 +272,42 @@ File::Copy - Copy files or filehandles =head1 SYNOPSIS - use File::Copy; + use File::Copy; - copy("file1","file2"); - copy("Copy.pm",\*STDOUT);' + copy("file1","file2") or die "Copy failed: $!"; + copy("Copy.pm",\*STDOUT); + move("/dev1/fileA","/dev2/fileB"); - use POSIX; - use File::Copy cp; + use File::Copy "cp"; - $n=FileHandle->new("/dev/null","r"); - cp($n,"x");' + $n = FileHandle->new("/a/file","r"); + cp($n,"x"); =head1 DESCRIPTION -The File::Copy module provides a basic function C which takes two +The File::Copy module provides two basic functions, C and +C, which are useful for getting the contents of a file from +one place to another. + +=over 4 + +=item * + +The C function takes two parameters: a file to copy from and a file to copy to. Either 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 it will be opened for reading. Likewise, the second argument will be -written to (and created if need be). Note that passing in +written to (and created if need be). Trying to copy a file on top +of itself is a fatal error. + +B Files are opened in binary mode where +applicable. To get a consistent behaviour when copying from a +filehandle to a file, use C 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 @@ -150,33 +319,58 @@ upon the file, but will generally be the whole file (up to 2Mb), or You may use the syntax C to get at the "cp" alias for this function. The syntax is I the same. +=item * + +The C function also takes two parameters: the current name +and the intended name of the file to be moved. If the destination +already exists and is a directory, and the source is not a +directory, then the source file will be renamed into the directory +specified by the destination. + +If possible, move() will simply rename the file. Otherwise, it copies +the file to the new location and deletes the original. If an error occurs +during this copy-and-delete process, you may be left with a (possibly partial) +copy of the file under the destination name. + +You may use the "mv" alias for this function in the same way that +you may use the "cp" alias for C. + +=back + File::Copy also provides the C routine, which copies the file specified in the first parameter to the file specified in the second parameter, preserving OS-specific attributes and file structure. For Unix systems, this is equivalent to the simple -C routine. For VMS systems, this calls the C -routine (see below). For OS/2 systems, this calls the C -XSUB directly. +C routine, which doesn't preserve OS-specific attributes. For +VMS systems, this calls the C routine (see below). For OS/2 +systems, this calls the C XSUB directly. For Win32 systems, +this calls C. -=head2 Special behavior under VMS +On Mac OS (Classic), C calls C, +if available. -If the second argument to C is not a file handle for an -already opened file, then C will perform an RMS copy of +=head2 Special behaviour if C is defined (OS/2, VMS and Win32) + +If both arguments to C are not file handles, +then C will perform a "system copy" of the input file to a new output file, in order to preserve file attributes, indexed file structure, I The buffer size -parameter is ignored. If the second argument to C is a -Perl handle to an opened file, then data is copied using Perl +parameter is ignored. If either argument to C is a +handle to an opened file, then data is copied using Perl operators, and no effort is made to preserve file attributes or record structure. -The RMS copy routine may also be called directly under VMS -as C (or C, which -is just an alias for this routine). +The system copy routine may also be called directly under VMS and OS/2 +as C (or under VMS as C, which +is the routine that does the actual work for syscopy). + +=over 4 =item rmscopy($from,$to[,$date_flag]) -The first and second arguments may be strings, typeglobs, or -typeglob references; they are used in all cases to obtain the +The first and second arguments may be strings, typeglobs, typeglob +references, or objects inheriting from IO::Handle; +they are used in all cases to obtain the I of the input and output files, respectively. The name and type of the input file are used as defaults for the output file, if necessary. @@ -207,15 +401,45 @@ it defaults to 0. Like C, C returns 1 on success. If an error occurs, it sets C<$!>, deletes the output file, and returns 0. +=back + =head1 RETURN -Returns 1 on success, 0 on failure. $! will be set if an error was -encountered. +All functions return 1 on success, 0 on failure. +$! will be set if an error was encountered. + +=head1 NOTES + +=over 4 + +=item * + +On Mac OS (Classic), the path separator is ':', not '/', and the +current directory is denoted as ':', not '.'. You should be careful +about specifying relative pathnames. While a full path always begins +with a volume name, a relative pathname should always begin with a +':'. If specifying a volume name only, a trailing ':' is required. + +E.g. + + copy("file1", "tmp"); # creates the file 'tmp' in the current directory + copy("file1", ":tmp:"); # creates :tmp:file1 + copy("file1", ":tmp"); # same as above + copy("file1", "tmp"); # same as above, if 'tmp' is a directory (but don't do + # that, since it may cause confusion, see example #1) + copy("file1", "tmp:file1"); # error, since 'tmp:' is not a volume + 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 + # volume to another + +=back =head1 AUTHOR -File::Copy was written by Aaron Sherman Iajs@ajs.comE> in 1995. -The VMS-specific code was added by Charles Bailey -Ibailey@genetics.upenn.eduE> in March 1996. +File::Copy was written by Aaron Sherman Iajs@ajs.comE> in 1995, +and updated by Charles Bailey Ibailey@newman.upenn.eduE> in 1996. =cut +