Initial Commit
This commit is contained in:
Riley Schneider
513
database/perl/lib/File/Copy.pm
Normal file
513
database/perl/lib/File/Copy.pm
Normal file
@@ -0,0 +1,513 @@
|
||||
# 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 5.006;
|
||||
use strict;
|
||||
use warnings; no warnings 'newline';
|
||||
use File::Spec;
|
||||
use Config;
|
||||
# During perl build, we need File::Copy but Scalar::Util might not be built yet
|
||||
# And then we need these games to avoid loading overload, as that will
|
||||
# confuse miniperl during the bootstrap of perl.
|
||||
my $Scalar_Util_loaded = eval q{ require Scalar::Util; require overload; 1 };
|
||||
# We want HiRes stat and utime if available
|
||||
BEGIN { eval q{ use Time::HiRes qw( stat utime ) } };
|
||||
our(@ISA, @EXPORT, @EXPORT_OK, $VERSION, $Too_Big, $Syscopy_is_copy);
|
||||
sub copy;
|
||||
sub syscopy;
|
||||
sub cp;
|
||||
sub mv;
|
||||
|
||||
$VERSION = '2.34';
|
||||
|
||||
require Exporter;
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT = qw(copy move);
|
||||
@EXPORT_OK = qw(cp mv);
|
||||
|
||||
$Too_Big = 1024 * 1024 * 2;
|
||||
|
||||
sub croak {
|
||||
require Carp;
|
||||
goto &Carp::croak;
|
||||
}
|
||||
|
||||
sub carp {
|
||||
require Carp;
|
||||
goto &Carp::carp;
|
||||
}
|
||||
|
||||
sub _catname {
|
||||
my($from, $to) = @_;
|
||||
if (not defined &basename) {
|
||||
require File::Basename;
|
||||
import File::Basename 'basename';
|
||||
}
|
||||
|
||||
return File::Spec->catfile($to, basename($from));
|
||||
}
|
||||
|
||||
# _eq($from, $to) tells whether $from and $to are identical
|
||||
sub _eq {
|
||||
my ($from, $to) = map {
|
||||
$Scalar_Util_loaded && Scalar::Util::blessed($_)
|
||||
&& overload::Method($_, q{""})
|
||||
? "$_"
|
||||
: $_
|
||||
} (@_);
|
||||
return '' if ( (ref $from) xor (ref $to) );
|
||||
return $from == $to if ref $from;
|
||||
return $from eq $to;
|
||||
}
|
||||
|
||||
sub copy {
|
||||
croak("Usage: copy(FROM, TO [, BUFFERSIZE]) ")
|
||||
unless(@_ == 2 || @_ == 3);
|
||||
|
||||
my $from = shift;
|
||||
my $to = shift;
|
||||
|
||||
my $size;
|
||||
if (@_) {
|
||||
$size = shift(@_) + 0;
|
||||
croak("Bad buffer size for copy: $size\n") unless ($size > 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 (_eq($from, $to)) { # works for references, too
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (!$from_a_handle && !$to_a_handle && -d $to && ! -d $from) {
|
||||
$to = _catname($from, $to);
|
||||
}
|
||||
|
||||
if ((($Config{d_symlink} && $Config{d_readlink}) || $Config{d_link}) &&
|
||||
!($^O eq 'MSWin32' || $^O eq 'os2')) {
|
||||
my @fs = stat($from);
|
||||
if (@fs) {
|
||||
my @ts = stat($to);
|
||||
if (@ts && $fs[0] == $ts[0] && $fs[1] == $ts[1] && !-p $from) {
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif (_eq($from, $to)) {
|
||||
carp("'$from' and '$to' are identical (not copied)");
|
||||
return 0;
|
||||
}
|
||||
|
||||
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 'MSWin32')
|
||||
&& !($from_a_handle && $^O eq 'NetWare')
|
||||
)
|
||||
{
|
||||
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, $to) || 0;
|
||||
}
|
||||
|
||||
my $closefrom = 0;
|
||||
my $closeto = 0;
|
||||
my ($status, $r, $buf);
|
||||
local($\) = '';
|
||||
|
||||
my $from_h;
|
||||
if ($from_a_handle) {
|
||||
$from_h = $from;
|
||||
} else {
|
||||
open $from_h, "<", $from or goto fail_open1;
|
||||
binmode $from_h or die "($!,$^E)";
|
||||
$closefrom = 1;
|
||||
}
|
||||
|
||||
# Seems most logical to do this here, in case future changes would want to
|
||||
# make this croak for some reason.
|
||||
unless (defined $size) {
|
||||
$size = tied(*$from_h) ? 0 : -s $from_h || 0;
|
||||
$size = 1024 if ($size < 512);
|
||||
$size = $Too_Big if ($size > $Too_Big);
|
||||
}
|
||||
|
||||
my $to_h;
|
||||
if ($to_a_handle) {
|
||||
$to_h = $to;
|
||||
} else {
|
||||
$to_h = \do { local *FH }; # XXX is this line obsolete?
|
||||
open $to_h, ">", $to or goto fail_open2;
|
||||
binmode $to_h or die "($!,$^E)";
|
||||
$closeto = 1;
|
||||
}
|
||||
|
||||
$! = 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;
|
||||
}
|
||||
}
|
||||
|
||||
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_h;
|
||||
$! = $status unless $!;
|
||||
}
|
||||
fail_open2:
|
||||
if ($closefrom) {
|
||||
$status = $!;
|
||||
$! = 0;
|
||||
close $from_h;
|
||||
$! = $status unless $!;
|
||||
}
|
||||
fail_open1:
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub cp {
|
||||
my($from,$to) = @_;
|
||||
my(@fromstat) = stat $from;
|
||||
my(@tostat) = stat $to;
|
||||
my $perm;
|
||||
|
||||
return 0 unless copy(@_) and @fromstat;
|
||||
|
||||
if (@tostat) {
|
||||
$perm = $tostat[2];
|
||||
} else {
|
||||
$perm = $fromstat[2] & ~(umask || 0);
|
||||
@tostat = stat $to;
|
||||
}
|
||||
# Might be more robust to look for S_I* in Fcntl, but we're
|
||||
# trying to avoid dependence on any XS-containing modules,
|
||||
# since File::Copy is used during the Perl build.
|
||||
$perm &= 07777;
|
||||
if ($perm & 06000) {
|
||||
croak("Unable to check setuid/setgid permissions for $to: $!")
|
||||
unless @tostat;
|
||||
|
||||
if ($perm & 04000 and # setuid
|
||||
$fromstat[4] != $tostat[4]) { # owner must match
|
||||
$perm &= ~06000;
|
||||
}
|
||||
|
||||
if ($perm & 02000 && $> != 0) { # if not root, setgid
|
||||
my $ok = $fromstat[5] == $tostat[5]; # group must match
|
||||
if ($ok) { # and we must be in group
|
||||
$ok = grep { $_ == $fromstat[5] } split /\s+/, $)
|
||||
}
|
||||
$perm &= ~06000 unless $ok;
|
||||
}
|
||||
}
|
||||
return 0 unless @tostat;
|
||||
return 1 if $perm == ($tostat[2] & 07777);
|
||||
return eval { chmod $perm, $to; } ? 1 : 0;
|
||||
}
|
||||
|
||||
sub _move {
|
||||
croak("Usage: move(FROM, TO) ") unless @_ == 3;
|
||||
|
||||
my($from,$to,$fallback) = @_;
|
||||
|
||||
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;
|
||||
}
|
||||
|
||||
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 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
|
||||
((!defined $tosz1) || # not before or
|
||||
($tosz1 != $tosz2 or $tomt1 != $tomt2)) && # was changed
|
||||
$tosz2 == $fromsz; # it's all there
|
||||
|
||||
($tosz1,$tomt1) = (stat($to))[7,9]; # just in case rename did something
|
||||
|
||||
{
|
||||
local $@;
|
||||
eval {
|
||||
local $SIG{__DIE__};
|
||||
$fallback->($from,$to) or die;
|
||||
my($atime, $mtime) = (stat($from))[8,9];
|
||||
utime($atime, $mtime, $to);
|
||||
unlink($from) or die;
|
||||
};
|
||||
return 1 unless $@;
|
||||
}
|
||||
($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;
|
||||
}
|
||||
|
||||
sub move { _move(@_,\©); }
|
||||
sub mv { _move(@_,\&cp); }
|
||||
|
||||
# &syscopy is an XSUB under OS/2
|
||||
unless (defined &syscopy) {
|
||||
if ($^O eq 'VMS') {
|
||||
*syscopy = \&rmscopy;
|
||||
} elsif ($^O eq 'MSWin32' && defined &DynaLoader::boot_DynaLoader) {
|
||||
# Win32::CopyFile() fill only work if we can load Win32.xs
|
||||
*syscopy = sub {
|
||||
return 0 unless @_ == 2;
|
||||
return Win32::CopyFile(@_, 1);
|
||||
};
|
||||
} else {
|
||||
$Syscopy_is_copy = 1;
|
||||
*syscopy = \©
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
File::Copy - Copy files or filehandles
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use File::Copy;
|
||||
|
||||
copy("sourcefile","destinationfile") or die "Copy failed: $!";
|
||||
copy("Copy.pm",\*STDOUT);
|
||||
move("/dev1/sourcefile","/dev2/destinationfile");
|
||||
|
||||
use File::Copy "cp";
|
||||
|
||||
$n = FileHandle->new("/a/file","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 copy
|
||||
X<copy> X<cp>
|
||||
|
||||
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. 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
|
||||
file will be copied into the directory specified by the destination,
|
||||
using the same base name as the source file. It's a failure to have a
|
||||
filehandle as the source when the destination is a directory.
|
||||
|
||||
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 behaviour 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 will 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 C<cp>
|
||||
alias for this function. The syntax is I<exactly> the same. The
|
||||
behavior is nearly the same as well: as of version 2.15, C<cp> will
|
||||
preserve the source file's permission bits like the shell utility
|
||||
C<cp(1)> would do, while C<copy> uses the default permissions for the
|
||||
target file (which may depend on the process' C<umask>, file
|
||||
ownership, inherited ACLs, etc.). If an error occurs in setting
|
||||
permissions, C<cp> will return 0, regardless of whether the file was
|
||||
successfully copied.
|
||||
|
||||
=item move
|
||||
X<move> X<mv> X<rename>
|
||||
|
||||
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 C<mv> alias for this function in the same way that
|
||||
you may use the C<cp> alias for C<copy>.
|
||||
|
||||
=item syscopy
|
||||
X<syscopy>
|
||||
|
||||
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, which doesn't preserve OS-specific attributes. For
|
||||
VMS systems, this calls the C<rmscopy> routine (see below). For OS/2
|
||||
systems, this calls the C<syscopy> XSUB directly. For Win32 systems,
|
||||
this calls C<Win32::CopyFile>.
|
||||
|
||||
B<Special behaviour if C<syscopy> is defined (OS/2, VMS and Win32)>:
|
||||
|
||||
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).
|
||||
|
||||
=item rmscopy($from,$to[,$date_flag])
|
||||
X<rmscopy>
|
||||
|
||||
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.
|
||||
|
||||
C<rmscopy> is VMS specific and cannot be exported; it must be
|
||||
referenced by its full name, e.g.:
|
||||
|
||||
File::Copy::rmscopy($from, $to) or die $!;
|
||||
|
||||
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 NOTES
|
||||
|
||||
Before calling copy() or move() on a filehandle, the caller should
|
||||
close or flush() the file to avoid writes being lost. Note that this
|
||||
is the case even for move(), because it may actually copy the file,
|
||||
depending on the OS-specific implementation, and the underlying
|
||||
filesystem(s).
|
||||
|
||||
=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@newman.upenn.eduE<gt>> in 1996.
|
||||
|
||||
=cut
|
||||
|
||||
Reference in New Issue
Block a user