diff options
Diffstat (limited to 'contrib/perl5/lib/File/Copy.pm')
| -rw-r--r-- | contrib/perl5/lib/File/Copy.pm | 342 |
1 files changed, 342 insertions, 0 deletions
diff --git a/contrib/perl5/lib/File/Copy.pm b/contrib/perl5/lib/File/Copy.pm new file mode 100644 index 0000000000000..d0b3c8977ef04 --- /dev/null +++ b/contrib/perl5/lib/File/Copy.pm @@ -0,0 +1,342 @@ +# File/Copy.pm. Written in 1994 by Aaron Sherman <ajs@ajs.com>. This +# 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 strict; +use Carp; +use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION $Too_Big + © &syscopy &cp &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.02'; + +require Exporter; +@ISA = qw(Exporter); +@EXPORT = qw(copy move); +@EXPORT_OK = qw(cp mv); + +$Too_Big = 1024 * 1024 * 2; + +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(FROM, TO [, BUFFERSIZE]) ") + unless(@_ == 2 || @_ == 3); + + my $from = shift; + my $to = shift; + + 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 != \© + && !$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. + ) + { + return syscopy($from, $to); + } + + my $closefrom = 0; + my $closeto = 0; + my ($size, $status, $r, $buf); + local(*FROM, *TO); + local($\) = ''; + + if ($from_a_handle) { + *FROM = *$from{FILEHANDLE}; + } else { + $from = "./$from" if $from =~ /^\s/; + open(FROM, "< $from\0") or goto fail_open1; + binmode FROM or die "($!,$^E)"; + $closefrom = 1; + } + + if ($to_a_handle) { + *TO = *$to{FILEHANDLE}; + } else { + $to = "./$to" if $to =~ /^\s/; + open(TO,"> $to\0") or goto fail_open2; + binmode TO 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 = 1024 if ($size < 512); + $size = $Too_Big if ($size > $Too_Big); + } + + $! = 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; + } + } + + 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) { + $status = $!; + $! = 0; + close TO; + $! = $status unless $!; + } + fail_open2: + if ($closefrom) { + $status = $!; + $! = 0; + close FROM; + $! = $status unless $!; + } + fail_open1: + 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 +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; + }; + } else { + *syscopy = \© + } +} + +1; + +__END__ + +=head1 NAME + +File::Copy - Copy files or filehandles + +=head1 SYNOPSIS + + use File::Copy; + + copy("file1","file2"); + copy("Copy.pm",\*STDOUT);' + move("/dev1/fileA","/dev2/fileB"); + + use POSIX; + use File::Copy cp; + + $n=FileHandle->new("/dev/null","r"); + cp($n,"x");' + +=head1 DESCRIPTION + +The File::Copy module provides two basic functions, C<copy> and +C<move>, which are useful for getting the contents of a file from +one place to another. + +=over 4 + +=item * + +The C<copy> 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<name> it will +be opened for reading. Likewise, the second argument will be +written to (and created if need be). + +B<Note that passing in +files as handles instead of names may lead to loss of information +on some operating systems; it is recommended that you use file +names whenever possible.> Files are opened in binary mode where +applicable. To get a consistent behavour when copying from a +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 +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 +1k for filehandles that do not reference files (eg. sockets). + +You may use the syntax C<use File::Copy "cp"> to get at the +"cp" alias for this function. The syntax is I<exactly> the same. + +=item * + +The C<move> 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<copy>. + +=back + +File::Copy also provides the C<syscopy> 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<copy> routine. For VMS systems, this calls the C<rmscopy> +routine (see below). For OS/2 systems, this calls the C<syscopy> +XSUB directly. + +=head2 Special behavior if C<syscopy> is defined (VMS and OS/2) + +If both arguments to C<copy> are not file handles, +then C<copy> will perform a "system copy" of +the input file to a new output file, in order to preserve file +attributes, indexed file structure, I<etc.> The buffer size +parameter is ignored. If either argument to C<copy> 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 system copy routine may also be called directly under VMS and OS/2 +as C<File::Copy::syscopy> (or under VMS as C<File::Copy::rmscopy>, 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, typeglob +references, or objects inheriting from IO::Handle; +they are used in all cases to obtain the +I<filespec> 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. + +A new version of the output file is always created, which +inherits the structure and RMS attributes of the input file, +except for owner and protections (and possibly timestamps; +see below). All data from the input file is copied to the +output file; if either of the first two parameters to C<rmscopy> +is a file handle, its position is unchanged. (Note that this +means a file handle pointing to the output file will be +associated with an old version of that file after C<rmscopy> +returns, not the newly created version.) + +The third parameter is an integer flag, which tells C<rmscopy> +how to handle timestamps. If it is E<lt> 0, none of the input file's +timestamps are propagated to the output file. If it is E<gt> 0, then +it is interpreted as a bitmask: if bit 0 (the LSB) is set, then +timestamps other than the revision date are propagated; if bit 1 +is set, the revision date is propagated. If the third parameter +to C<rmscopy> is 0, then it behaves much like the DCL COPY command: +if the name or type of the output file was explicitly specified, +then no timestamps are propagated, but if they were taken implicitly +from the input filespec, then all timestamps other than the +revision date are propagated. If this parameter is not supplied, +it defaults to 0. + +Like C<copy>, C<rmscopy> returns 1 on success. If an error occurs, +it sets C<$!>, deletes the output file, and returns 0. + +=back + +=head1 RETURN + +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 I<E<lt>ajs@ajs.comE<gt>> in 1995, +and updated by Charles Bailey I<E<lt>bailey@genetics.upenn.eduE<gt>> in 1996. + +=cut + |