view release on metacpan or  search on metacpan

lib/File/Rotate/Backup/Copy.pm  view on Meta::CPAN

            # plain file
            my $size = -s _;
            $self->debugPrint(9, "$src_path is a plain file - $size bytes\n");
            $self->_copyPlainFile($src_path, $dst_path) or return undef;
            $self->_fixOwnerPermissionsTimestamp($dst_path);
        } elsif (-d _) {
            # directory
            $self->debugPrint(9, "$src_path is a directory\n");
            return undef unless mkdir $dst_path, 0777;
            $self->_fixOwnerPermissionsTimestamp($dst_path);
        } elsif (-p _) {
            # don't copy pipes, sockets, and other special files for now
            
            # named pipe
            $self->debugPrint(9, "$src_path is a named pipe\n");
        } elsif (-S _) {
            # socket
            $self->debugPrint(9, "$src_path is a socket\n");
        } elsif (-b _) {
            # block special file
            $self->debugPrint(9, "$src_path is a block special file\n");
        } elsif (-c _) {
            # character special file
            $self->debugPrint(9,"$src_path is a character special file\n");
        }

        $self->debugPrint(9, sprintf("$src_path has permissions %o\n", $permissions));

        return 1;
    }

    sub _isSameFile {
        my ($self, $src_file, $dst_file) = @_;
        my ($src_dev, $src_ino);
        my ($dst_dev, $dst_ino);

        if (-l $src_file or -l $dst_file) {
            ($src_dev, $src_ino) = (lstat($src_file))[0,1];
            ($dst_dev, $dst_ino) = (lstat($dst_file))[0,1];
        } else {
            ($src_dev, $src_ino) = (stat($src_file))[0,1];
            ($dst_dev, $dst_ino) = (stat($dst_file))[0,1];
        }

        if ($src_dev == $dst_dev and $src_ino == $dst_ino) {
            return 1;
        }

        return 0;
    }
    
    sub _fixOwnerPermissionsTimestamp {
        my ($self, $dst_file) = @_;
        my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,
            $atime,$mtime,$ctime,$blksize,$blocks)
            = stat(_);

        my $permissions = $mode & 07777;

        chown $uid, $gid, $dst_file;
        chmod $permissions, $dst_file;
        utime $atime, $mtime, $dst_file;
    }

    sub _copyPlainFile {
        my ($self, $src_path, $dst_path) = @_;
        
        local(*IN);
        local(*OUT);
        open(IN, '<' . $src_path) or return undef;
        unless (open(OUT, '>' . $dst_path)) {
            close IN;
            return undef;
        }

        # just in case this ever runs on windoze
        binmode IN, ':raw';
        binmode OUT, ':raw';
        
        my $buf;
        while (read(IN, $buf, 1024)) {
            print OUT $buf;
        }
        close IN;
        close OUT;

        return 1;
    }

    sub remove {
        my ($self, $victim) = @_;

        $self->debugPrint(9, "remove() - passed $victim\n");

        if (not -l $victim and -d $victim) {
            return $self->_removeDirectoryRecursive($victim);
        } else {
            $self->debugPrint(1, "Removing $victim\n");
            my $params = $self->_getParams;
            if ($$params{use_flock}) {
                local(*FILE);
                open(FILE, '+<' . $victim);
                unless (CORE::flock(FILE, &Fcntl::LOCK_EX() | &Fcntl::LOCK_NB)) {
                    # can't get lock
                    close FILE;
                    $self->debugPrint(1, "Could not get lock on $victim -- not removing\n");
                    return undef;
                }
                my $rv = unlink $victim;
                CORE::flock(FILE, &Fcntl::LOCK_UN);
                close FILE;
                if (not $rv and $$params{use_rm}) {
                    # added for v0.08
                    $self->debugPrint(1, "unlink() failed -- using /bin/rm\n");
                    $rv = not system("/bin/rm", "-f", $victim);
                }
                return $rv;
            } else {
                my $rv = unlink $victim;
                if (not $rv and $$params{use_rm}) {