view release on metacpan or  search on metacpan

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

#
# See http://perlrsync.sourceforge.net.
#
#========================================================================

package File::RsyncP;

use strict;
use Socket;
use File::RsyncP::Digest;
use File::RsyncP::FileIO;
use File::RsyncP::FileList;
use Getopt::Long;
use Data::Dumper;
use Config;
use Encode qw/from_to/;
use Fcntl;

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 $rs = bless {
        protocol_version => 28,
	logHandler       => \&logHandler,
	abort		 => 0,
	%$options,
    }, $class;

    #
    # In recent versions of rsync (eg: 2.6.8) --devices is no
    # longer identical to -D.  Now -D means --devices --specials.
    # File::RsyncP assumes --devices behaves the same as -D,
    # and doesn't currently handle --specials.
    #
    # To make sure we don't lie to the remote rsync, we must
    # send -D instead of --devices.  Therefore, we manually
    # replace --devices with -D in $rs->{rsyncArgs}.
    #
    for ( my $i = 0 ; $i < @{$rs->{rsyncArgs}} ; $i++ ) {
        $rs->{rsyncArgs}[$i] = "-D"
                    if ( $rs->{rsyncArgs}[$i] eq "--devices" );
    }

    #
    # process rsync options
    #
    local(@ARGV);
    $rs->{rsyncOpts} = {};
    @ARGV = @{$rs->{rsyncArgs}};

    my $p = new Getopt::Long::Parser(
		config => ["bundling", "pass_through"],
	    );

    #
    # First extract all the exclude related options for processing later
    #
    return if ( !$p->getoptions(
                "exclude=s",       sub { optExclude($rs, @_); },
                "exclude-from=s",  sub { optExclude($rs, @_); },
                "include=s",       sub { optExclude($rs, @_); },
                "include-from=s",  sub { optExclude($rs, @_); },
                "cvs-exclude|C",   sub { optExclude($rs, @_); },
	    ) );

    #
    # Since the exclude arguments are no longer needed (they are
    # passed via the socket, not the command-line args), update
    # $rs->{rsyncOpts}
    #
    @{$rs->{rsyncArgs}} = @ARGV;

    #
    # Now process the rest of the arguments we care about
    #
    return if ( !$p->getoptions($rs->{rsyncOpts},
		    "block-size=i",
		    "devices|D",
                    "from0|0",
		    "group|g",
		    "hard-links|H",
		    "ignore-times|I",
		    "links|l",
		    "numeric-ids",
		    "owner|o",
		    "perms|p",
		    "protocol=i",
		    "recursive|r",
		    "relative|R",
		    "timeout",
		    "verbose|v+",
	    ) );
    $rs->{blockSize}          = $rs->{rsyncOpts}{"block-size"};
    $rs->{timeout}          ||= $rs->{rsyncOpts}{timeout};
    $rs->{protocol_version}   = $rs->{rsyncOpts}{protocol}
		    if ( defined($rs->{rsyncOpts}{protocol}) );
    $rs->{fio_version} = 1;
    if ( !defined($rs->{fio}) ) {
	$rs->{fio} = File::RsyncP::FileIO->new({
			blockSize           => $rs->{blockSize},
			logLevel            => $rs->{logLevel},
                        protocol_version    => $rs->{protocol_version},
                        preserve_hard_links => $rs->{rsyncOpts}{"hard-links"},
			clientCharset       => $rs->{clientCharset},
		    });
	eval { $rs->{fio_version} = $rs->{fio}->version; };
    } else {
        #
        # Tell the existing FileIO module various parameters that
        # depend upon the parsed rsync args
        #
	eval { $rs->{fio_version} = $rs->{fio}->version; };
	$rs->{fio}->blockSize($rs->{blockSize});
	if ( $rs->{fio_version} >= 2 ) {
	    $rs->{fio}->protocol_version($rs->{protocol_version});
	    $rs->{fio}->preserve_hard_links($rs->{rsyncOpts}{"hard-links"});
	} else {
	    #
	    # old version of FileIO: only supports version 26
	    #
	    $rs->{protocol_version} = 26 if ( $rs->{protocol_version} > 26 );
	}
    }

    #
    # build signal list in case we do an abort
    #
    my $i = 0;
    foreach my $name ( split(' ', $Config{sig_name}) ) {
	$rs->{sigName2Num}{$name} = $i;
	$i++;
    }
    return $rs;
}

sub optExclude
{
    my($rs, $argName, $argValue) = @_;

    push(@{$rs->{excludeArgs}}, {name => $argName, value => $argValue});
}

#
# Strip the exclude and include arguments from the given argument list
#
sub excludeStrip
{
    my($rs, $args) = @_;
    local(@ARGV);
    my $p = new Getopt::Long::Parser(
		config => ["bundling", "pass_through"],
	    );

    @ARGV = @$args;

    #
    # Extract all the exclude related options
    #
    $p->getoptions(
            "exclude=s",       sub { },
            "exclude-from=s",  sub { },
            "include=s",       sub { },
            "include-from=s",  sub { },
            "cvs-exclude|C",   sub { },
        );

    return \@ARGV;
}

sub serverConnect
{
    my($rs, $host, $port) = @_;
    #local(*FH);

    $port ||= 873;
    my $proto = getprotobyname('tcp');
    my $iaddr = inet_aton($host)     || return "unknown host $host";
    my $paddr = sockaddr_in($port, $iaddr);

    alarm($rs->{timeout}) if ( $rs->{timeout} );
    socket(FH, PF_INET, SOCK_STREAM, $proto)
				    || return "inet socket: $!";
    connect(FH, $paddr)             || return "inet connect: $!";
    $rs->{fh} = *FH;
    $rs->writeData("\@RSYNCD: $rs->{protocol_version}\n", 1);
    my $line = $rs->getLine;
    alarm(0) if ( $rs->{timeout} );
    if ( $line !~ /\@RSYNCD:\s*(\d+)/ ) {
	return "unexpected response $line\n";
    }
    $rs->{remote_protocol} = $1;
    if ( $rs->{remote_protocol} < 20 || $rs->{remote_protocol} > 40 ) {
        return "Bad protocol version: $rs->{remote_protocol}\n";
    }
    $rs->log("Connected to $host:$port, remote version $rs->{remote_protocol}")
                        if ( $rs->{logLevel} >= 1 );
    $rs->{protocol_version} = $rs->{remote_protocol}
                        if ( $rs->{protocol_version} > $rs->{remote_protocol} );
    $rs->{fio}->protocol_version($rs->{protocol_version})
			if ( $rs->{fio_version} >= 2 );
    $rs->log("Negotiated protocol version $rs->{protocol_version}")
                        if ( $rs->{logLevel} >= 1 );
    return;
}

sub serverList
{
    my($rs) = @_;
    my(@service);