view release on metacpan or  search on metacpan

NCopy.pm  view on Meta::CPAN

$VERSION = '0.33.1';


# 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) = @_;
    use Fcntl ':flock';

    # get a shared lock on file to copy from
    flock $file_from, LOCK_SH | LOCK_NB
        or return 0;
    # try and get an exclusive lock on the file to copy to
    flock $file_to, LOCK_EX | LOCK_NB
        or do {
            flock $file_from, LOCK_UN;
            return 0;
        };
    flock $file_from, LOCK_UN;
    flock $file_to, LOCK_UN;

    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);

    if ($this->{'-precopycommand'}) {
	my ($command, @args) = @{$this->{'-precopycommand'}};
	$command->($file_from, $file_to, @args);
    }

    return 0 if $this->{'_stop'};

    # 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'};