view release on metacpan or  search on metacpan

lib/File/NCopy.pm  view on Meta::CPAN

@EXPORT_OK = qw(copy cp);

$VERSION = '0.36';

# this works on Unix
sub u_chmod($$)
{
    my ($file_from,$file_to) = @_;

    my ($mode) = (stat $file_from)[2];
    chmod $mode & 0777,$file_to
        unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle';
    1;
}

# this also works on Unix
sub f_check($$)
{
    my ($file_from,$file_to) = @_;

    # get a shared lock on file to copy from
    flock $file_from,5
        or return 0;
    # try and get an exclusive lock on the file to copy to
    flock $file_to,6
        or do {
            flock $file_from,8;
            return 0;
        };
    flock $file_from,8;
    flock $file_to,8;

    1;
}

# this also works on Unix, it's not the default but you can easily use
# it by using the module in an object oriented way
# $copy = File::NCopy->new('file_check' => \&File::NCopy::unix_check);
sub unix_check($$)
{
    my ($file_from,$file_to) = @_;

    my ($fdev,$fino) = (stat $file_from)[0,1];
    my ($tdev,$tino) = (stat $file_to)[0,1];

    return 0
        if $fdev == $tdev && $fino == $tino;
    1;
}

sub s_times($$)
{
    my ($file_from,$file_to) = @_;

    my ($uid,$gid,$atime,$mtime) = (stat $file_from)[4,5,8,9];

    utime $atime,$mtime,$file_to
        unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle';

    # this may only work for men in white hats; on Unix
    chown $uid,$gid,$file_to
        unless ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle';
    1;
}

# all the actual copying is done here, folks ;)
sub _docopy_file_file($$$)
{
    my $this = shift;
    my ($file_from,$file_to) = @_;
    local (*FILE_FROM,*FILE_TO);
    my ($was_handle);

    # did we get a file handle ?
    unless(ref $file_from eq 'GLOB' || ref $file_from eq 'FileHandle') {
        open FILE_FROM,"<$file_from"
            or do {
                print "*** Couldn\'t open from file <$!> ==> $file_from\n"
                    if $this->{'_debug'};
                return 0;
            };
    }
    else {
        *FILE_FROM = *$file_from;
    }

    unless(ref $file_to eq 'GLOB' || ref $file_to eq 'FileHandle') {
        # we must open in update mode since on some systems exclusive
        # locks are only granted to files that are going to be written;
        open FILE_TO,"+<$file_to"
            or goto NO_FILE; # no file, so file can't be the same :)
    }
    else {
        *FILE_TO = *$file_to;
        $was_handle = 1;
    }

    unless(-t FILE_FROM || -t FILE_TO) {
        $this->{'file_check'}->(\*FILE_FROM,\*FILE_TO)
            or return 0;
    }

NO_FILE:
    # files aren't the same; now open for writing unless we got a
    # filehandle
    if(! $was_handle && ! $this->{test}) {
        open FILE_TO,">$file_to"
            or chmod 0644, "$file_to"
                if $this->{'force_write'};
        open FILE_TO,">$file_to"
            or do {
                print "*** Couldn\'t open to file <$!> ==> $file_to\n"
                    if $this->{'_debug'};
                return 0;
            };
    }

    # and now for the braindead OS's
    binmode FILE_FROM unless ($this->{test});
    binmode FILE_TO   unless ($this->{test});