#!/usr/bin/env perl
# -*- perl -*-

# $Id: incorporate,v 3.9 2002/04/16 09:31:45 eserte Exp $

# XXX Issues:
#     * Win32 compatibility
#     * preserve symbolic links?

use File::Basename ();
use File::Find;

my $main_pid = $$;

$SIG{INT} = sub { exit };

# /usr/local/bin vor /usr/bin, weil dort ein besseres tar/zcat zu finden ist
$ENV{'PATH'} = "/usr/gnu/bin:/usr/ucb:/usr/local/bin:/bin:/usr/bin:/usr/X11/bin:$ENV{'PATH'}";

my($child_pid, $msg, $wait_done);
my @checked_out_files;
my $uudecode_file;

my $use_direct_emacs = 0;

my $tmp = tmpdir();

use constant SEL_BUFFER => 4096;

&domainname;

$default_fromdir     = ($ENV{'FROMDIR'} eq '' ? '.'          : $ENV{'FROMDIR'});
$default_todir       = ($ENV{'TODIR'}   eq '' ? $ENV{'HOME'} : $ENV{'TODIR'});
$copy_uncond = "$ENV{'HOME'}/.copy_uncond";
$backups     = "$tmp/e/backups";
$includefile = "$ENV{'HOME'}/.include_add";
$noexec      = 0;
#$home2       = 1;
if (is_in_path("less")) {
    $pager   = ($ENV{'DOMAINNAME'} =~ /herceg.de/ ? "less -E" : "less");
} else {
    $pager   = "more";
}
@echo        = ();
%fancy_diff  = ();
@unprocessed_files = ();
$use_color   = 1;
$diffopts    = "-u"; # options for diff --- I like unified diffs
$ignorercs   = 0;
$fast_cmp    = 0;
$ignore_files = 1;
$use_skip_file = 0;
$skip_file_base_name = ".copynewer.SKIP";
$use_tk        = 0;
$quiet       = 0;

# Loop through the command-line args:
for ($i = 0; $i <= $#ARGV; ++$i) {
    $_ = $ARGV[$i];
  ARGL:
    { /^-n$/ && do { $noexec = 1; last ARGL; };
      /^-backup$/ && do { &backup_add; exit 0; last ARGL; };
      /^-restore$/ && do { &restore_add; exit 0; last ARGL; };
      #/^-nohome2$/ && do { $home2 = 0; last ARGL; };
      /^-fromdir$/ && do { $fromdir = &get_arg(*i, *ARGV, "-fromdir", "$_");
			   last ARGL; };
      /^-todir$/ && do { $todir = &get_arg(*i, *ARGV, "-todir", "$_");
			 last ARGL; };
      /^-lastrestore$/ && do { $lastrestore = &get_arg(*i, *ARGV,
						       "-lastrestore", "$_");
			 last ARGL; };
      /^-img$/ && do { $fancy_diff{'img'}++; last ARGL; };
      /^-nocolor$/ && do { $use_color = 0; last ARGL; };
      /^-ignorercs$/ && do { $ignorercs = 1; last ARGL; };
      /^-fastcmp$/ && do { $fast_cmp = 1; last ARGL; };
      /^-noignorefiles$/ && do { $ignore_files = 0; last ARGL; };
      /^-useskipfile$/ && do { $use_skip_file = 1; last ARGL; };
      /^-skipfile$/ && do { $skip_file_base_name = &get_arg(*i, *ARGV,
							    "-skipfile", "$_");
			    last ARGL; };
      /^-directemacs$/ && do {
	  if (!$ENV{DISPLAY} && $^O ne 'MSWin32') {
	      warn "No DISPLAY defined --- disabling -directemacs option\n\n";
	  } else {
	      $use_direct_emacs = 1;
	  }
	  last ARGL;
      };
      /^-tk$/ && do { $use_tk = 1; last ARGL; };
      /^-quiet$/ && do { $quiet = 1; last ARGL; };
      /^-/ && do {
	  &usage("bad argument: $_"); last ARGL;
      };
      /^[^-]/ && do {
	  if (!defined $fromdir) {
	      $fromdir = $_; last ARGL;
	  }
	  if (!defined $todir) {
	      $todir   = $_; last ARGL;
	  }
	  &usage("bad argument: $_"); last ARGL;
      };
  }
}				# end of the for loop.

if ($0 =~ m;(/|^)tkincorporate(\.pl)?$;) {
    $use_tk = 1;
}

if (!defined $fromdir) {
    $fromdir = $default_fromdir;
}
if (!defined $todir) {
    # first try to guess destination
    if (-f $fromdir) {
	my $frombase = File::Basename::basename($fromdir);
	if ($frombase =~ /^copynewer(_.*)\.(tar\.gz|zip|tgz)$/) {
	    my $guess_todir = $1;
	    $guess_todir =~ s|_|/|g;
	    if (-d $guess_todir && -w $guess_todir) {
		$todir = $guess_todir;
	    }
	}
    }
}
if (!defined $todir) {
    $todir = $default_todir;
}

@echo = ('echo') if ($noexec);	# echoing commands instead of executing them

my $tmp_extract_dir;
if (-f $fromdir) {
    if ($fromdir =~ /\.t(ar\.)?gz$/) {
	extract("tgz");
    } elsif ($fromdir =~ /\.zip$/) {
	extract("zip");
    } elsif (is_uuencoded($fromdir)) {
	extract("uudecode");
    }
}

if ($^O eq 'MSWin32') {
    # stat is not working...
    die "FROMDIR ($fromdir) must be not equal TODIR ($todir)"
	if $fromdir eq $todir;
} else {
    die "FROMDIR ($fromdir) must be not equal TODIR ($todir)"
	if (stat($fromdir))[0] eq (stat($todir))[0]  # compare devices
	&& (stat($fromdir))[1] eq (stat($todir))[1]; # compare inodes
}

# strip slashes at tail
$fromdir =~ s|/+$||;
$todir   =~ s|/+$||;

# make absolute paths, if possible
$fromdir = rel2abs($fromdir);
$todir   = rel2abs($todir);

$redcolor = $bluecolor = $normalcolor = '';
if ($use_color && !$use_tk) {
    eval {
	require Term::Cap;
	if (-r "/etc/termcap") {
	    # force colored xterm
	    system(qw|fgrep|,
		   ($^O ne 'solaris' ? "-q" : ()),
		   qw|xterm-color /etc/termcap|);
	    if (!$?) {
		$ENV{TERM} = "xterm-color" if ($ENV{TERM} eq 'xterm');
	    }
	}
	$terminal = Tgetent Term::Cap { TERM => undef, OSPEED => 9600 };
	$terminal->Trequire(qw/AF op/);
	$redcolor = $terminal->Tgoto('AF', 1, 1);
	$bluecolor = $terminal->Tgoto('AF', 1, 4);
	$normalcolor = $terminal->Tputs('op', 1);
    };
    if ($@) {
	$use_color = 0;
	warn "Don't use coloring because:\n$@";
    }
}

if ($use_skip_file) {
    if (!open(SKIP, "$fromdir/$skip_file_base_name")) {
	warn "Skip file $fromdir/$skip_file_base_name requested, but: $!";
    } else {
	while(<SKIP>) {
	    chomp;
	    push @use_manifest_skip, $_;
	}
	close SKIP;
    }
}

open(LOG, ">$tmp/incorporate_log.$$") ||
    print STDERR "Can't open logfile\n";

# first copy all files from .copy_uncond without prompting
if (open(COPYUNCOND, $copy_uncond)) {
    $shscript = '';
    while(<COPYUNCOND>) {
	chop;
	# gather all commands for a sh script
	$shscript .= "cp -pr '$_' '" . &dirname("$todir/$_") . "' && rm -rf '$_'\n"
	    if (-e $_);
    }
    if ($noexec) {
	print STDERR $shscript;
    }
    else {
	open(SHELL, "| sh -") || die "Can't exec shell";
	print SHELL $shscript if (!$noexec);
	close(SHELL);
    }
}

if (-d $backups) {
    &restore_add;
    system(@echo, "rm", "-rf", $backups)/256 == 0 ||
	print LOG "Can't remove $backups\n";
}

# may be on a CDROM where nlink is not handled (e.g. FreeBSD's cd9660 fs)
$File::Find::dont_use_nlink = 1;

# process all files in the subtree
find(\&wanted, $fromdir);

sub wanted {
#open(FIND, "find $fromdir -type f -print |") || die "Can't exec find";
#while(<FIND>) {
#    chop($file = $_);
    return if !-f $_;

    chomp($file = $File::Find::name);

    if ($ignore_files) {
	if ($file =~ /~$/ || $file =~ /^\#.*\#$/) {
	    return;
	}
    }

    if (@use_manifest_skip) {
	foreach my $skip (@use_manifest_skip) {
	    if ($file =~ /$skip/) {
		#warn "Ignore $n"; #XXX if $VERBOSE;
		# XXX
		#if (-d $_) {
		#    $File::Find::prune = 1;
		#}
		return;
	    }
	}
    }

    my $cmp;

    $file =~ s|^$fromdir/||;
    print STDERR "$file ... " unless $quiet;
    if ($ignorercs and $file =~ m#(^|/)(RCS|CVS)/#) {
	print STDERR "ignoring (RCS or CVS).\n" unless $quiet;
	return;
    }
    if (! -r "$fromdir/$file") {
	print STDERR "source file $fromdir/$file isn't readable.\n" unless $quiet;
	return;
    }
    if (! -r "$todir/$file") {
	print STDERR "does not exist\n" unless $quiet;
	push @dont_exist_files, $file;
    }
    elsif (!$fast_cmp && ($cmp = exact_cmp("$fromdir/$file", "$todir/$file")) == 0) {
	print STDERR "OK\n" unless $quiet;
    }
    elsif ($fast_cmp && ($cmp = fast_cmp("$fromdir/$file", "$todir/$file")) == 0) {
	print STDERR "[OK]\n" unless $quiet;
    }
    else {
	if ($cmp != 1) {
	    warn "Problem while comparing $file, do not add to diff list...\n";
	    return;
	}

	print STDERR "diffs\n" unless $quiet;
    	push @diff_files, $file;

	if ($use_tk) {
	    system(qw/diff -q -I/, chr(36) . "Id:.*" . chr(36),
		   "$fromdir/$file", "$todir/$file");
	    if ($? == 0) {
		push @rcs_change_only_files, $file;
	    }
	}

    }
}
#close(FIND);

if ($use_tk) {
    Incorporate::Tk::mw();
    Incorporate::Tk::fill(-changed => \@diff_files,
			  -rcschangeonly => \@rcs_change_only_files,
			  -new => \@dont_exist_files);
    Incorporate::Tk::loop();
    exit;
}

foreach my $file (@dont_exist_files) {
    if (! -r "$fromdir/$file") {
	warn "$fromdir/$file is being deleted...\n";
	next;
    }

    print STDERR "$file does not exist\n";
    &dontexist($file);
}

foreach my $file (@diff_files) {
    if (! -r "$fromdir/$file") {
	warn "$fromdir/$file is being deleted...\n";
	next;
    }

    $local_file_newer = 0;
    if (-z "$fromdir/$file" &&
	!((stat("$todir/$file"))[9] > (stat("$fromdir/$file"))[9])) {
	# empty file
	print STDERR "$file: empty file\nDelete destination? (y/n) ";
	chop($_ = <STDIN>);
	if ($_ eq 'y') {
	    unlink "$todir/$file";
	    next;
	}
    } else {
	print STDERR "$file diffs";
	if ((stat("$todir/$file"))[9] > (stat("$fromdir/$file"))[9]) {
	    print STDERR ", ${redcolor}local file is newer${normalcolor}";
	    $local_file_newer = 1;
	}
	print STDERR "\n";
    }
    difffiles($file);
}

# if ($home2 && ($_ = "$ENV{'HOME'}/export/home2.tgz") && -s $_) {
#     system("tar xfvzpP $_")/256 == 0 ||
# 	print LOG "Can't untar $_\n";
#     rename($_, "$_~");
# }

close(LOG);

if (defined $lastrestore) {
    if (open(LAST, ">>$lastrestore")) {
	print LAST scalar localtime;
	print LAST "\n";
	close LAST;
    } else {
	warn "Can't write to $lastrestore: $!\n";
    }
}

if (@unprocessed_files) {
    print STDERR "These files are unprocessed:\n";
    print STDERR join("\n", map { "\t$_" } @unprocessed_files), "\n";
}

if (@merged_files) {
    print STDERR "These files are merged:\n";
    print STDERR join("\n", map { "\t$_" } @merged_files), "\n";
}

if (@checked_out_files) {
    print STDERR "These files were checked out:\n";
    print STDERR join("\n", map { "\t$_" } @checked_out_files), "\n";

    my $emacs_s = "(progn\n" . join("\n", map { "  (find-file \"$_\")" }
				          @checked_out_files) .
		  ")\n";
    set_selection($emacs_s);
    if ($msg) {
	print STDERR
	    "Print C-c to exit the program (the selection will be lost).\n";
	sleep 60*10;
    }
}

######################################################################
# prompt for copying the file
sub copyfile {
    local($file) = @_;
    local($yesno, $mode) = '';

    my $topath = "$todir/$file";
    while ($yesno eq '') {
	print STDERR "copy (merge) $bluecolor", basename($file),
	"$normalcolor to " . $todir . "/$bluecolor" . dirname($file) .
	  "$normalcolor?";
	if ($local_file_newer) {
	    print STDERR "${redcolor} (local file is newer)$normalcolor";
	}
	print STDERR " (y/c/m/i/n/a/d/E/?) ";
	$_ = <STDIN>;
	if (/^[yjc]/i) {

	    do_real_copy($file);

	    $yesno = 'y';
	}
	elsif (/^i/i) {		# merge with interactive sdiff
	    rename($topath, "$topath~") if (!$noexec);
	    my(@cmd);
	    if (@echo) { push @cmd, @echo }
	    push(@cmd, "sdiff", "-o", $topath, "-s", "$fromdir/$file",
		 "$topath~");
	    system(@cmd);
	    $yesno = 'i';
	}
	elsif (/^m/i) {		# merge with merge
	    require File::Copy;
	    File::Copy::copy($topath, "$topath~") if (!$noexec);
	    my(@cmd);
	    if (@echo) { push @cmd, @echo }
	    push(@cmd, "merge", $topath, $topath, "$fromdir/$file");
	    push @merged_files, $topath;
	    system(@cmd);
	    $yesno = 'm';
	}
	elsif (/^n/i) {
	    $yesno = 'n';
	}
	elsif (/^a/i) {
	    # XXX open etc. verwenden
	    system(join(" ", @echo) . "cat '$fromdir/$file' >> '$topath'")/256 == 0 ||
		print LOG
		  "Problems appending $fromdir/$file to $topath\n";
	}
	elsif (/^d/i) {
	    &difffiles($file);
	    last; # exit loop
	}
	elsif (/^E/) {
	    my $emacs_s = get_emacs_lisp_diff_line($file);

	    if ($use_direct_emacs) {
		next if call_emacs($emacs_s);
		# otherwise fall through...
	    }

	    print "$emacs_s\n";
	    set_selection($emacs_s);
	}
	else {			# wrong input, try again
	    print STDERR
	      "y/c=cp; m=merge; i=inter.merge; E=emacs diff; n=nothing; a=append; d=diff\n";
	    $yesno = '';
	}
    }
    &killprocs;
}

sub do_real_copy {
    my($file) = @_;
    my $topath = "$todir/$file";

    if (-l $topath) {
	my $symlinkpath = File::Basename::dirname($topath) . "/" . readlink($topath);
	if (-e $symlinkpath) {
	    if (common_yn("$topath is linked to $symlinkpath. Use orig file?", "yn")) {
		$topath = $symlinkpath;
	    }
	}
    }

    my $was_checked_out = 0;
    if (-f $topath && !-w $topath &&
	is_rcs_file($topath) && is_rcs_locked($topath)) {
	if (common_yn("Checkout file $topath?", "yn")) {
	    checkout_file($topath);
	    $was_checked_out++;
	    push @checked_out_files, $topath;
	}
    }

    rename($topath, "$topath~") if (!$noexec);
    if (! -d &dirname($topath)) {
	system(@echo, "mkdirhier", &dirname($topath))/256 != 0
	    && print LOG "Can't mkdirhier $topath\n";
    }

    # target file isn't writeable
    if (-f $topath && ! -w $topath) {
	my $mode = (stat(_))[2]; # XXX don't yet used
	# make file writeable
	chmod 200, $topath ||
	    print LOG "Can't chmod $topath\n";
    }
    # -p resets right permissions
    my(@cmd);
    if (@echo) {
	push @cmd, @echo;
    }
    my @cp_args = ("-p");
    if ($^O eq 'linux') {
	push @cp_args, "-b";
    }
    push @cmd, "cp", @cp_args, "$fromdir/$file", $topath;
    my $ret = system(@cmd)/256;
    if ($ret != 0) {
	print LOG "Problems copying $fromdir/$file to $todir\n";
	if (-z $topath && -e "$topath~") {
	    print LOG "Try to restore old file $topath~...\n";
	    system("cp", "-p", "$topath~", $topath);
	}
    }

    if ($was_checked_out) {
	# correct write permission, so emacs does not get confused...
	my(@s) = stat($topath);
	if (@s) {
	    my $mode = $s[2] | 0200;
	    chmod $mode => $topath;
	}
    }

}

sub common_yn {
    my $text = shift;
    my $type = shift;
    if ($use_tk) {
	return 1 if ($Incorporate::Tk::mw->messageBox
		     (-title => "Symlink",
		      -text  => $text,
		      -icon  => "question",
		      -type  => ($type =~ /^yn$/i ? "YesNo" : die),
		     ) =~ /yes/i);
    } else {
	print STDERR "$text (Y/n) ";
	$_ = <STDIN>;
	return 1 if /^[yj]/i;
    }
    0;
}

sub get_emacs_lisp_diff_line {
    my $file = shift;

    require Cwd;
    my $frompath;
    if (file_name_is_absolute($fromdir)) {
	$frompath = catfile($fromdir, $file);
    } else {
	$frompath = catfile(Cwd::cwd(), $fromdir, $file);
    }
    "(ediff-files \"$todir/$file\" \"$frompath\")";
}

# what to do if a file does not exist ...
sub dontexist {
    local($file) = @_;
    &copyfile($file);
}

# command for encountering differnces
sub difffiles {
    local($file) = @_;
    local($fromfile) = "$fromdir/$file";
    local($tofile)   = "$todir/$file";
    if ($fancy_diff{'img'} && &is_img($fromfile) && defined $ENV{DISPLAY}) {
	&cmd("xv", "-geometry", "+0+0", $fromfile);
	&cmd("xv", "-geometry", "-0+0", $tofile);
    } else {
	if ($file =~ /\.(z|Z|gz)$/) {
	    $diffprg = "zdiff";
	} else {
	    $diffprg = "diff";
	}
	# XXX better solution
	system("$diffprg $diffopts " .
	       quote_single($tofile) . " " .
	       quote_single($fromfile) . " | $pager");
    }
    &copyfile($file);
}

# do a backup of additional files (.include_add)
sub backup_add {
    local($count, $local, $remote, $base) = 1;

    if (!open(INCLUDEFILE, $includefile)) {
	print STDERR "No $includefile\n";
    }
    else {
	umask 077;
	# make backup directory
	system(@echo, "mkdirhier", $backups) if ( ! -d $backups );

	# process all files/directories in .include_add
	while(<INCLUDEFILE>) {
	    chop;
	    ($local, $remote) = split(/\t/);
	    if (-r $local) {
		if (-f $local) {
		    chdir &dirname($local);
		}
		else {
		    chdir $local;
		}

		$base = &basename($local);
		$base = '.' if ($base eq '');
		system(@echo, "gtar", "cfvzp", "$backups/$count.tgz", $base);
		$count++;
	    }
	    else {
		print STDERR "No such file or directory: $local\n";
	    }
	}
	close(INCLUDEFILE);
    }
}

# restore a archive made by backup_add
sub restore_add {
    local($count) = 1;

    if (!open(INCLUDEFILE, $includefile)) {
	print STDERR "No $includefile\n";
    }
    else {
	while(<INCLUDEFILE>) {
	    chop;
	    ($local, $remote) = split(/\t/);
	    if (-d $remote) {	# check it XXX
		chdir $remote;
		system(@echo, "gtar", "xfvzp", "$backups/$count.tgz");
	    }
	    $count++;
	}
	close(INCLUDEFILE);
    }
}

# ermittelt die Domain
sub domainname {
    ($ENV{'DOMAINNAME'} eq '') && chop($ENV{'DOMAINNAME'} = `domainname`);
}

# basename
sub basename {
    local($pathname) = @_;
    $pathname =~ /([^\/]*)$/;
    $1;
}

# dirname
sub dirname {
    local($pathname) = @_;
    $pathname =~ s|/[^/]+$||;
    $pathname;
}

sub cmd {
    local(@cmd) = @_;
    local($pid);
    $pid = fork;
    if (!$pid) { # child
	exec @cmd;
	die $!;
    }
    $waitpids{$pid}++;
}

sub killprocs {
    local($k);
    while($k = each %waitpids) {
	kill 15, $k;
	delete $waitpids{$k};
    }
}

sub is_img {
    local($file) = @_; # XXX vielleicht auch magic verwenden
    $file =~ /\.(gif|jpe?g|p[pngb]m|x[bp]m|tiff?|bmp|ras|rgb|tga|fts|iff|i?lbm)$/i;
}

# print out how to use this program.
# the string argument passed to it is printed at the end, with a nl.
sub usage
{ local ($problem) = @_;
  die "usage:", &basename($0), "[-n] [-backup] [-restore] [-nohome]
       [-fromdir dir] [-todir dir] [-img]
Incorporate changes from cs to cabulja and vice versa
\n"
    . "$problem\n";
}

# Get the argument, which may be directly after this switch, or the
# next word entirely.  This works like getopts, in a way.
sub get_arg {
    local(*index, *array, $prefix, $arg) = @_; # kein my!!!
    if ($arg =~ m/^$prefix$/) {
	++$index;
	die "Too few args - last arg was $arg\n" if ($index > $#array);
	return "$array[$index]";
    } else {
	$arg =~ s/^$prefix//; return "$arg";
    }
}

sub is_rcs_file {
    my $file = shift;
    my $dir = dirname($file);
    my $base = basename($file);
    -f $file && -d "$dir/RCS" && -f "$dir/RCS/$base,v";
}

sub is_rcs_locked {
    my $file = shift;
    open(RLOG, "rlog $file|");
    while(<RLOG>) {
	if (/^locks:/) {
	    my $nextline = scalar <RLOG>;
	    if ($nextline =~ /^\s/) {
		return 0;
	    } else {
		return 1;
	    }
	}
    }
    close RLOG;
    0;
}

sub checkout_file {
    my $file = shift;
    system(qw/co -l/, $file);
}

# REPO BEGIN
# REPO NAME is_in_path /home/e/eserte/src/repository 
# REPO MD5 8ef726a767d6a3291c0cd8569ce761b1
=head2 is_in_path($prog)

Return the pathname of $prog, if the program is in the PATH, or undef
otherwise.

DEPENDENCY: file_name_is_absolute

=cut

sub is_in_path {
    my($prog) = @_;
    return $prog if (file_name_is_absolute($prog) and -x $prog);
    require Config;
    my $sep = $Config::Config{'path_sep'} || ':';
    foreach (split(/$sep/o, $ENV{PATH})) {
	return "$_/$prog" if -x "$_/$prog";
    }
    undef;
}
# REPO END

# REPO BEGIN
# REPO NAME file_name_is_absolute /home/e/eserte/src/repository 
# REPO MD5 47355e35bcf03edac9ea12c6f8fff9a3
=head2 file_name_is_absolute($file)

Return true, if supplied file name is absolute. This is only necessary
for older perls where File::Spec is not part of the system.

=cut

sub file_name_is_absolute {
    my $file = shift;
    my $r;
    eval {
        require File::Spec;
        $r = File::Spec->file_name_is_absolute($file);
    };
    if ($@) {
	if ($^O eq 'MSWin32') {
	    $r = ($file =~ m;^([a-z]:(/|\\)|\\\\|//);i);
	} else {
	    $r = ($file =~ m|^/|);
	}
    }
    $r;
}
# REPO END

# REPO BEGIN
# REPO NAME rel2abs /home/e/eserte/src/repository 
# REPO MD5 bc5f1345a60d58768f98dc20a434cd0c
sub rel2abs {
    my($path, $base) = @_;
    require File::Spec;
    if (File::Spec->can("rel2abs")) {
	File::Spec->rel2abs($path, $base);
    } else {
	if ( ! file_name_is_absolute( $path ) ) {
	    # Figure out the effective $base and clean it up.
	    if ( !defined( $base ) || $base eq '' ) {
		require Cwd;
		$base = Cwd::cwd() ;
	    }
	    elsif ( ! file_name_is_absolute( $base ) ) {
		$base = rel2abs( $base ) ;
	    }
	    else {
		$base = File::Spec->canonpath( $base );
	    }

	    # Glom them together
	    $path = File::Spec->catdir( $base, $path ) ;
	}

	return File::Spec->canonpath( $path ) ;
    }
}
# REPO END

# REPO BEGIN
# REPO NAME catfile /home/e/eserte/src/repository 
# REPO MD5 0c04863c43c3eb9e92772bc0b73ad923
=head2 catfile($dirname, $dirname, ..., $basename)

Take dirname and basename portions and return an entire path. This is
only necessary for older perls where File::Spec is not part of the
system.

=cut

sub catfile {
    my(@args) = @_;
    my $path;
    eval {
        require File::Spec;
        $path = File::Spec->catfile(@args);
    };
    if ($@) {
        $path = join("/", @args);
    }
    $path;
}
# REPO END

# XXX maybe use gnuclient instead...
sub call_emacs {
    my $elisp_code = shift;

    my $elisp_file = "$tmp/incorporate.el";
    if (open(F, ">$elisp_file")) {
	print F "$elisp_code\n";
	close F;
	system("emacs -q -l $elisp_file &");
	return 1;
    } else {
	warn "Can't create $elisp_file";
	return 0;
    }
}

sub create_hidden_sel_window {
    if (!defined $msg) {
	$msg = 0;
	# complex IPC code for X11 selection...
	eval q{use IPC::Msg;
	       use IPC::SysV qw(IPC_PRIVATE S_IRWXU S_IRWXG S_IRWXO);
	       use Tk;
	       $msg = new IPC::Msg(IPC_PRIVATE,
				   S_IRWXU | S_IRWXG | S_IRWXO);
	       $SIG{INT} = sub { exit };
	       END { $msg->remove if $msg }
	       $childpid = fork;
	       if (!$childpid) {
		   my $buf;
		   my $top;
		   my $pending;
		   my $handler = sub {
		       if (!$top) {
			   $pending = 1;
			   return;
		       }
		       $msg->rcv($buf, SEL_BUFFER);
		       ($buf) = split(/\0/, $buf, 1);
		       $top->SelectionOwn;
		       $top->SelectionHandle(sub { $buf });
		   };
		   $SIG{USR1} = $handler;
		   $top = new MainWindow;
		   $top->withdraw;
		   if ($pending) {
		       $handler->();
		   }
		   MainLoop;
		   CORE::exit(0);
	       }
	      };
	warn $@ if $@;
	$msg = 0 if $@;
    }
}

sub send_selection_to_process {
    my $sel_string = shift;
    if (defined $msg and $msg != 0) {
	select(undef,undef,undef,0.05) if !$wait_done;
	$wait_done++;
	my $buf = "\0" x SEL_BUFFER;
	substr($buf, 0) = $sel_string;
	$msg->snd(1, $buf);
	kill USR1 => $childpid
    }
}

sub set_selection {
    my $sel_string = shift;
    create_hidden_sel_window();
    send_selection_to_process($sel_string);
}

sub quote_single {
    my $s = shift;
    $s =~ s/\'/\\\'/g;
    "'" . $s . "'";
}

# cmp functions: return 0 if the files are the same
sub exact_cmp {
    my($from, $to) = @_;
    system("cmp", "-s", $from, $to)/256;
}

# be optimistic: if the files have the same modtime and size, then they
# are the same
sub fast_cmp {
    my($from, $to) = @_;
    my @s1 = stat($from);
    my @s2 = stat($to);
    return 1 if !@s1 || !@s2; # one file is missing
    # different modtimes and the files are really differing
    return exact_cmp($from, $to) if $s1[9] != $s2[9];
    return 1 if $s1[7] != $s2[7];
    0;
}

sub extract {
    my $archiver = shift || "";

    $tmp_extract_dir = "$tmp/incorporate-extract-$archiver-$$";
    if (-d $tmp_extract_dir) {
	undef $tmp_extract_dir;
	die "Extract directory $tmp_extract_dir already exists";
    }
    require File::Path;
    File::Path::mkpath([$tmp_extract_dir], 1, 0700);
    require Cwd;
    my $cwd = Cwd::cwd();
    my $fromtgz = (file_name_is_absolute($fromdir)
		   ? $fromdir
		   : catfile($cwd, $fromdir)
		  );

    chdir $tmp_extract_dir || die "Can't chdir to $tmp_extract_dir: $!";

    if ($archiver eq "") {
	# guess...
	if ($fromtgz =~ /\.t(ar\.)?gz$/) {
	    $archiver = "tgz";
	} elsif ($fromtgz =~ /\.zip$/) {
	    $archiver = "zip";
	}
    }

    if ($archiver eq 'tgz') {
	#system("tar", "xfvzp", "$fromtgz");
	system("zcat $fromtgz | tar xfvp -");
    } elsif ($archiver eq 'zip') {
	system("unzip", "$fromtgz");
    } elsif ($archiver eq 'uudecode') {
	die "No uudecode file given" unless defined $uudecode_file;
	system("uudecode", "$fromtgz");
	$fromdir = $uudecode_file;
	return extract();
    } else {
	die "$archiver?";
    }

    my(@extracted) = glob("*");
    if (@extracted != 1 || !-d $extracted[0]) {
	die "Archive contents are ambiguous (not a single directory)";
    }
    $fromdir = $tmp_extract_dir . "/" . $extracted[0];
    chdir $cwd || die "Can't chdir back to $cwd: $!";
}

sub is_uuencoded {
    my $file = shift;
    my $is_uuencoded = 0;
    if (open(F, $file)) {
	while(<F>) {
	    chomp;
	    /^begin\s+[0-7]+\s+(.*)/ and do {
		$uudecode_file = $1;
		$is_uuencoded++;
		last;
	    };
	}
	close F;
    } else {
	die "Can't open $file: $!";
    }
    $is_uuencoded;
}

sub tmpdir {
    foreach my $d ($ENV{TMPDIR}, $ENV{TEMP},
		   "/tmp", "/var/tmp", "/usr/tmp", "/temp") {
	next if !defined $d;
	next if !-d $d || !-w $d;
	if ($^O eq 'MSWin32') {
	    $d =~ s|\\|/|g;
	}
	return $d;
    }
    undef;
}

END {
    if ($$ == $main_pid && defined $tmp_extract_dir && -d $tmp_extract_dir &&
	$tmp_extract_dir =~ m|^$tmp|) {
	system("rm", "-rf", $tmp_extract_dir);
    }
}

# stolen from tkpop
package Tk::MyHList;
BEGIN { @ISA = qw(Tk::HList) }

sub Button1
{
 my $w = shift;
 my $Ev = $w->XEvent;

 delete $w->{'shiftanchor'};
 delete $w->{tixindicator};

 $w->focus() if($w->cget('-takefocus'));

 my $mode = $w->cget('-selectmode');

 if ($mode eq 'dragdrop')
  {
   # $w->Send_WaitDrag($Ev->y);
   return;
  }

 my $ent = $w->GetNearest($Ev->y, 1);

 if (!defined($ent) || !length($ent))
  {
    $w->selectionClear;
    $w->anchorClear;
    return;
  }

 my @info = $w->info('item',$Ev->x, $Ev->y);
 if (@info)
  {
   die 'Assert' unless $info[0] eq $ent;
  }
 else
  {
   @info = $ent;
  }

 if (defined($info[1]) && $info[1] eq 'indicator')
  {
   $w->{tixindicator} = $ent;
   $w->Callback(-indicatorcmd => $ent, '<Arm>');
  }
 else
  {
   my $browse = 0;

   if ($mode eq 'single')
    {
     $w->anchorSet($ent);
    }
   elsif ($mode eq 'browse')
    {
     $w->anchorSet($ent);
     $w->selectionClear;
     $w->selectionSet($ent);
     $browse = 1;
    }
   elsif ($mode eq 'multiple')
    {
     $w->selectionClear;
     $w->anchorSet($ent);
     $w->selectionSet($ent);
     $browse = 1;
    }
   elsif ($mode eq 'extended')
    {
     if ($w->selectionIncludes($ent))
      {
       $w->selectionClear($ent);
      }
     else
      {
       $w->selectionSet($ent);
      }
     $w->{'LastEnt'} = $ent;
     $browse = 1;
    }

   if ($browse)
    {
     $w->Callback(-browsecmd => @info);
    }
  }
}

sub CtrlButton1 {
#      my $w = shift;
#      my $Ev = $w->XEvent;

#      delete $w->{'shiftanchor'};

#      my $ent = $w->GetNearest($Ev->y);

#      return unless (defined($ent) and length($ent));

#      my $mode = $w->cget('-selectmode');

#      if($mode eq "extended")	{
#  #	$w->anchor('set', $ent) unless( $w->info('anchor') );

#  	if($w->select('includes', $ent)) {
#  	    $w->select('clear', $ent);
#  warn "undef 2";
#  	    undef $w->{'LastEnt'};
#  	} else {
#  	    $w->select('set', $ent);
#  	    $w->{'LastEnt'} = $ent;
#  	}
#  	$w->Callback(-browsecmd =>$ent);
#      }
}

sub ButtonRelease1 {
 my ($w, $Ev) = @_;

 my ($x, $y) = ($Ev->x, $Ev->y);
 my $ent = $w->GetNearest($y, 1);
 return unless defined $ent;
 return unless $w->{ReleaseCommand};
 $w->{ReleaseCommand}->($w, $ent);
}

sub Button1Motion {
    my $w = shift;
    my $Ev = $w->XEvent;

    delete $w->{'shiftanchor'};

    my $mode = $w->cget('-selectmode');

    if ($mode eq "dragdrop") {
#   $w->Send_StartDrag();
	return;
    }

    my $ent = $w->GetNearest($Ev->y);
    return unless (defined($ent) and length($ent));

    if($w->{tixindicator}) {
	my $event_type = $w->{tixindicator} eq $ent ? "<Arm>" : "<Disarm>";
	$w->Callback(-indicatorcmd => $w->{tixindicator}, $event_type );
	return;
    }

    if (!defined $w->{'LastEnt'} || $w->{'LastEnt'} ne $ent) {
  	if ($w->selectionIncludes($ent)) {
  	    $w->selectionClear($ent);
  	} else {
	    $w->selectionSet($ent);
	}
	$w->{'LastEnt'} = $ent;
    }

    if ($mode ne "single") {
	$w->Callback(-browsecmd =>$ent);
    }
}

package Incorporate::Tk;

use strict;
use vars qw($mw $redstyle $greenstyle);

sub mw {
    require Tk;
    require Tk::HList;
    require Tk::ItemStyle;
    require Tk::ROText;

    eval {
	package Tk::MyHList;
	Tk::Widget->Construct('MyHList');
    };
    die $@ if $@;

    $mw = MainWindow->new;
    $mw->title("$main::fromdir => $main::todir");

    for (qw(Entry NumEntry Listbox KListbox K2Listbox TixHList HList MyHList
	    Text ROText BrowseEntry.Entry)) {
	$mw->optionAdd("*$_.background", "grey95", "userDefault");
    }
    $mw->optionAdd("*MyHList.selectBackground", "green");

    my $src_f = $mw->Frame->packAdjust(-side => "left", -fill => "both", -expand => 1);
    my $dest_f = $mw->Frame->packAdjust(-side => "left", -fill => "both", -expand => 1);
    my $diff_f = $mw->Frame->pack(-side => "left", -fill => "both", -expand => 1);

    $redstyle = $mw->ItemStyle("text", -foreground => "red", -background => "grey95");
    $greenstyle = $mw->ItemStyle("text", -foreground => "darkgreen", -background => "grey95");

    $src_f->Label(-text => "New files:")->pack;
    my $new_files_hl = $src_f->Scrolled("MyHList", -selectmode => 'extended', -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);
    $src_f->Label(-text => "Changed files:")->pack;
    my $changed_files_hl = $src_f->Scrolled("MyHList", -selectmode => 'extended', -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);

    my $std_height = 6;
    $dest_f->Label(-text => "Don't copy:")->pack;
    my $dont_copy_hl = $dest_f->Scrolled("MyHList", -height => $std_height, -selectmode => 'extended', -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);
    $dest_f->Label(-text => "Never copy:")->pack;
    my $never_copy_hl = $dest_f->Scrolled("MyHList", -height => $std_height, -selectmode => 'extended', -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);
    $dest_f->Label(-text => "Copy:")->pack;
    my $copy_hl = $dest_f->Scrolled("MyHList", -height => $std_height, -selectmode => 'extended', -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);
    $dest_f->Label(-text => "Merge:")->pack;
    my $merge_hl = $dest_f->Scrolled("MyHList", -height => $std_height, -selectmode => 'extended', -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);

    $diff_f->Label(-text => "Diff:")->pack;
    my $diff_txt = $diff_f->Scrolled("ROText", -width => 40,
				     -wrap => "none",
				     -font => "fixed",
				     -scrollbars => "osoe")->pack(-fill => "both", -expand => 1);
    my $bf = $diff_f->Frame->pack(-fill => "x");
    $bf->Button(-text => "Cancel",
		-command => sub { $mw->destroy },
	       )->pack(-side => "left", -fill => "x", -expand => 1);
    $bf->Button(-text => "Do it!",
		-command => \&do_it,
	       )->pack(-side => "left", -fill => "x", -expand => 1);

    $mw->Advertise("NewFiles"	   => $new_files_hl);
    $mw->Advertise("ChangedFiles"  => $changed_files_hl);
    $mw->Advertise("DontCopy"	   => $dont_copy_hl);
    $mw->Advertise("NeverCopy"	   => $never_copy_hl);
    $mw->Advertise("Copy"	   => $copy_hl);
    $mw->Advertise("Merge"	   => $merge_hl);
    $mw->Advertise("Diff"	   => $diff_txt);

    my $new_files_popup_menu = $new_files_hl->Menu;
    $new_files_popup_menu->command
	(-label => "don't copy",
	 -command => sub { move_items($new_files_hl, $dont_copy_hl) }
	);
    $new_files_popup_menu->command
	(-label => "never copy",
	 -command => sub { move_items($new_files_hl, $never_copy_hl) }
	);
    $new_files_popup_menu->command
	(-label => "copy",
	 -command => sub { move_items($new_files_hl, $copy_hl) }
	);
    $new_files_hl->bind("<ButtonPress-3>" => sub {
			    my $e = $_[0]->XEvent;
			    $new_files_popup_menu->Post($e->X, $e->Y);
			});

    my $changed_files_popup_menu = $changed_files_hl->Menu;
    $changed_files_popup_menu->command
	(-label => "don't copy",
	 -command => sub { move_items($changed_files_hl, $dont_copy_hl) }
	);
    $changed_files_popup_menu->command
	(-label => "never copy",
	 -command => sub { move_items($changed_files_hl, $never_copy_hl) }
	);
    $changed_files_popup_menu->command
	(-label => "copy",
	 -command => sub { move_items($changed_files_hl, $copy_hl) }
	);
    $changed_files_popup_menu->command
	(-label => "merge",
	 -command => sub { move_items($changed_files_hl, $merge_hl) }
	);
    $changed_files_hl->bind("<ButtonPress-3>" => sub {
				my $e = $_[0]->XEvent;
				$changed_files_popup_menu->Post($e->X, $e->Y);
			    });

    foreach my $w ($dont_copy_hl, $never_copy_hl, $copy_hl, $merge_hl) {
	my $menu = $w->Menu;
	$menu->command(-label => "dismiss",
		       -command => [sub { dismiss(@_) }, $w],
		      );
	$w->bind("<ButtonPress-3>" => sub {
		     my $e = $_[0]->XEvent;
		     $menu->Post($e->X, $e->Y);
		 });
    }

    foreach my $w ($dont_copy_hl, $never_copy_hl, $copy_hl, $merge_hl,
		   $changed_files_hl) {
	my $ww = $w;
	$ww->Subwidget("scrolled")->{ReleaseCommand} = sub {
	    show_diff($ww->entrycget($_[1], "-text"))
	};
    }

}

sub fill {
    my(%args) = @_;
    my($diff_files_ref, $dont_exist_files_ref) =
	($args{-changed}, $args{-new});
    my %only_rcs_change_files;
    if ($args{-rcschangeonly}) {
	%only_rcs_change_files = map { ($_ => 1) } @{ $args{-rcschangeonly} };
    }

    my $new_files_hl = $mw->Subwidget("NewFiles");
    my $changed_files_hl = $mw->Subwidget("ChangedFiles");
    my $never_copy_hl = $mw->Subwidget("NeverCopy");

    $new_files_hl->delete("all");
    $changed_files_hl->delete("all");
    $never_copy_hl->delete("all");

    my %never_copy_files;

    if (open(NEVERCOPY, "$main::todir/.incorporate.nevercopy")) {
	my $i = 0;
	while(<NEVERCOPY>) {
	    chomp;
	    $never_copy_files{$_}++;
	    $never_copy_hl->add($i, -text => $_, -itemtype => "text");
	    $i++;
	}
	close NEVERCOPY;
    }



    my $i = 0;
    foreach my $file (@$dont_exist_files_ref) {
	next if $never_copy_files{$file};
	$new_files_hl->add($i, -text => $file, -itemtype => "text");
	$i++;
    }


    $i = 0;
    foreach my $file (@$diff_files_ref) {
	next if $never_copy_files{$file};
	my %args;
	if ($only_rcs_change_files{$file}) {
	    $args{-style} = $greenstyle;
	}
	if ((stat("$main::todir/$file"))[9] > (stat("$main::fromdir/$file"))[9]) {
	    $args{-style} = $redstyle;
	}

	$changed_files_hl->add($i,
			       -text => $file,
			       -itemtype => "text",
			       %args);

	$i++;
    }
}

sub move_items {
    my($from, $to) = @_;
    my $last_in_to = ($to->info("children"))[-1];
    foreach my $item ($from->info("selection")) {
	my $f = $from->entrycget($item, "-text");
	$last_in_to++;
	$to->add($last_in_to, -text => $f,
		 -data => {'Src' => $from,
			   'SrcEntry' => $item,
			   'SrcStyle' => $from->entrycget($item, "-style"),
			  });
	$from->delete("entry", $item);
    }
}

sub dismiss {
    my($from) = @_;
    foreach my $item ($from->info("selection")) {
	my $data = $from->info("data", $item);
	next unless ref $data eq 'HASH';
	my $to = $data->{Src};
	next unless $to;
	my $to_entry = $data->{SrcEntry};
	my $f = $from->entrycget($item, "-text");
	$to->add($to_entry, -text => $f,
		 -itemtype => "text",
		 ($data->{SrcStyle} ? (-style => $data->{SrcStyle}) : ()),
		);
	$from->delete("entry", $item);
    }
}

sub show_diff {
    my $file = shift;
    my $fromfile = "$main::fromdir/$file";
    my $tofile   = "$main::todir/$file";

    return unless -r "$main::todir/$file";

    my $diff_result = `diff -u $tofile $fromfile`;

    my $diff_txt = $mw->Subwidget("Diff");
    $diff_txt->delete("1.0", "end");
    $diff_txt->insert("end", $diff_result);
}

sub loop {
    Tk::MainLoop();
}

sub do_it {

    # ignore dont_copy

    # copy:
    my $copy_hl = $mw->Subwidget("Copy");
    foreach my $item ($copy_hl->info("children")) {
	my $file = $copy_hl->entrycget($item, "-text");
	main::do_real_copy($file);
    }

    # merge:
    my $emacs_s = "(progn\n";
    my $merge_hl = $mw->Subwidget("Merge");
    foreach my $item ($merge_hl->info("children")) {
	my $file = $merge_hl->entrycget($item, "-text");
	$emacs_s .= main::get_emacs_lisp_diff_line($file) . "\n";
    }
    $emacs_s .= ")\n";
    print $emacs_s;
    # XXX und nun???

    # never copy:
    my $never_copy_s = "";
    my $never_copy_hl = $mw->Subwidget("NeverCopy");
    foreach my $item ($never_copy_hl->info("children")) {
	my $file = $never_copy_hl->entrycget($item, "-text");
	$never_copy_s .= $file . "\n";
    }
    if ($never_copy_s ne "") {
	if (open(NEVERCOPY, ">$main::todir/.incorporate.nevercopy")) {
	    print NEVERCOPY $never_copy_s;
	    close NEVERCOPY;
	} else {
	    warn "Can't write .incorporate.nevercopy file: $!";
	}
    }

    $mw->destroy;
}

__END__

=head1 NAME

incorporate - interactively integrate two directory trees

=head1 SYNOPSIS

    incorporate [-n] [-ignorercs] [-tk] fromdir todir

=head1 DESCRIPTION

B<incorporate> is a program for restoring a backup archive. For each
file in the directory C<fromdir>, the program prompts whether the file
should be copied to C<todir>. It works interactively with C<sdiff> to
merge differences between the archived and local file.

If invoked with the C<-tk> switch (or as C<tkincorporate>), then a Tk
GUI will be used instead, if Tk is available.

=head2 OPTIONS

=over 4

=item -n

Display the commands that would have been executed, but do not
actually execute them.

=item -ignorercs

Ignore RCS or CVS files.

=item -tk

Use the Tk interface.

=back

=head1 PREREQUISITES

Only standard perl modules.

=head1 COREQUISITES

C<Tk>, C<Term::Cap>

=head1 OSNAMES

only tested on Unix

=head1 SCRIPT CATEGORIES

???

=head1 AUTHOR

Slaven Rezic <slaven.rezic@berlin.de>

=head1 SEE ALSO

sdiff(1).

=cut