File Coverage

/root/.cpan/build/File-RsyncP-0.76-0/blib/lib/File/RsyncP/FileIO.pm

Criterion	Covered	Total	%
statement	39	327	11.9
branch	0	172	0.0
condition	0	59	0.0
subroutine	13	45	28.8
pod	25	31	80.6
total	77	634	12.1

#============================================================= -*-perl-*-
#
# File::RsyncP::FileIO package
#
# DESCRIPTION
#   Provide file system IO for File::RsyncP.
#
# AUTHOR
#   Craig Barratt
#
# COPYRIGHT
#   File::RsyncP is Copyright (C) 2002  Craig Barratt.
#
#   Rsync is Copyright (C) 1996-2001 by Andrew Tridgell, 1996 by Paul
#   Mackerras, and 2001, 2002 by Martin Pool.
#
#   This program is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this program.  If not, see .
#
#========================================================================
#
# Version 0.76, released 14 Sep 2020.
#
# See http://perlrsync.sourceforge.net.
#
#========================================================================

package File::RsyncP::FileIO;

use strict;
use File::RsyncP::Digest;
use File::Path;
use File::Find;

use vars qw($VERSION);
$VERSION = '0.76';

use constant S_IFMT       => 0170000;	# type of file
use constant S_IFDIR      => 0040000; 	# directory
use constant S_IFCHR      => 0020000; 	# character special
use constant S_IFBLK      => 0060000; 	# block special
use constant S_IFREG      => 0100000; 	# regular
use constant S_IFLNK      => 0120000; 	# symbolic link
use constant S_IFSOCK     => 0140000; 	# socket
use constant S_IFIFO      => 0010000; 	# fifo

sub new
{
    my($class, $options) = @_;

    $options ||= {};
    my $self = bless {
        blockSize    => 700,
        logLevel     => 0,
        digest       => File::RsyncP::Digest->new($options->{protocol_version}),
        checksumSeed => 0,
	logHandler   => \&logHandler,
	%$options,
    }, $class;
    return $self;
}

sub blockSize
{
    my($fio, $value) = @_;

    $fio->{blockSize} = $value if ( defined($value) );
    return $fio->{blockSize};
}

#
# We publish our version to File::RsyncP.  This is so File::RsyncP
# can provide backward compatibility to older FileIO code.
#
# Versions:
#
#   undef or 1:  protocol version 26, no hardlinks
#   2:           protocol version 28, supports hardlinks
#
sub version
{
    return 2;
}

sub preserve_hard_links
{
    my($fio, $value) = @_;

    $fio->{preserve_hard_links} = $value if ( defined($value) );
    return $fio->{preserve_hard_links};
}

sub protocol_version
{
    my($fio, $value) = @_;

    if ( defined($value) ) {
        $fio->{protocol_version} = $value;
        $fio->{digest}->protocol($fio->{protocol_version});
    }
    return $fio->{protocol_version};
}

sub logHandlerSet
{
    my($fio, $sub) = @_;
    $fio->{logHandler} = $sub;
}

#
# Given a remote name, return the local name
#
sub localName
{
    my($fio, $name) = @_;

    return $name if ( !defined($fio->{localDir})
	   	   && !defined($fio->{remoteDir}) );
    if ( substr($name, 0, length($fio->{remoteDir})) eq $fio->{remoteDir} ) {
	substr($name, 0, length($fio->{remoteDir})) = $fio->{localDir};
    }
    return $name;
}

#
# Setup rsync checksum computation for the given file.
#
sub csumStart
{
    my($fio, $f, $needMD4) = @_;
    local(*F);
    my $localName = $fio->localName($f->{name});

    $fio->{file} = $f;
    $fio->csumEnd if ( defined($fio->{fh}) );
    return if ( !-f $localName || -l $localName );
    if ( !open(F, $localName) ) {
        $fio->log("Can't open $localName");
        return -1;
    }
    if ( $needMD4) {
	$fio->{csumDigest}
                    = File::RsyncP::Digest->new($fio->{protocol_version});
	$fio->{csumDigest}->add(pack("V", $fio->{checksumSeed}));
    } else {
	delete($fio->{csumDigest});
    }
    $fio->{fh} = *F;
}

sub csumGet
{
    my($fio, $num, $csumLen, $blockSize) = @_;
    my($fileData);

    $num     ||= 100;
    $csumLen ||= 16;

    return if ( !defined($fio->{fh}) );
    if ( sysread($fio->{fh}, $fileData, $blockSize * $num) <= 0 ) {
        return;
    }
    $fio->{csumDigest}->add($fileData) if ( defined($fio->{csumDigest}) );
    $fio->log(sprintf("%s: getting csum ($num,$csumLen,%d,0x%x)",
                            $fio->{file}{name},
                            length($fileData),
                            $fio->{checksumSeed}))
                if ( $fio->{logLevel} >= 10 );
    return $fio->{digest}->blockDigest($fileData, $blockSize,
                                         $csumLen, $fio->{checksumSeed});
}

sub csumEnd
{
    my($fio) = @_;

    return if ( !defined($fio->{fh}) );
    #
    # make sure we read the entire file for the file MD4 digest
    #
    if ( defined($fio->{csumDigest}) ) {
	while ( sysread($fio->{fh}, my $fileData, 65536) > 0 ) {
	    $fio->{csumDigest}->add($fileData);
	}
    }
    close($fio->{fh});
    delete($fio->{fh});
    return $fio->{csumDigest}->digest if ( defined($fio->{csumDigest}) );
}

sub readStart
{
    my($fio, $f) = @_;
    local(*F);
    my $localName = $fio->localName($f->{name});

    $fio->{file} = $f;
    $fio->readEnd if ( defined($fio->{fh}) );
    return if ( !-f $localName || -l $localName );
    if ( !open(F, $localName) ) {
        $fio->log("Can't open $localName");
        return;
    }
    $fio->{fh} = *F;
}

sub read
{
    my($fio, $num) = @_;
    my($fileData);

    $num ||= 32768;
    return if ( !defined($fio->{fh}) );
    if ( sysread($fio->{fh}, $fileData, $num) <= 0 ) {
        return $fio->readEnd;
    }
    return \$fileData;
}

sub readEnd
{
    my($fio) = @_;

    return if ( !defined($fio->{fh}) );
    close($fio->{fh});
    delete($fio->{fh});
}

sub checksumSeed
{
    my($fio, $checksumSeed) = @_;

    $fio->{checksumSeed} = $checksumSeed;
}

sub dirs
{
    my($fio, $localDir, $remoteDir) = @_;

    $fio->{localDir}  = $localDir;
    $fio->{remoteDir} = $remoteDir;
}

sub attribGet
{
    my($fio, $f) = @_;
    my $localName = $fio->localName($f->{name});

    my @s = stat($localName);
    return if ( !@s );
    return {
        mode  => $s[2],
        uid   => $s[4],
        gid   => $s[5],
        size  => $s[7],
        mtime => $s[9],
    }
}

#
# Set the attributes for a file.  Returns non-zero on error.
#
sub attribSet
{
    my($fio, $f, $placeHolder) = @_;
    my $ret;

    #
    # Ignore placeholder attribute sets: only do real ones.
    #
    return if ( $placeHolder );

    my $lName = $fio->localName($f->{name});
    my @s = stat($lName);
    my $a = {
        mode  => $s[2],
        uid   => $s[4],
        gid   => $s[5],
        size  => $s[7],
        atime => $s[8],
        mtime => $s[9],
    };
    $f->{atime} = $f->{mtime} if ( !defined($f->{atime}) );
    if ( ($f->{mode} & ~S_IFMT) != ($a->{mode} & ~S_IFMT)
		&& !chmod($f->{mode} & ~S_IFMT, $lName) ) {
        $fio->log(sprintf("Can't chmod(%s, 0%o)", $lName, $f->{mode}));
        $ret = -1;
    }
    if ( ($f->{uid} != $a->{uid} || $f->{gid} != $a->{gid})
	    && !chown($f->{uid}, $f->{gid}, $lName) ) {
        $fio->log("Can't chown($f->{uid}, $f->{gid}, $lName)");
        $ret = -1;
    }
    if ( ($f->{mtime} != $a->{mtime} || $f->{atime} != $a->{atime})
            && !utime($f->{atime}, $f->{mtime}, $lName) ) {
        $fio->log("Can't mtime($f->{atime}, $f->{mtime}, $lName)");
        $ret = -1;
    }
    return $ret;
}

sub statsGet
{
    my($fio) = @_;

    return {};
}

#
# Make a given directory.  Returns non-zero on error.
#
sub makePath
{
    my($fio, $f) = @_;
    my $localDir = $fio->localName($f->{name});

    return $fio->attribSet($f) if ( -d $localDir );
    File::Path::mkpath($localDir, 0, $f->{mode});
    return $fio->attribSet($f) if ( -d $localDir );
    $fio->log("Can't create directory $localDir");
    return -1;
}

#
# Make a special file.  Returns non-zero on error.
#
sub makeSpecial
{
    my($fio, $f) = @_;
    my $localPath = $fio->localName($f->{name});

    #
    # TODO: check if the special file is the same, then do nothing.
    # Should also create as a new unique name, then rename/unlink.
    #
    $fio->unlink($f->{name});
    if ( ($f->{mode} & S_IFMT) == S_IFCHR ) {
	my($major, $minor);

	$major = $f->{rdev} >> 8;
	$minor = $f->{rdev} & 0xff;
	return system("mknod $localPath c $major $minor");
    } elsif ( ($f->{mode} & S_IFMT) == S_IFBLK ) {
	my($major, $minor);

	$major = $f->{rdev} >> 8;
	$minor = $f->{rdev} & 0xff;
	return system("mknod $localPath b $major $minor");
    } elsif ( ($f->{mode} & S_IFMT) == S_IFLNK ) {
	if ( !symlink($f->{link}, $localPath) ) {
	    # error
	}
    } elsif ( ($f->{mode} & S_IFMT) == S_IFIFO ) {
	if ( system("mknod $localPath p") ) {
	    # error
	}
    }
    return $fio->attribSet($f);
}

#
# Make a hardlink.  Returns non-zero on error.
# This actually gets called twice for each hardlink.
# Once as the file list is processed, and again at
# the end.  This subroutine should decide whether it
# should do the hardlinks during the transer or at
# the end.  Normally they would be done at the end
# since the target might not exist until them.
# BackupPC does them as it goes (since it is just saving the
# hardlink info and not actually making hardlinks).
#
sub makeHardLink
{
    my($fio, $f, $end) = @_;

    #
    # In this case, only do hardlinks at the end.
    #
    return if ( !$end );
    my $localPath = $fio->localName($f->{name});
    my $destLink  = $fio->localName($f->{hlink});
    $fio->unlink($localPath) if ( -e $localPath );
    return !link($destLink, $localPath);
}


sub unlink
{
    my($fio, $path) = @_;
    my $localPath   = $fio->localName($path);

    return if ( !-e $localPath && !-l $localPath );
    if ( -d _ ) {
	rmtree($localPath);
    } else {
	CORE::unlink($localPath);
    }
}

sub ignoreAttrOnFile
{
    return undef;
}

#
# Start receive of file deltas for a particular file.
#
sub fileDeltaRxStart
{
    my($fio, $f, $cnt, $size, $remainder) = @_;

    $fio->{rxFile}      = $f;           # file attributes
    $fio->{rxBlkCnt}    = $cnt;         # how many blocks we will receive
    $fio->{rxBlkSize}   = $size;        # block size
    $fio->{rxRemainder} = $remainder;   # size of the last block
    $fio->{rxMatchBlk}  = 0;            # current start of match
    $fio->{rxMatchNext} = 0;            # current next block of match
    $fio->{rxSize}      = 0;            # size of received file
    if ( $fio->{rxFile}{size} != ($cnt > 0
				 ? ($cnt - 1) * $size + $remainder
				 : 0) ) {
        $fio->{rxMatchBlk} = undef;     # size different, so no file match
        $fio->log("$fio->{rxFile}{name}: size doesn't match"
                  . " ($fio->{rxFile}{size})")
                        if ( $fio->{logLevel} >= 5 );
    }
    delete($fio->{rxInFd});
    delete($fio->{rxOutFd});
    delete($fio->{rxDigest});
    $fio->{rxFile}{localName} = $fio->localName($fio->{rxFile}{name});
}

#
# Process the next file delta for the current file.  Returns 0 if ok,
# -1 if not.  Must be called with either a block number, $blk, or new data,
# $newData, (not both) defined.
#
sub fileDeltaRxNext
{
    my($fio, $blk, $newData) = @_;

    if ( defined($blk) ) {
        if ( defined($fio->{rxMatchBlk}) && $fio->{rxMatchNext} == $blk ) {
            #
            # got the next block in order; just keep track.
            #
            $fio->{rxMatchNext}++;
            return;
        }
    }
    my $newDataLen = length($newData);
    $fio->log("$fio->{rxFile}{name}: blk=$blk, newData=$newDataLen,"
        . " rxMatchBlk=$fio->{rxMatchBlk}, rxMatchNext=$fio->{rxMatchNext}")
		    if ( $fio->{logLevel} >= 8 );
    if ( !defined($fio->{rxOutFd}) ) {
	#
	# maybe the file has no changes
	#
	if ( $fio->{rxMatchNext} == $fio->{rxBlkCnt}
		&& !defined($blk) && !defined($newData) ) {
	    #$fio->log("$fio->{rxFile}{name}: file is unchanged");
	    #		    if ( $fio->{logLevel} >= 8 );
	    return;
	}

        #
        # need to open a temporary output file where we will build the
        # new version.
        #
        local(*F);
        my $rxTmpFile;
        for ( my $i = 0 ; ; $i++ ) {
            $rxTmpFile = "$fio->{rxFile}{localName}__tmp__$$.$i";
            last if ( !-e $rxTmpFile );
        }
        if ( !open(F, ">$rxTmpFile") ) {
            $fio->log("Can't open/create $rxTmpFile");
            return -1;
        }
        $fio->log("$fio->{rxFile}{name}: opening tmp output file $rxTmpFile")
                        if ( $fio->{logLevel} >= 10 );
        $fio->{rxOutFd} = *F;
        $fio->{rxTmpFile} = $rxTmpFile;

        $fio->{rxDigest} = File::RsyncP::Digest->new($fio->{protocol_version});
        $fio->{rxDigest}->add(pack("V", $fio->{checksumSeed}));
    }
    if ( defined($fio->{rxMatchBlk})
                && $fio->{rxMatchBlk} != $fio->{rxMatchNext} ) {
        #
        # need to copy the sequence of blocks that matched
        #
        if ( !defined($fio->{rxInFd}) ) {
            if ( open(F, "$fio->{rxFile}{localName}") ) {
                $fio->{rxInFd} = *F;
            } else {
                $fio->log("Unable to open $fio->{rxFile}{localName}");
                return -1;
            }
        }
	my $lastBlk = $fio->{rxMatchNext} - 1;
        $fio->log("$fio->{rxFile}{name}: writing blocks $fio->{rxMatchBlk}.."
                  . "$lastBlk")
                        if ( $fio->{logLevel} >= 10 );
        my $seekPosn = $fio->{rxMatchBlk} * $fio->{rxBlkSize};
        if ( !sysseek($fio->{rxInFd}, $seekPosn, 0) ) {
            $fio->log("Unable to seek $fio->{rxFile}{localName} to $seekPosn");
            return -1;
        }
        my $cnt = $fio->{rxMatchNext} - $fio->{rxMatchBlk};
        my($thisCnt, $len, $data);
        for ( my $i = 0 ; $i < $cnt ; $i += $thisCnt ) {
            $thisCnt = $cnt - $i;
            $thisCnt = 512 if ( $thisCnt > 512 );
            if ( $fio->{rxMatchBlk} + $i + $thisCnt == $fio->{rxBlkCnt} ) {
                $len = ($thisCnt - 1) * $fio->{rxBlkSize} + $fio->{rxRemainder};
            } else {
                $len = $thisCnt * $fio->{rxBlkSize};
            }
            if ( sysread($fio->{rxInFd}, $data, $len) != $len ) {
                $fio->log("Unable to read $len bytes from"
                          . " $fio->{rxFile}{localName} ($i,$thisCnt,$fio->{rxBlkCnt})");
                return -1;
            }
            if ( syswrite($fio->{rxOutFd}, $data) != $len ) {
                $fio->log("Unable to write $len bytes to"
                          . " $fio->{rxTmpFile}");
            }
            $fio->{rxDigest}->add($data);
	    $fio->{rxSize} += length($data);
        }
        $fio->{rxMatchBlk} = undef;
    }
    if ( defined($blk) ) {
        #
        # Remember the new block number
        #
        $fio->{rxMatchBlk}  = $blk;
        $fio->{rxMatchNext} = $blk + 1;
    }
    if ( defined($newData) ) {
        #
        # Write the new chunk
        #
        my $len = length($newData);
        $fio->log("$fio->{rxFile}{name}: writing $len bytes new data")
                        if ( $fio->{logLevel} >= 10 );
        if ( syswrite($fio->{rxOutFd}, $newData) != $len ) {
            $fio->log("Unable to write $len bytes to $fio->{rxTmpFile}");
            return -1;
        }
        $fio->{rxDigest}->add($newData);
	$fio->{rxSize} += length($newData);
    }
    return;
}

#
# Finish up the current receive file.  Returns undef if ok, -1 if not.
# Returns 1 if the md4 digest doesn't match.
#
sub fileDeltaRxDone
{
    my($fio, $md4) = @_;

    if ( !defined($fio->{rxDigest}) ) {
        local(*F);
        #
        # File was exact match, but we still need to verify the
        # MD4 checksum.  Therefore open and read the file.
        #
        $fio->{rxDigest} = File::RsyncP::Digest->new($fio->{protocol_version});
        $fio->{rxDigest}->add(pack("V", $fio->{checksumSeed}));
        if ( open(F, $fio->{rxFile}{localName}) ) {
            $fio->{rxInFd} = *F;
	    while ( sysread($fio->{rxInFd}, my $data, 4 * 65536) > 0 ) {
		$fio->{rxDigest}->add($data);
		$fio->{rxSize} += length($data);
	    }
        } else {
	    # error
	}
        $fio->log("$fio->{rxFile}{name}: got exact match")
                        if ( $fio->{logLevel} >= 5 );
    }
    close($fio->{rxInFd})  if ( defined($fio->{rxInFd}) );
    close($fio->{rxOutFd}) if ( defined($fio->{rxOutFd}) );
    my $newDigest = $fio->{rxDigest}->digest;
    if ( $fio->{logLevel} >= 3 ) {
        my $md4Str = unpack("H*", $md4);
        my $newStr = unpack("H*", $newDigest);
        $fio->log("$fio->{rxFile}{name}: got digests $md4Str vs $newStr")
    }
    if ( $md4 eq $newDigest ) {
        #
        # Nothing to do if there is no output file
        #
        if ( !defined($fio->{rxOutFd}) ) {
            $fio->log("$fio->{rxFile}{name}: nothing to do")
                        if ( $fio->{logLevel} >= 5 );
	    return $fio->attribSet($fio->{rxFile});
        }

        #
        # First rename the original file (in case the rename below fails)
        # to a unique temporary name.
        #
	my $oldFile;
	if ( -e $fio->{rxFile}{localName} ) {
	    for ( my $i = 0 ; ; $i++ ) {
		$oldFile = "$fio->{rxFile}{localName}__old__$$.$i";
		last if ( !-e $oldFile );
	    }
	    $fio->log("$fio->{rxFile}{name}: unlinking/renaming")
			if ( $fio->{logLevel} >= 5 );
	    if ( !rename($fio->{rxFile}{localName}, $oldFile) ) {
		$fio->log("Can't rename $fio->{rxFile}{localName}"
			  . " to $oldFile");
		CORE::unlink($fio->{rxTmpFile});
		return -1;
	    }
	}
        if ( !rename($fio->{rxTmpFile}, $fio->{rxFile}{localName}) ) {
            #
            # Restore old file
            #
            if ( !rename($oldFile, $fio->{rxFile}{localName}) ) {
                $fio->log("Can't retore original file $oldFile after rename"
                          . " of $fio->{rxTmpFile} failed");
            } else {
                $fio->log("Can't rename $fio->{rxTmpFile} to"
                          . " $fio->{rxFile}{localName}");
            }
            return -1;
        }
	if ( defined($oldFile) && CORE::unlink($oldFile) != 1 ) {
            $fio->log("Can't unlink old file $oldFile");
            return -1;
        }
    } else {
        $fio->log("$fio->{rxFile}{name}: md4 doesn't match")
                    if ( $fio->{logLevel} >= 1 );
        CORE::unlink($fio->{rxTmpFile}) if ( defined($fio->{rxTmpFile}) );
        return 1;
    }
    delete($fio->{rxDigest});
    $fio->{rxFile}{size} = $fio->{rxSize};
    return $fio->attribSet($fio->{rxFile});
}

sub fileListEltSend
{
    my($fio, $name, $fList, $outputFunc) = @_;
    my @s;
    my $extra = {};

    (my $n = $name) =~ s/^\Q$fio->{localDir}/$fio->{remoteDir}/;
    if ( -l $name ) {
	@s = lstat($name);
	$extra = {
	    %$extra,
            link => readlink($name),
        };
    } else {
	@s = stat($name);
    }
    if ( $fio->{preserve_hard_links}
            && ($s[2] & S_IFMT) == S_IFREG
            && ($fio->{protocol_version} < 27 || $s[3] > 1) ) {
	$extra = {
	    %$extra,
            dev   => $s[0],
            inode => $s[1],
        };
    }
    $fio->log("fileList send $name (remote=$n)") if ( $fio->{logLevel} >= 3 );
    $fList->encode({
            name  => $n,
            mode  => $s[2],
            uid   => $s[4],
            gid   => $s[5],
            rdev  => $s[6],
            size  => $s[7],
            mtime => $s[9],
	    %$extra,
        });
    &$outputFunc($fList->encodeData);
}

sub fileListSend
{
    my($fio, $flist, $outputFunc) = @_;

    find({wanted => sub {
                $fio->fileListEltSend($File::Find::name, $flist, $outputFunc);
          },
          no_chdir => 1
      }, $fio->{localDir});
}

sub finish
{
    my($fio, $isChild) = @_;

    return;
}

#
# Default log handler
#
sub logHandler
{
    my($str) = @_;

    print(STDERR $str, "\n");
}

#
# Handle one or more log messages
#
sub log
{
    my($fio, @logStr) = @_;

    foreach my $str ( @logStr ) {
        next if ( $str eq "" );
        $fio->{logHandler}->($str);
    }
}

1;
__END__