X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FFile%2FCopy.pm;h=8638bee2108ea412590fc5422e6958cf92c5cb97;hb=cb50131aab68ac6dda048612c6e853b8cb08701e;hp=92b9be15e67c89751320482aa35b7f19de6744f7;hpb=1fef88e72b0b21420614d87ecab0aaedf3725271;p=p5sagit%2Fp5-mst-13.2.git diff --git a/lib/File/Copy.pm b/lib/File/Copy.pm index 92b9be1..8638bee 100644 --- a/lib/File/Copy.pm +++ b/lib/File/Copy.pm @@ -2,63 +2,100 @@ # 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; -require Exporter; +use 5.005_64; +use strict; use Carp; +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.03'; -@ISA=qw(Exporter); -@EXPORT=qw(copy); -@EXPORT_OK=qw(copy cp); +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); -$File::Copy::VERSION = '1.5'; -$File::Copy::Too_Big = 1024 * 1024 * 2; +$Too_Big = 1024 * 1024 * 2; -sub VERSION { - # Version of File::Copy - return $File::Copy::VERSION; +sub _catname { # Will be replaced by File::Spec when it arrives + my($from, $to) = @_; + if (not defined &basename) { + require File::Basename; + import File::Basename 'basename'; + } + if ($^O eq 'VMS') { $to = VMS::Filespec::vmspath($to) . basename($from); } + elsif ($^O eq 'MacOS') { $to .= ':' . basename($from); } + elsif ($to =~ m|\\|) { $to .= '\\' . basename($from); } + else { $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(\$to) ne 'GLOB' && - !(defined ref $to and (ref($to) eq 'GLOB' || - ref($to) eq 'FileHandle' || ref($to) 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_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') + ) + { + 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; + if ($from_a_handle) { + *FROM = *$from{FILEHANDLE}; } else { - open(FROM,"<$from")||goto(fail_open1); - binmode FROM; + $from = "./$from" if $from =~ /^\s/; + open(FROM, "< $from\0") or goto fail_open1; + binmode FROM 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; + if ($to_a_handle) { + *TO = *$to{FILEHANDLE}; } else { - open(TO,">$to")||goto(fail_open2); - binmode TO; - $closeto=1; + $to = "./$to" if $to =~ /^\s/; + open(TO,"> $to\0") or goto fail_open2; + binmode TO or die "($!,$^E)"; + $closeto = 1; } if (@_) { @@ -67,21 +104,27 @@ sub copy { } else { $size = -s FROM; $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, $buf, $size)) + or goto fail_inner; + last unless $r; + for ($w = 0; $w < $r; $w += $t) { + $t = syswrite(TO, $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; + # Use this idiom to avoid uninitialized value warning. return 1; - + # All of these contortions try to preserve error messages... fail_inner: if ($closeto) { @@ -101,10 +144,63 @@ sub copy { return 0; } +sub move { + my($from,$to) = @_; + my($copied,$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; + + ($sts,$ossts) = ($! + 0, $^E + 0); + # 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 ($copied = copy($from,$to)) && unlink($from); + + ($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; + # &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); + }; + } else { + $Syscopy_is_copy = 1; + *syscopy = \© + } +} 1; @@ -120,6 +216,7 @@ File::Copy - Copy files or filehandles copy("file1","file2"); copy("Copy.pm",\*STDOUT);' + move("/dev1/fileA","/dev2/fileB"); use POSIX; use File::Copy cp; @@ -129,16 +226,28 @@ File::Copy - Copy files or filehandles =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). + +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 +259,54 @@ 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. +XSUB directly. For Win32 systems, this calls C. -=head2 Special behavior under VMS +=head2 Special behaviour if C is defined (OS/2, VMS and Win32) -If the second argument to C is not a file handle for an -already opened file, then C will perform an RMS copy of +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 +337,17 @@ 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 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 +