Realsync with command overrides

realsync_cmd

#!/usr/bin/perl -w
use Cwd qw(getcwd abs_path);
use strict;
use File::Basename;
use File::Path qw(mkpath rmtree);
use File::Spec;
use Text::ParseWords;
use IPC::Open2;
use IO::Handle;
use Digest::MD5 'md5_hex';
use Fcntl ':mode';
use POSIX ":sys_wait_h";
use threads;
use threads::shared;

# Paths (will be filled later automatically).
my $DIR_PRIVATE = undef;              # private area directory (holds e.g. .ssh folder)
my $FILE_CONFIG = undef;              # config file
my $FILE_IDENTITY = undef;            # identity file within .ssh folder

# Constants.
my $BINDIR = dirname(abs_path(__FILE__));
my $DELAY = 0.2;
my $DEBUG_PATCH_TREE = 0;
my $SSH_VERBOSE = 0;
my $MIN_CHANGES_FOR_RSYNC = 10;
my @SSH_OPTIONS = (
    "-o", "Compression=yes",
    "-o", "CompressionLevel=9",
    "-o", "ConnectTimeout=3",
    "-o", "ServerAliveInterval=2",
    "-o", "ServerAliveCountMax=4",
    "-o", "StrictHostKeyChecking=no",
);
my @RSYNC_OPTIONS = (
    "-rltzxv",
    "--delete",
);
my @RSYNC_WRAPPER = ();
my @RSYNC_SSH_WRAPPER = ();
my $REALSYNC_SPEC_FILE = $ENV{'REALSYNC_SPEC_FILE'} ? $ENV{'REALSYNC_SPEC_FILE'} : ".realsync";
if ($REALSYNC_SPEC_FILE ne ".realsync") {
  print "Using REALSYNC_SPEC_FILE: $REALSYNC_SPEC_FILE\n";
}

my @DEFAULT_EXCLUDE = ($REALSYNC_SPEC_FILE, "CVS", ".git", ".svn", ".hg", ".cache", ".idea", "nbproject", "~*", "*.tmp", "*.pyc", "*.swp");

# Globals.
my %CONFIG;
my %CONFIG_OVERRIDES;
my $REM_SCRIPT = get_remote_script();
my $SSH_PID;
my @TREE;
my $IN_REPLICATION = 0;
my $HOOKS =
    ($ENV{COMSPEC} && 'Realsync::Win32')
    || ($^O =~ /darwin/i && 'Realsync::Darwin')
    || ($^O =~ /linux/i && 'Realsync::Linux')
    || 'Realsync::Generic';
my %PENDING: shared = ();


#
# Does everything,
#
sub main {
    my $arg_index = 0;

    if (defined $ARGV[0] && $ARGV[0] eq '-h') {
      $CONFIG_OVERRIDES{host} = $ARGV[1];
      $arg_index = 2;
    }

    eval {
        print "dkLab RealSync: replicate developer's files over SSH in realtime.\n\n";

        # Make remote script's subs available.
        eval("sub { $REM_SCRIPT }"); die $@ if $@;

        # If an argument is passed, chdir to that directory. Else use the current one.
        my $chdir = $ARGV[$arg_index];
        if (!defined $chdir && -f $REALSYNC_SPEC_FILE) {
            $chdir = ".";
        }
        if (!defined $chdir) {
            die "Usage:\n  realsync SOURCE_DIRECTORY_WHICH_IS_REPLICATED\n";
        }
        chdir($chdir) or die "Cannot set current directory to $chdir: $!\n";

        # Initialize and (possibly) correct environment.
        $HOOKS->init_env();

        # Correct pathes.
        build_pathes_based_on_cwd();

        # Run the mainloop.
        mainloop();
    };
    if ($@) {
        if (!$IN_REPLICATION) {
            print STDERR $@;
        } else {
            logger($@);
        }
        print STDERR "\nPress Enter to quit... ";
        scalar <STDIN>;
    }
}


#
# Main execution loop.
# Called inside eval{} block to catch errors and print them.
#
sub mainloop {
    binmode(STDIN);  STDIN->autoflush(1);
    binmode(STDOUT); STDOUT->autoflush(1);
    binmode(STDERR); STDERR->autoflush(1);

    $SIG{CHLD} = 'IGNORE'; # later, if you use system(), reset this signal!
    $SIG{PIPE} = 'IGNORE'; # do not kill the whole realsync if remote SSH dies
    $SIG{INT} = $SIG{TERM} = $SIG{KILL} = sub { onexit(); exit; };

    if (!-d $DIR_PRIVATE || !-f $FILE_CONFIG) {
        do_install();
    }

    # If we use a custom identity file, switch home dir to its directory.
    if (-f $FILE_IDENTITY) {
        $ENV{HOME} = $DIR_PRIVATE;
    }

    # Read configuration.
    %CONFIG = read_config($FILE_CONFIG, %CONFIG_OVERRIDES);
    if ($CONFIG{identity}) {
        $FILE_IDENTITY = $CONFIG{identity};
    }

    # We MUST avoid chdir: in Cygwin we have problems with non-ASCII names.
    -d cfg("local") or die "Bad local directory " . cfg("local") . ": $!\n";

    $IN_REPLICATION = 1;

    spawn_notify_daemon();
    $HOOKS->init_gui();

    while (1) {
        eval { do_replication() };
        logger($@) if $@;
        onexit(1);
        sleep(1);
    }
}


#
# Called at script dead.
#
sub onexit {
    my ($iteration_end) = @_;
    if ($IN_REPLICATION) {
        kill(9, $SSH_PID) if $SSH_PID;
        $SSH_PID = undef;
        notification("wait");
    }
    if (!$iteration_end) {
        $HOOKS->finalize_env() if $HOOKS;
    }
}


#
# Called at the end of script.
#
sub END {
    onexit();
}


#
# Builds pathes and saves it to global variables.
#
sub build_pathes_based_on_cwd {
    my ($is_tmp) = @_;
    my $dir_appdata = ($ENV{APPDATA} || $ENV{HOME}) or die "Environment variable HOME must be set!\n";
    # First, try to use legacy scheme.
    build_pathes_based_on_cwd_legacy($dir_appdata, $is_tmp);
    return if -f $FILE_CONFIG;
    # Use a new scheme.
    my $cwd = getcwd();
    my $hash = $cwd;
    $hash =~ s{^\w:[/\\]|[/\\]+$}{}sg;
    $hash =~ s{\W+}{_}sgi;
    $hash = substr($hash, -80) if length($hash) > 80;
    $hash = substr(md5_hex($cwd), 0, 10) . "_" . $hash;
    # Build pathes.
    $DIR_PRIVATE = $dir_appdata . "/$REALSYNC_SPEC_FILE/" . $hash;
    $DIR_PRIVATE .= ".tmp" if $is_tmp;
    $FILE_IDENTITY = "$DIR_PRIVATE/.ssh/identity";
    $FILE_CONFIG = "$cwd/$REALSYNC_SPEC_FILE";
}


#
# Legacy pathes for configuration.
#
sub build_pathes_based_on_cwd_legacy {
    my ($dir_appdata, $is_tmp) = @_;
    $DIR_PRIVATE = $dir_appdata . "/$REALSYNC_SPEC_FILE/" . substr(md5_hex(getcwd()), 0, 10);
    $DIR_PRIVATE .= ".tmp" if $is_tmp;
    $FILE_CONFIG = "$DIR_PRIVATE/realsync.ini";
    $FILE_IDENTITY = "$DIR_PRIVATE/.ssh/identity";
}


#
# Executes the whole replication algorithm.
#
sub do_replication {
    # Run SSH asynchronously to save time.
    do_run_ssh("Initiating a background connection with " . cfg("remote") . "...");

    # Read initial state BEFORE rsync!
    @TREE = ();
    my $num_objs = grep { $_->{type} eq "dir" } get_changes();

    # Initial rsync.
    do_rsync("Fast initial rsync synchronization...") if !$DEBUG_PATCH_TREE;

    # Watching.
    logger("", 0, 1);
    do_watch("Watching for changes in $num_objs folder(s)...");
}


#
# Executes RSYNC command.
#
sub do_rsync {
    my ($msg) = @_;
    my ($h_host, $h_port) = parse_host_spec(cfg("host"));
    my @rsync_cmd = (
        @RSYNC_WRAPPER,
        "rsync",
        "-e", join(" ",
            @RSYNC_SSH_WRAPPER,
            "ssh",
            (-f $FILE_IDENTITY ? ("-i", $FILE_IDENTITY) : ()),
            split_cmd_args(cfg("ssh_options")),
            "-p$h_port"
        ),
        split_cmd_args(cfg("rsync_options")),
        $HOOKS->convert_rsync_local_path(cfg("local")) . "/", # the trailing slash is significant!
        cfg("user") . '@' . $h_host . ":" . cfg("remote") . "/",
        map { ("--exclude", $_) } @{cfg("exclude", 1)},
    );
    notification("rsync");
    while (1) {
        logger($msg);
        #logger(join(" ", map { /\s|\*/s ? '"' . $_ . '"' : $_ } @rsync_cmd));
        local $SIG{CHLD}; # else system() does not work
        local $SIG{PIPE}; # to be on a safe side
        my $exitcode = system(@rsync_cmd);
        if (!defined $exitcode || $exitcode < 0) {
            logger("Failed to run rsync: $!\n");
        } elsif ($exitcode & 127) {
            logger("Rsync died with signal " . ($exitcode & 127));
        } elsif (($exitcode >> 8) == 0) {
            last;
        } else {
            logger("Rsync exited with code " . ($exitcode >> 8) . ", retrying...");
        }
        usleep(0.5);
    }
    notification("wait");
}


#
# Executes background SSH process which is used to push changes.
#
sub do_run_ssh {
    my ($msg) = @_;
    logger($msg);
    my $rem_script = $REM_SCRIPT;
    $rem_script =~ s/!/@@/sg; # for tcsh
    my ($h_host, $h_port) = parse_host_spec(cfg("host"));
    my @ssh_cmd = (
        "ssh",
        ($SSH_VERBOSE ? ("-v") : ()),
        (-f $FILE_IDENTITY ? ("-i", $FILE_IDENTITY) : ()),
        split_cmd_args(cfg("ssh_options")),
        "-p$h_port",
        cfg("user") . '@' . $h_host,
        # For TCSH we must NEVER insert "!" character into arguments, else it
        # breaks the program. So we previously replace "!" to "@@" and then,
        # at the remote side, replace it back to "!", but with no "!" specification.
        q{exec perl -we '$_=$ARGV[0]; s/@@/\x21/sg; eval($_); die $@ if $@;'} . " '$rem_script'"
    );
#   use Data::Dumper; print Dumper(\@ssh_cmd); exit;
    # Unfortunately on Win32 we cannot read from a handle returned
    # from the first open2's argument - Perl hangs even if buffering
    # is correctly turned off. So we cannot receive a feedback from
    # a remote SSH and are just passively displaying its output.
    $SSH_PID = open2(">&STDOUT", \*IN, @ssh_cmd) or die "Cannot run ssh: $!\n";
    binmode IN; IN->autoflush(1);
}


#
# Performs endless changes watching.
#
sub do_watch {
    my ($msg) = @_;
    logger($msg);
    # Watching loop.
    print IN cfg("remote") . "\n";
    notification("replication");
    my $candidates = undef;
    while (1) {
        my @changes = get_changes($candidates);
        if (@changes > $MIN_CHANGES_FOR_RSYNC) {
            do_rsync("Detected changes in more than $MIN_CHANGES_FOR_RSYNC objects. Running rsync: it's faster.");
        } elsif (@changes) {
            logger("Detected " . @changes . " change(s), transmitting...");
            notification("transfer");
            foreach my $change (@changes) {
                write_change(\*IN, $change);
            }
            notification("wait");
        }
        # Wait with periodical callback checking.
        $candidates = wait_notify(sub {
            if (!$SSH_PID || !kill(0, $SSH_PID)) {
                die "SSH client died, restarting.\n";
            }
        });
    }
}


#
# Performs installation process.
#
sub do_install {
    local $SIG{CHLD}; # else system() does not work
    local $SIG{PIPE}; # to be on a safe side

    my $step_num = 1;
    my $step_text = sub {
        my $s = "(Step $step_num) $_[0]";
        $step_num++;
        return $s;
    };

    print "THIS WIZARD APPEARS ONLY ONCE!\nNEXT TIME THE REPLICATION WILL START IMMEDIATELY.\n\n";

    my %CONFIG = ();
    if (-f $FILE_CONFIG) {
        %CONFIG = read_config($FILE_CONFIG, %CONFIG_OVERRIDES);
        print "Read options from existing config: $FILE_CONFIG.\n";
    } else {
        print "Starting an interactive installation.\n";
    }
    print "\n";

    my @config = ();

    my $local;
    if (!defined $CONFIG{local}) {
        $local = ask(
            $step_text->("LOCAL directory to replicate FROM:\n  "),
            getcwd(),
            sub { -d $_ ? undef : "No such directory: $_" }
        );
        $local = "." if $local eq getcwd();
        $local =~ s{\\}{/}sg;
        $local =~ s{/+$}{}sg;
        push @config, {
            "name"    => "local",
            "value"   => $local,
            "comment" => "Local directory to be realtime-replicated.",
        };
    } else {
        $local = $CONFIG{local};
    }

    chdir($local) or die "Cannot chdir to $local: $!\n";
    build_pathes_based_on_cwd(1); # builds TEMPORARY paths
    mkpath($DIR_PRIVATE, 0, 0700); # IMPORTANT: it's a marker to skip the installation wizard next time

    my $host = undef;
    my $user = undef;
    my $step_save = $step_num;
    while (1) {
        $step_num = $step_save;

        if (!defined $CONFIG{host}) {
            push @config, {
                "name"    => "host",
                "value"   => ($host = ask(
                    $step_text->("REMOTE host to replicate TO (host or host:port):"),
                    $host,
                    sub { /^[-\w.]+(?::\d+)?$/s ? undef : "Invalid hostname!" }
                )),
                "comment" => "Remote host to replicate to over SSH.",
            };
        } else {
            $host = $CONFIG{host};
        }

        if (!defined $CONFIG{user}) {
            push @config, {
                "name"    => "user",
                "value"   => ($user = ask(
                    $step_text->("REMOTE SSH login at $host:"),
                    $user,
                    sub { /^\S+$/s ? undef : "Invalid login format!" }
                )),
                "comment" => "User to connect to the remote host.",
            };
        } else {
            $user = $CONFIG{user};
        }

        # Check if we already have a passwordless access.
        print "Checking if we have access to $user\@$host with no password...\n";
        my ($h_host, $h_port) = parse_host_spec($host);
        my $cmd_check = "ssh -q -o PasswordAuthentication=no -o BatchMode=yes -o StrictHostKeyChecking=no -p$h_port $user\@$h_host exit";
        if (system($cmd_check) == 0) {
            print "   we already have access to the host, continuing.\n";
            last;
        } else {
            print "   no access, generating new SSH keys.\n";
        }

        # Use a custom SSH key (create a new one if no key exists).
        mkpath(dirname($FILE_IDENTITY), 0, 0700);
        if (!-f $FILE_IDENTITY) {
            my $cmd = "ssh-keygen -N \"\" -q -t rsa -b 2048 -f $FILE_IDENTITY";
            if (system($cmd)) {
                die "Cannot generate SSH keys. ssh-keygen: $!\n$cmd\n";
            }
            # Temporarily rename the file to avoid the case when the next
            # pubkey copying failed and the user restarts realsync again.
            rename($FILE_IDENTITY, "$FILE_IDENTITY.tmp");
        }

        # For users who ask: "should I enter my password each time?"
        ask($step_text->("ONLY ONCE you will be asked for a password. Continue?"), "y");
        my $pub_file = "$FILE_IDENTITY.pub";

        # system() is better than popen(), because Perl does not flush a child
        # process'es STDERR till we read from STDIN (Win32 perl bug?).
        print "Copying SSH key to $user\@$host. Executing:\n";
        my $cmd = "ssh"
            . " -o StrictHostKeyChecking=no -p$h_port $user\@$h_host\n"
            . ' "cd; umask 077; test -d .ssh && chmod 700 .ssh || mkdir .ssh;'
            . ' test -e .ssh/authorized_keys && chmod 600 .ssh/authorized_keys; (echo; cat)'
            . ' >> .ssh/authorized_keys"';
        my $show = '$ ' . $cmd;
        print "$show\n";
        $cmd =~ s/\s*\n\s*/ /sg;
        if (system("$cmd < $pub_file")) {
            print STDERR "\n";
            print STDERR "Failed connecting to $user\@$host. Please enter a correct host, login and password.\n";
            print STDERR "\n";
            next;
        }
        print "Public key $pub_file is copied to $user\@$host!\n";
        print "\n";
        # Successfully copied, so rename the file back.
        rename("$FILE_IDENTITY.tmp", $FILE_IDENTITY);

        last;
    }

    if (!defined $CONFIG{remote}) {
        push @config, {
            "name"    => "remote",
            "value"   => ask(
                $step_text->("REMOTE directory at $user\@$host to replicate to:"),
                undef,
                sub {
                    print "   checking if the directory exists...\n";
                    my ($h_host, $h_port) = parse_host_spec($host);
                    my $cmd = "ssh"
                        . (-f $FILE_IDENTITY ? " -i $FILE_IDENTITY" : "")
                        . " -o StrictHostKeyChecking=no -p$h_port $user\@$h_host \"test -d $_\"";
                    my $ret = system($cmd) >> 8;
                    if ($ret != 0) {
                        return "Directory $_ at $user\@$host does not exist. Try again.";
                    }
                    return;
                }
            ),
            "comment" => "Directory at the remote host to replicate files to.",
        };
    } else {
        # Pass.
    }

    if (!defined $CONFIG{exclude}) {
        print "\n";
        my $excludes = ask(
            $step_text->(
                "Exclusions from " . basename($FILE_CONFIG) . " configuration are:\n" .
                "  " . join(" ", @DEFAULT_EXCLUDE) . "\n" .
                "Enter a space-separated list of ADDITIONAL exclusions:",
            ),
            ""
        );
        my $first = 1;
        foreach my $mask (@DEFAULT_EXCLUDE, grep { length } split(m/[\s+,]+/s, $excludes)) {
            push @config, {
                "name"    => "exclude",
                "value"   => $mask,
                "comment" => $first ? "Pathname wildcards to be excluded from the replication.\nUse \"*\" for any filename character and \"**\" for any character,\nincluding \"/\" in pathnames." : undef,
            };
            $first = 0;
        }
    } else {
        # Pass.
    }

    if (!%CONFIG) {
        push @config, {
            "name"    => "#exclude_file",
            "value"   => ".gitignore",
            "comment" => "You may read exclusion list from e.g. a .gitignore file.",
        };
    }

    if (!defined $CONFIG{nosound}) {
        push @config, {
            "name"    => "nosound",
            "value"   => "0",
            "comment" => "To turn off \"synchronization ding\" sound, set the following to 1.",
        };
    }

    if (!%CONFIG) {
        unshift @config, {
            "name"    => "#load",
            "value"   => "$REALSYNC_SPEC_FILE-local",
            "comment" => "You may load some other config files. It's a good practice to put\n"
                       . "all user-specific options (e.g. \"user\" directive, see below) to\n"
                       . "$REALSYNC_SPEC_FILE-local plus add this file to .gitignore. After that\n"
                       . "you commit the current $REALSYNC_SPEC_FILE file to your version control\n"
                       . "system, so developers may just override options in their own local files."
        };

        push @config, {
            "name"    => "#rsync_options",
            "value"   => join(" ", @RSYNC_OPTIONS),
            "comment" => "Options passed to RSYNC.",
        };

        push @config, {
            "name"    => "#ssh_options",
            "value"   => join(" ", @SSH_OPTIONS),
            "comment" => "Options passed to SSH.",
        };
    }

    print "\n";

    if (@config) {
        open(local *F, ">>", $FILE_CONFIG);
        if (!%CONFIG) {
            print F "##\n";
            print F "## dkLab RealSync configuration file.\n";
            print F "##\n";
        }
        foreach my $opt (@config) {
            my $comment = $opt->{comment};
            if ($comment) {
                $comment =~ s/^/# /mg;
                print F "\n$comment\n";
            }
            print F $opt->{name} . " = " . $opt->{value} . "\n";
        }
        close(F);
        print "All done. The configuration file has been updated.\n";
    }

    print "Configuration file is:\n  $FILE_CONFIG\n";
    if (-f $FILE_IDENTITY) {
        print "Generated SSH private key is saved to:\n";
        print "  $FILE_IDENTITY\n";
    }

    # Flip tmp keys directory into the permanent one at the very end, so if
    # one presses Ctrl+C above and relaunches, everything is started from scratch.
    my ($tmp_dir_private) = ($DIR_PRIVATE);
    build_pathes_based_on_cwd();
    rename($tmp_dir_private, $DIR_PRIVATE);

    print "\n";
    print "Press Enter start the replication. ";
    scalar <STDIN>;
}


#
# Asks a question interactively.
# Used by installer only.
#
sub ask {
    my ($msg, $default, $check) = @_;
    while (1) {
        print $msg . " ";
        print "[" . (length $default ? $default : "<none>") . "] " if defined $default;
        local $_ = <STDIN>;
        s/^\s+|\s+$//sg;
        if ($_ eq "") {
            return $default if defined $default;
            next;
        }
        if ($check) {
            my $err = $check->();
            if ($err) {
                print "$err\n";
                next;
            }
        }
        return $_;
    }
}


#
# Reads a config item value.
#
sub cfg {
    my ($name, $nodie) = @_;
    my $value = $CONFIG{$name};
    if ($name eq "ssh_options") {
        $value ||= join(" ", @SSH_OPTIONS);
    }
    if ($name eq "rsync_options") {
        $value ||= join(" ", @RSYNC_OPTIONS);
    }
    if (!$nodie) {
        if (!defined $value) {
            die("Cannot read \"$name\" configuration option at $FILE_CONFIG!\n");
        }
    }
    if ($name eq "local" || $name eq "remote") {
        # Trailing slash is removed, but added at rsync call manually,
        # because it is significant for rsync.
        $value =~ s{[/\\]+$}{}sg;
    }
    return $value;
}


#
# Precise sleep function.
#
sub usleep {
    my ($delay) = @_;
    select(undef, undef, undef, $delay);
}


#
# Pass information about background file changes monitoring.
# This is an abstraction level for multi-thread communication.
#
{
    my $NOTIFIES_SUPPORTED: shared = 0;
    my @NOTIFIES: shared = ();

    sub notifies_set_supported {
        my ($flag) = @_;
        lock $NOTIFIES_SUPPORTED;
        $NOTIFIES_SUPPORTED = !!$flag;
    }

    sub notifies_is_supported {
        lock $NOTIFIES_SUPPORTED;
        return $NOTIFIES_SUPPORTED;
    }

    sub notifies_push {
        lock @NOTIFIES;
        push @NOTIFIES, @_;
    }

    sub notifies_pop {
        lock @NOTIFIES;
        my @changes = @NOTIFIES;
        @NOTIFIES = ();
        return @changes;
    }
}


#
# Calculates filesystem changes between the previous call to
# get_changes() and the current time.
#
sub get_changes {
    my ($candidates) = @_;
    my @changes = ();

    # Build current tree.
    my @cur_tree = ();
    if (!$candidates || !@$candidates) {
        make_tree(\@cur_tree, ".");
    } else {
        @cur_tree = @TREE;
        $candidates = expand_dir_candidates(\@cur_tree, $candidates);
        if ($DEBUG_PATCH_TREE) {
            foreach (@$candidates) { print "Candidate: $_\n" }
        }
        patch_tree(\@cur_tree, $candidates);
    }
#   foreach (@cur_tree) { print $_->{name} . "\n"; } print "\n";
#   use Data::Dumper; print Dumper(\@cur_tree); exit;

    # Collect deleted entries.
    my %cur_tree = map { ($_->{name} => $_) } @cur_tree;
    for (my $i = 0; $i < @TREE; $i++) {
        my $prev = $TREE[$i];
        my $name = $prev->{name};
        if (!$cur_tree{$name}) {
            push @changes, {
                type => "del",
                name => $name,
            };
            # Skip children entries.
            for (++$i; $i < @TREE; $i++) {
                last if substr($TREE[$i]->{name}, 0, length($name) + 1) ne "$name/";
            }
            --$i;
        }
    }

    # Collect added entries.
    my %TREE = map { ($_->{name} => $_) } @TREE;
    foreach my $cur (@cur_tree) {
        my $name = $cur->{name};
        if (!$TREE{$name} || $TREE{$name}{stamp} != $cur->{stamp} || $TREE{$name}{perm} ne $cur->{perm}) {
            push @changes, $cur;
        }
    }

#   use Data::Dumper; open(local *F, ">/realsync.debug"); print F Dumper(\@TREE) . "\n\n"; print F Dumper(\@changes);
    @TREE = @cur_tree;

    return @changes;
}


#
# Reads filesystem information about $rel.
# Returns undef if no such file/directory exists.
#
sub make_tree_item {
    my ($rel) = @_;
    my $exclude_re = cfg("exclude_re", 1);
    # We use substr($rel, 1) below, because we need to cut leading "."
    # (rel pathes are ALWAYS started with ".", so we must cat to avoid its
    # matching with ".*" glob wildcard: e.g. "./aa/b" does match ".*"
    # glob wildcard, but "/aa/b" - does not.
    return if $exclude_re && $rel ne "." && substr($rel, 1) =~ $exclude_re;
    my $local = cfg("local");
    my $fullpath = "$local/$rel";
    my @stat = stat($fullpath);
    return if !@stat; # hmm? but it is needed for linux mcedit
    my $cur = {
        path  => $fullpath,
        name  => $rel,
        stamp => $stat[9],
        perm  => ($HOOKS eq 'Realsync::Win32' ? "" : ($stat[2] & 0777)), # Skip perms for Windows
    };
    if (S_ISREG($stat[2])) {
        $cur->{type} = "fil";
    } elsif (S_ISDIR($stat[2])) {
        $cur->{type} = "dir";
    }
    return $cur;
}


#
# Makes a tree from the filesystem. You may limit recursion by $max_level: e.g.
# if it is 1, only $rel and its direct children (if any) are returned.
#
sub make_tree {
    my ($tree, $rel, $max_level) = @_;
    my $cur = make_tree_item($rel) or return;
    push @$tree, $cur;
    return if defined($max_level) && $max_level == 0;
    if ($cur->{type} eq "dir") {
        opendir(local *D, $cur->{path}) or die "Cannot opendir $cur->{path}: $!\n";
        my @content = sort readdir(D); # sort is VERY important here! we use bsearch!
        closedir(D);
        foreach my $e (@content) {
            next if $e eq "." || $e eq "..";
            make_tree($tree, $cur->{name} . "/" . $e, (defined($max_level) ? $max_level - 1 : undef));
        }
    }
}


#
# Updates the current tree in memory checking statuses of enumerated
# candidate elements (each of them may be changed, added or removed).
#
sub patch_tree {
    my ($tree, $candidates) = @_;
    foreach my $cand (@$candidates) {
        my $branch_start_idx = find_branch_start_in_tree($tree, $cand);
        if (!defined($tree->[$branch_start_idx]) || $tree->[$branch_start_idx]->{name} ne $cand) {
            # Candidate is not within the tree, add it at $branch_start_idx pos.
            my @subtree;
            make_tree(\@subtree, $cand);
            splice(@$tree, $branch_start_idx, 0, @subtree);
        } else {
            # Candidate is within the old tree.
            my $new_item = make_tree_item($cand);
            if (!$new_item) {
                # Item was deleted. Also remove its children.
                my $branch_end_idx = find_branch_end_in_tree($tree, $cand, $branch_start_idx);
                splice(@$tree, $branch_start_idx, $branch_end_idx - $branch_start_idx + 1);
            } else {
                # Item was modified. Just update the previous one.
                splice(@$tree, $branch_start_idx, 1, $new_item);
            }
        }
    }
}


#
# For each directory in the candidates list expand it to all direct
# children of this directory (existed now or existed previously).
#
sub expand_dir_candidates {
    my ($tree, $candidates) = @_;
    my %expanded = ();
    foreach my $cand (@$candidates) {
        my $item = make_tree_item($cand);
        if (!$item || $item->{type} eq 'fil') {
            $expanded{$cand} = undef;
        } elsif ($item->{type} eq 'dir') {
            # First, files/directories which exist directly below $cand NOW (including $cand).
            my @existed = ();
            make_tree(\@existed, $cand, 1);
            @expanded{map { $_->{name} } @existed} = ();
            # Next, add sub-files/sub-directories which exist PREVIOUSLY.
            my @previous = ();
            my $branch_start_idx = find_branch_start_in_tree($tree, $cand);
            my $branch_end_idx = find_branch_end_in_tree($tree, $cand, $branch_start_idx);
            my $item_is_child_to_cand_re = qr{^\Q$cand\E/[^/]+$}s;
            for (my $i = $branch_start_idx + 1; $i <= $branch_end_idx; $i++) {
                my $name = $tree->[$i]->{name};
                $expanded{$name} = undef if $name =~ $item_is_child_to_cand_re;
            }
        }
    }
    return [sort keys %expanded];
}


#
# Searches for $rel position within the tree. If nothing is found,
# returns a position at which $rel should be inserted alphabethically.
#
sub find_branch_start_in_tree {
    my ($tree, $rel) = @_;
    my $idx = binsearch(
        sub {
            # Make "/" to be the lowest possible priority. This is needed, because
            # the plain "/" is greater than ".", so we have a WRONG ordering:
            # - aaa/bbb
            # - aaa/bbb.ext
            # - aaa/bbb/ccc
            # This is wrong, the correct order must be:
            # - aaa/bbb
            # - aaa/bbb/ccc
            # - aaa/bbb.ext
            my $a = $_[0];         $a =~ tr{/}{\x00};
            my $b = $_[1]->{name}; $b =~ tr{/}{\x00};
            return $a cmp $b;
        },
        $rel,
        $tree
    );
    return $idx;
}


#
# Starting from $branch_start_idx position in the tree, searches for
# the last item which is descendand of $rel (or equals to $rel).
#
sub find_branch_end_in_tree {
    my ($tree, $rel, $branch_start_idx) = @_;
    my $i;
    for ($i = $branch_start_idx + 1; $i < @$tree; $i++) {
        last if substr($tree->[$i]->{name}, 0, length($rel) + 1) ne "$rel/";
    }
    $i--;
    return $i;
}


#
# Sorted array binary search.
# Returns the index of the position at which $s must be situated.
#
sub binsearch {
    my ($f, $s, $list) = @_;
    my $i = 0;
    my $j = $#$list;
    for (;;) {
        my $k = int(($j - $i) / 2) + $i;
        my $c = &$f($s, $list->[$k]);
        #printf "== %s...%s k=%s  %s <=> %s = %s\n", $i, $j, $k, $s, $list->[$k], $c;

        if ($c == 0) {
            return $k;
        } elsif ($c < 0) {
            $j = $k - 1;
            return $k if ($i > $j);
        } else {
            $i = $k + 1;
            return $i if ($i > $j);
        }
    }
}


#
# Splits command-line arguments by spaces (with correct quotes processing).
#
sub split_cmd_args {
    my ($s) = @_;
    return Text::ParseWords::shellwords($s);
}


#
# Reads a configuration file.
#
sub read_config {
    my ($file) = @_;
    shift;
    my %config_overrides = @_;
    open(local *F, $file) or die "Cannot open $file: $!\n";
    my %config;
    while (<F>) {
        # Comments could be at the beginning of the line only,
        # because "#" character is valid e.g. inside a file path.
        s/^\s*#.*//sg;
        s/^\s+|\s+$//sg;
        next if !$_;
        my ($k, $v) = ($_ =~ m/^(\w+)(?:\s*=\s*|\s+)(.*)$/s);
        next if !$k;
        if ($k eq "exclude") {
            push @{$config{exclude}}, $v;
        } elsif ($k eq "exclude_file") {
            push @{$config{exclude}}, read_exclude_file($v);
        } elsif ($k eq "load") {
            %config = (%config, read_config(File::Spec->rel2abs($v, dirname($file))));
        } else {
            $config{$k} = $v;
        }
    }
    if ($config{exclude}) {
        $config{exclude_re} = join("|", map { mask_to_re($_) } @{$config{exclude}});
    }

    if ($config_overrides{host}) {
      $config{host} = $config_overrides{host};
    }

    return %config;
}


#
# Reads a content of .gitignore-like file.
#
sub read_exclude_file {
    my ($file) = @_;
    my @excludes = ();
    open(local *F, $file) or die "Cannot open an exclude file $file: $!\n";
    while (<F>) {
        # Comments could be at the beginning of the line only,
        # because "#" character is valid e.g. inside a file path.
        s/^\s*#.*//sg;
        s/^\s+|\s+$//sg;
        push @excludes, $_ if length($_);
    }
    return @excludes;
}


#
# Converts filesystem wildcard into regular expression.
#
sub mask_to_re {
    my ($mask) = @_;
    my $is_basename_mask = $mask !~ m{[/\\]}s && $mask !~ m{\*\*}s;
    $mask = "\Q$mask";
    $mask =~ s{\\\*\\\*}{.*}sg;
    $mask =~ s{\\\*}{[^/\\\\]*}sg;
    if ($is_basename_mask) {
        $mask = '(?:[/\\\\]|^)' . $mask . '(?:[/\\\\]|$)';
    } else {
        # Rel path to match with such mask is always started with "./",
        # but before matching the first character is cut. So when we
        # check rel path like "./aaa/bbb" to be matched by "aaa/b*" mask,
        # we are really executing "/aaa/bbb" =~ m{^(?:[/\\\\])?aaa/b.*$}.
        $mask = '^(?:[/\\\\])?' . $mask . '$';
    }
    return $mask;
}


#
# Returns host and port number from a host specification.
#
sub parse_host_spec {
    my ($host_port) = @_;
    return $host_port =~ /^(.*):(\d+)$/s ? ($1, $2) : ($host_port, "22");
}


#
# Reads the script from __DATA__ section of the file.
#
sub get_remote_script {
    local $/;
    my $script = <DATA>;
    $script =~ s/\#[^\n]+//sg;
    $script =~ s/"(.*?)"/qq{$1}/sg;
    $script =~ s/'(.*?)'/q{$1}/sg;
    $script =~ s/[\t\r\n]+/ /sg;
    return $script;
}


#
# Runs a notification daemon.
#
sub spawn_notify_daemon {
    my $cmd = $HOOKS->get_notify_daemon_cmd() or return;
    my $local = main::cfg("local"); $local =~ s{\\}{/}sg;
    async {
        # Unfortunately we have to use a separate thread and shared-var
        # polling to listen to the watcher, because Win32 IO::Select
        # does not support waiting on a filehandle.
        while (1) {
            eval {
                logger("Running async notification watcher (to save CPU time).\n");
                my $pid = open(NOTIFY_FH, $cmd . "|");
                if (!$pid) {
                    logger("Cannot run notification daemon: $!. Command was:\n  $cmd\n");
                    notifies_set_supported(0);
                    return;
                }
                notifies_set_supported(1);
                binmode(NOTIFY_FH);
                NOTIFY_FH->autoflush(1);
                my @buf = ();
                while (1) {
                    my $line = <NOTIFY_FH>; # locks until data is ready
                    defined $line or die "Notification daemon is terminated unexpectedly, restarting. Command was:\n  $cmd\n";
                    kill(0, $pid) or die "Notification watcher is dead, restarting. Command was:\n  $cmd\n";
                    $line =~ s/^\s+|\s+$//sg;
                    if ($line eq "-") {
                        notifies_push(@buf);
                        @buf = ();
                    } elsif ($line =~ /^\w+ (.+)/s) {
                        #print "Received: $line\n" if $DEBUG_PATCH_TREE;
                        my $path = $1; $path =~ s{\\}{/}sg;
                        my $rel = File::Spec->file_name_is_absolute($path) ? File::Spec->abs2rel($path, $local) : $path;
                        print "Notify: $rel\n" if $DEBUG_PATCH_TREE;
                        $rel = "./" . $rel if substr($rel, 0, 2) ne "./" && $rel ne ".";
                        push @buf, $rel;
                    } else {
                        # Unknown response - just wake up.
                        notifies_push("");
                    }
                }
            };
            logger($@) if $@;
            close(NOTIFY_FH);
            sleep(1);
        }
    }->detach();
    # Wait a bit - possibly notification daemon will dead shortly, so we glue
    # its mortal message with its launching message.
    usleep(0.5);
}


#
# Waits for changes within the filesystem.
# Callback $callback is called in busy-wait manner (to monitor
# background processes health etc).
# Returns undef if no changes detalization is known (we
# know only the fact that SOMETHING was changes), else -
# a reference to array of changed file/directory names.
#
sub wait_notify {
    my ($idle_callback) = @_;
    # Use polling if we have no watcher program for this platform.
    if (!notifies_is_supported()) {
        usleep($DELAY);
        $idle_callback->();
        return undef;
    }
    # Unfortunately we have to use shared-var polling, because Win32
    # IO::Select does not support waiting on a filehandle.
    while (1) {
        my %changes;
        @changes{notifies_pop()} = ();
        if (%changes) {
            usleep(0.01); # changes often go one after another, glue them
            @changes{notifies_pop()} = ();
            my $changes = [ sort keys %changes ]; # sort is very important here!
            return @$changes == 1 && exists($changes{""}) ? undef : $changes;
        }
        $idle_callback->();
        usleep(0.01);
    }
}


#
# Must not be overriden.
# Set icon state to:
# - rsync
# - replication
# - transfer
# - wait
#
my $prev_wav_time = time();
sub notification {
    my ($type) = @_;
    if ($type eq "rsync") {
        $PENDING{balloon_title} = "dkLab RealSync";
        $PENDING{balloon_tip} = "RSync of the whole directory is running...";
        $PENDING{icon} = "flash";
        $PENDING{reset_icon_in} = 0;
    } elsif ($type eq "replication") {
        $PENDING{balloon_title} = "dkLab RealSync";
        $PENDING{balloon_tip} = "Incremental replication is running.";
        $PENDING{icon} = "icon";
        $PENDING{visibility} = 0 if !$DEBUG_PATCH_TREE;
        $PENDING{reset_icon_in} = 0;
    } elsif ($type eq "transfer") {
        $PENDING{icon} = "flash";
        if (!$CONFIG{nosound} && time() - ($prev_wav_time||0) > 1) {
            $PENDING{wav} = "transfer";
            $prev_wav_time = time();
        }
        $PENDING{reset_icon_in} = 0;
    } elsif ($type eq "wait") {
        # Delay resetting of wait status (because we cannot have no feedback about
        # a transfer finish from the server in Win32).
        $PENDING{reset_icon_in} = 1;
    }
}


#
# Must not be overriden.
# Return pending events and clean them.
# Should be used in derived classes.
#
sub pop_pending {
    my (%pending) = %PENDING;
    %PENDING = ();
    return %pending;
}




##
## Generic hooks.
##
package Realsync::Generic;

# Convert path (e.g. Windows -> Cygwin).
sub convert_rsync_local_path {
    return $_[1];
}

# Initializes and correct runtime environment.
# Should be overriden if needed.
sub init_env {}

# Initializes and correct GUI.
# Should be overriden if needed.
sub init_gui {}

# Called at the script death.
# Should be overriden if needed.
sub finalize_env {}

# Get notification daemon command-line.
# If undef is returned, no notify daemon is used.
sub get_notify_daemon_cmd {}



##
## Win32 hooks.
##
{{{{{
package Realsync::Win32;
our @ISA = 'Realsync::Generic';
use File::Basename;
use Time::HiRes 'time';
use threads;
use threads::shared;

my $title;
my $tray_ghost_wnd;
my $tray_icon;
my $icon;
my $reset_icon_at;
my $console_visible = 1;
my $console_manually_toggled = 0;
my %icons;
my $perl_window;
my $balloon_shown_at;


sub convert_rsync_local_path {
    my ($class, $path) = @_;
    $path =~ s{\\}{/}sg;
    $path =~ s{\s*(\w):}{"/cygdrive/" . lc($1)}sge;
    $path =~ s{/+$}{}sg;
    return $path;
}


sub _to_ascii_path {
    my ($path) = @_;
    local $ENV{PATH} = "$BINDIR\\bin\\win32";
    my $newpath = $path;
    $newpath =~ s{/}{\\}sg;
    $newpath = `cygpath -a -d "$newpath"`; # the only method to call in non-ASCII path!
    $newpath =~ s{\s+$}{}sg if $newpath;
    die
        "Cannot convert to Cygwin-compatible ASCII format:\n" .
        "  $path\n" .
        "(Unfortunately even Cygwin 1.7.1-1 + rsync + ssh cannot work properly when\n" .
        "PATH contains non-ASCII (national) characters. Even with LC_ALL setting.)\n"
        if !$newpath;
    return $newpath;
}


sub init_env {
    my ($class) = @_;

    # Very important to do it late!
    $ENV{CYGWIN} = "binmode nontsec nodosfilewarning noglob";

    # Resolve non-ASCII letters from $BINDIR - in fact, even a new Cygwin
    # rsync + ssh version cannot work with them.
    $BINDIR = _to_ascii_path($BINDIR);

    # Correct PATH to point to our utilities.
    # dirname($ENV{COMSPEC}) is used to call system("... < file"): else it does not work!
    my $path = "$BINDIR\\bin\\win32;" . dirname($ENV{COMSPEC});
    my $cygpath = join ";", map { __PACKAGE__->convert_rsync_local_path($_) } split /\s*;\s*/s, $path;
    $ENV{PATH} = $path . ";" . $cygpath;

    # Build HOME directiry as ASCII-only.
    $ENV{APPDATA} = _to_ascii_path($ENV{APPDATA} or die "Environment variable APPDATA must exist!\n");

    # Other CYGWIN environment.
    $ENV{TMPDIR} = $DIR_PRIVATE;

    # Default Linux permissions used by mkdir and cat:
    # dir:  rwxrwxr-x
    # file: rw-rw-r--
    push @RSYNC_OPTIONS, (
        "--perms=off", "--chmod=ug=rwX,o=rX",
    );
}


sub get_notify_daemon_cmd {
    my $bin = $BINDIR . '/bin/win32/notify.exe';
    return if !-f $bin;
    return "\"$bin\" \"" . main::cfg("local") . "\"";
}


sub init_gui {
    # Run a background GUI thread asynchronously.
    async {
        # Initialize the tray icon.
        require Win32;
        require Win32::GUI;
        $tray_ghost_wnd = Win32::GUI::Window->new(
            -name      => 'Window',
            -text      => "dkLab RealSync",
            -size      => [100, 100],
            -minsize   => [100, 100],
        );
        $tray_ghost_wnd->AddTimer('Timer', 50);
        $perl_window = Win32::GUI::GetPerlWindow();
        $title = "dkLab RealSync: " . main::cfg("user") . '@' . main::cfg("host") . ":" . main::cfg("remote");
        Win32::GUI::Text($perl_window, $title);
        Win32::GUI::Dialog();
    }->detach();
}


sub main::Timer_Timer {
    my %pending = main::pop_pending();
    #print "- " . join(" ", map { "$_=>$pending{$_}" } keys %pending) . "\n" if %pending;

    # Process hiding/showing BEFORE processing icon notifications (because icon
    # may appear only after the window is minimized).
    defined $pending{visibility} && !$console_manually_toggled and set_console_visibility($pending{visibility});

    # Process sounds.
    if ($pending{wav}) {
        require Win32::API;
        my $function = Win32::API->new(
            'Winmm.dll', 'BOOL PlaySound(LPCSTR pszSound, HMODULE hmod, DWORD fdwSound)',
        );
        $function->Call("$BINDIR/bin/win32/wav/" . $pending{wav} . ".wav", 0, 0x20000 | 0x1);
    }

    # Process icon notifications.
    my %changes = ();
    $pending{balloon_title} and $changes{-balloon_title} = $pending{balloon_title};
    $pending{balloon_tip}   and $changes{-balloon_tip} = $pending{balloon_tip};
    $pending{icon}          and $changes{-icon} = get_icon($pending{icon});
    if (exists $pending{reset_icon_in}) {
        $reset_icon_at = $pending{reset_icon_in} ? time() + $pending{reset_icon_in} : undef;
    }
    if ($reset_icon_at && time() > $reset_icon_at) {
        $changes{-icon} = get_icon("icon");
        $reset_icon_at = undef;
    }
    if (%changes) {
        $icon = ($changes{-icon} ||= get_icon($icon));
        Win32::GUI::SetIcon($perl_window, $icon);
        if ($tray_icon) {
            $tray_icon->Change(
                %changes,
                -balloon_icon => "info",
            );
            if ($changes{-balloon_tip}) {
                $tray_icon->ShowBalloon();
                $balloon_shown_at = time();
            } else {
                $tray_icon->HideBalloon();
            }
        }
    }

    # Hide balloon manually (automatic timeout seems do not work).
    if ($balloon_shown_at && time() - $balloon_shown_at > 3) {
        $tray_icon->HideBalloon() if $tray_icon;
        $balloon_shown_at = undef;
    }

    # Process minimization.
    if (Win32::GUI::IsIconic($perl_window) && Win32::GUI::IsVisible($perl_window)) {
        $console_manually_toggled = 1;
        set_console_visibility(0);
    }
}


sub main::NI_Click {
    $console_manually_toggled = 1;
    set_console_visibility() if !$console_visible;
}


sub finalize_env {
    $tray_icon->Remove() if $tray_icon;
    $tray_icon = undef;
}


sub get_icon {
    my ($name) = @_;
    my $f = "$BINDIR/bin/win32/icon/realsync_${name}.ico";
    return $icons{$f} ||= new Win32::GUI::Icon($f);
}


sub set_console_visibility {
    my ($visible) = @_;
    if (!defined $visible) {
        $visible = !$console_visible;
    }
    return if $console_visible == $visible;
    if ($visible) {
        $tray_icon->Remove() if $tray_icon;
        $tray_icon = undef;
        Win32::GUI::Show($perl_window);
        Win32::GUI::SetForegroundWindow($perl_window); # the ONLY method to activate!
    } else {
        Win32::GUI::Hide($perl_window);
        $tray_icon = $tray_ghost_wnd->AddNotifyIcon(
            -name => "NI",
            -tip => $title,
            -icon => $icon ? $icon : get_icon("icon"),
        );
    }
    $console_visible = $visible;
}
}}}}}



##
## MaxOS X hooks.
##
{{{{{
package Realsync::Darwin;
our @ISA = 'Realsync::Generic';

sub get_notify_daemon_cmd {
    my $bin = $BINDIR . '/bin/darwin/notify';
    return if !-f $bin;
    die "ATTENTION! You must perform:\n  chmod +x '$bin'\nto work with RealSync. Please do it now.\n" if !-x $bin;
    my $cmd = '"' . $bin . '" "' . main::cfg("local") . '"';
    return $cmd;
}
}}}}}



##
## Linux hooks.
##
{{{{{
package Realsync::Linux;
our @ISA = 'Realsync::Generic';

sub get_notify_daemon_cmd {
    my $bin = $BINDIR . '/bin/linux/notify';
    return if !-f $bin;
    die "ATTENTION! You must perform:\n  chmod +x '$bin'\nto work with RealSync. Please do it now.\n" if !-x $bin;
    my $cmd = '"' . $bin . '" "' . Cwd::abs_path(main::cfg("local")) . '"';
    return $cmd;
}
}}}}}



##
## End of main script code. Run main() - as late as we can, because
## else "my" variables in sub-modules will not be initialized.
##
package main;
main();



##
## Script code which is passed to remote side.
##
__DATA__
use File::Path qw(rmtree);
use File::Basename;
use POSIX qw(locale_h strftime);
use IO::Handle;

$ENV{LANG} = $ENV{LC_ALL} = "POSIX";
setlocale(LC_ALL, "C");
binmode(STDIN);  STDIN->autoflush(1);
binmode(STDOUT); STDOUT->autoflush(1);
binmode(STDERR); STDERR->autoflush(1);

my $cwd = readln();
# getcwd() does not support tilde-based pathes, so replace them into
# full user's home directory pathes.
$cwd =~ s{^ ~ ([^/]*) }{
    $1? ((getpwnam $1)[7] || $1)
      : ($ENV{HOME} || $ENV{LOGDIR} || (getpwuid $>)[7] || "")
}ex;
chdir($cwd) or die "Cannot chdir to $cwd: $!\n";
logger("Remote directory $cwd/ is ready.");

while (1) {
    my $change = read_change('STDIN');
    eval { apply_change($change) };
    logger("     " . $@) if $@;
}

sub readln {
    my $s = <STDIN>;
    die "STDIN closed, the remote process is finished.\n" if !defined $s;
    chomp($s);
    return $s;
}

sub writeln {
    my $fh = $_[0];
    print $fh $_[1];
    print $fh chr(10);
}

sub logger {
    my ($s, $nonl, $notime) = @_;
    $s =~ s/\s+$//sg;
    $s =~ s/^/strftime("[%H:%M:%S] ", localtime)/meg if !$notime;
    print $s . ($nonl ? "" : "\n");
}

sub read_change {
    my ($fh) = @_;
    my $change = {};
    $change->{type} = readln();
    $change->{name} = readln();
    $change->{perm} = readln();
    $change->{stamp} = readln();
    my $len = readln();
    logger(sprintf("%.3s: ", uc($change->{type})) . $change->{name} . ($len ? " ($len bytes)" : "") . " - ", 1);
    my $data = "";
    while (length($data) < $len) {
        my $left = $len - length($data);
        read($fh, $data, $left, length($data));
    }
    readln();
    logger(" done", 0, 1);
    $change->{data} = $data;
    return $change;
}

sub write_change {
    my ($fh, $change) = @_;
    my $data = undef;
    if ($change->{type} eq "fil") {
        local $/;
        if (!open(local *F, $change->{path})) {
            logger("Cannot open $change->{name}: $!; skipped");
            return;
        }
        binmode(F);
        $data = <F>;
    }
    my $block = join("",
        $change->{type}, "\n",
        $change->{name}, "\n",
        ($change->{perm} || ""), "\n",
        ($change->{stamp} || 0), "\n",
        (defined $data ? length($data) : 0), "\n",
        (defined $data ? $data : ""), "\n"
    );
    print $fh $block or die "Cannot transmit: $!\n";
}

sub apply_change {
    my ($change) = @_;
    if ($change->{name} =~ m{^\s+$ | ^\s*/ | \.\.}sx) {
        die "Invalid file name: $change->{name}\n";
    }

    # Save mtime of the parent directory: we must not modify it automatically
    # by files creation, only by request of RealSync. Why? Because the following
    # commands may arrive (assume `date` = 2010-02-02):
    #   DIR a/b         2010-01-05
    #   FIL a/b/x.txt   2010-01-05
    # If we do not save+restore mtime of a/b, OS will reset it to 2010-02-02
    # just after a/b/x.txt is created. So we save it.
    my $parent = dirname($change->{name});
    my @stat = stat($parent);
    my $name = $change->{name};

    if ($change->{type} eq "fil") {
        my $tmp = $name . "." . time() . ".tmp";
        open(local *F, ">", $tmp) or die "Cannot create $tmp: $!\n";
        binmode(F);
        print F $change->{data} or die "Cannot write to $tmp: $!\n";
        close(F) or die "Cannot close $tmp: $!\n";
        if (length($change->{perm})) {
            chmod($change->{perm}, $tmp) or die "Cannot chmod $tmp: $!\n";
        } else {
            chmod((stat $name)[2], $tmp) if -e $name;
        }
        rename($tmp, $name) or die "Cannot rename $tmp to $name: $!\n";
    } elsif ($change->{type} eq "dir") {
        if (!-d $name) {
            mkdir($name) or die "Cannot mkdir $name: $!\n";
            if (length($change->{perm})) {
                chmod($change->{perm}, $name) or die "Cannot chmod $name: $!\n";
            }
        }
    } elsif ($change->{type} eq "del") {
        if (-e $change->{name}) {
            if (-f $change->{name}) {
                unlink($change->{name}) or die "Cannot unlink $change->{name}: $!\n";
            } else {
                rmtree($change->{name}) or die "Cannot rmtree $change->{name}: $!\n";
            }
        }
    } else {
        die "Invalid change type: $change->{type}\n";
    }

    # Apply timestamp changes.
    if ($change->{type} ne "del" && $change->{stamp}) {
        utime($change->{stamp}, $change->{stamp}, $change->{name}) or die "$change->{type} - Cannot utime $change->{name}: $!\n";
    }

    # Restore mtime of the parent directory.
    if (@stat) {
        utime($stat[9], $stat[9], $parent) or die "Cannot utime parent $parent: $!\n";
    }
}

realsync_cmd.version

2