#!/usr/bin/perl -w
use strict;
$|++;

use File::Find qw(find finddepth);
use File::Copy qw(copy);
use File::Compare qw(compare);

## todo:
##  symlinks (must determine sensible rewrite rules)
##  hardlinks (maintain dev/ino maps for source and dest)
##  sparse files?

## start config

my $SRC = ["/home/merlyn/www-src",
           sub { # ignore source-management things:
             return 1 if $_[0] =~ /~\z/; # files ending in tilde
             return 1 if $_[1] =~ m{/CVS(\z|/)}; # CVS files
             0;
           },
          ];
my $DST = ["/home/merlyn/public_html",
           sub { # ignore web-management things:
             return 1 if $_[0] eq ".htaccess"; # sacred
             0;
           }];

my $DELETE_EXCLUDED = 1;
my $CHECK_CONTENT = 1;
my $CHECK_ATIME = 0;

my $TRACE = 1;

## end config

## delete phase:
walk (1, $DST, $SRC, \&delete_compare, \&delete_action, $DELETE_EXCLUDED);

## copy directories/files phase:
walk (0, $SRC, $DST, \&copy_compare, \&copy_action);

## clean up meta-stuff phase:
walk (1, $SRC, $DST, \&cleanup_compare, \&cleanup_action);

exit 0;

## subroutines:

sub walk {
  my $find_func = shift(@_) ? \&finddepth : \&find;
  my ($from, $from_ignore) = walk_expand(shift);
  my ($to, $to_ignore) = walk_expand(shift);
  my $compare = shift;
  my $action = shift;
  my $delete_excluded = shift;

  $find_func->
    (sub {
       return if $from_ignore and $from_ignore->($_, $File::Find::name);
       my $to_name = $to.substr($File::Find::name, length($from));
       if (not -e $to_name
           or $delete_excluded and $to_ignore->($_, $File::Find::name)
           or $compare->($File::Find::name, $to_name)
          ) {
         $action->($File::Find::name, $to_name);
       }
     }, $from);
}

sub walk_expand {
  ref($_[0]) ? @{$_[0]} : $_[0];
}

sub delete_compare {            # compare two existing files for differences
  my ($dst, $src) = @_;
  my @s = map [stat $_], @_;
  return 1 if ($s[0][2] >> 12) <=> ($s[1][2] >> 12); # not the same type
  return 0;
}

sub delete_action {
  my ($dst, $src) = @_;
  if (unlink $dst) {
    warn "rm $dst\n" if $TRACE;
  } elsif (rmdir $dst) {
    warn "rmdir $dst\n" if $TRACE;
  } else {
    warn "#ERROR# cannot eliminate $dst\n";
  }
}

sub copy_compare {
  my ($src, $dst) = @_;
  my @s = map [stat $_], @_;
  return 1 if ($s[0][2] >> 12) <=> ($s[1][2] >> 12); # not the same type
  if (not -l $src and -f _) {   # plain files both of ya
    return 1 if $s[0][9] <=> $s[1][9]; # not same mtime
    return 1 if $CHECK_ATIME
      and $s[0][8] <=> $s[1][8]; # not same atime
    return 1 if $CHECK_CONTENT
      and compare $src, $dst;   # not same content
  }
  0;                            # not different
}

sub copy_action {
  my ($src, $dst) = @_;
  if (-l $src) {
    warn "#ERROR# cannot symlink from $src to $dst (yet)\n";
  } elsif (-f $src) {
    if (copy $src, my $new = "$dst.$$.".time) {
      warn "cp $src $new\n" if $TRACE;
      if (rename $new, $dst) {
        warn "mv $new $dst\n" if $TRACE;
      } else {
        warn "#ERROR# cannot mv $new $dst: $!\n";
      }
    } else {
      warn "#ERROR# cannot cp $src $new: $!\n";
    }
  } elsif (-d $src) {
    if (mkdir $dst, 0777) {
      warn "mkdir $dst\n" if $TRACE;
    } else {
      warn "#ERROR# cannot mkdir $dst: $!\n";
    }
  } else {
    warn "#ERROR# don't know how to copy $src to $dst\n";
  }
}

sub cleanup_compare {
  my ($src,$dst) = @_;
  my @s = map [(lstat $_)[4,5,8,9], (stat _)[2] & 07777], @_;
  return "@{$s[0]}" cmp "@{$s[1]}";
}

sub cleanup_action {
  return if grep -l, @_;
  my ($src, $dst) = @_;
  my @s = map [lstat $_], @_;
  if ((my $oldperm = $s[0][2] & 07777) != ($s[1][2] & 07777)) {
    warn "setting perms on $dst\n" if $TRACE;
    chmod $oldperm, $dst
      or warn "#ERROR# can't update perms on $dst: $!";
  }

  if ("$s[0][8] $s[0][9]" ne "$s[1][8] $s[1][9]") {
    warn "setting times on $dst\n" if $TRACE;
    utime $s[0][8], $s[0][9], $dst
      or warn "#ERROR# can't update times on $dst: $!";
  }

  if ("$s[0][4] $s[0][5]" ne "$s[1][4] $s[1][5]") {
    $< and chown $s[0][4], $s[0][5], $dst
      or warn "#ERROR# can't update ownership of $dst: $!";
  }
}