File Coverage

blib/lib/ClearCase/SyncTree.pm

Criterion	Covered	Total	%
statement	60	1042	5.7
branch	2	514	0.3
condition	0	164	0.0
subroutine	18	74	24.3
pod	15	48	31.2
total	95	1842	5.1

package ClearCase::SyncTree;

$VERSION = '0.60';

require 5.004;

use strict;

use Cwd;
use File::Basename;
use File::Compare;
use File::Copy;
use File::Find;
use File::Path;
use File::Spec 0.82;
use ClearCase::Argv 1.34 qw(chdir);

use constant MSWIN => $^O =~ /MSWin|Windows_NT/i ? 1 : 0;
use constant CYGWIN => $^O =~ /cygwin/i ? 1 : 0;

my $lext = '.=lnk=';	# special extension for pseudo-symlinks

sub new {
    my $proto = shift;
    my $class;
    if ($class = ref($proto)) {
	# Make a (deep) clone of the invoking instance
	require Clone;
	Clone->VERSION(0.12);	# 0.10 has a known bug
	return Clone::clone($proto);
    }
    $class = $proto;
    my $self = {@_};
    bless $self, $class;
    $self->comment('By:' . __PACKAGE__);
    # Default is to sync file modes unless on ^$%#* Windows.
    $self->protect(1);
    # Set up a ClearCase::Argv instance with the appropriate attrs.
    $self->ct;
    # By default we'll call SyncTree->fail on any cleartool error.
    $self->err_handler($self, 'fail');
    # Set default file comparator.
    $self->cmp_func(\&File::Compare::compare);
    return $self;
}

sub err_handler {
    my $self = shift;
    my $ct = $self->ct;
    if (@_ >= 2) {
	my($obj, $method) = @_;
	$method = join('::', ref($obj), $method) unless $method =~ /::/;
	$ct->autofail([\&$method, $obj]);
    } else {
	$ct->autofail(@_);
    }
}

# For internal use only.  Provides a std msg format.
sub _msg {
    my $prog = basename($0);
    my $type = shift;
    my $msg = "@_";
    chomp $msg;
    return "$prog: $type: $msg\n";
}

# For internal use only.  A synonym for die() with a std error msg format.
sub fatal {
    die _msg('Error', @_);
}

# For internal use only.  A synonym for warn() with a std error msg format.
sub warning {
    warn _msg('Warning', @_);
}

# For internal use only.  Returns the ClearCase::Argv object.
sub ct {
    my $self = shift;
    return $self->{ST_CT} if $self->{ST_CT};
    if (!defined(wantarray)) {
	my $ct = ClearCase::Argv->new({autochomp=>1, outpathnorm=>1});
	$ct->syxargs($ct->qxargs);
	$self->{ST_CT} = $ct;
    }
    return $self->{ST_CT};
}

# For internal use only.  Returns a clone of the ClearCase::Argv object.
sub clone_ct {
    my $self = shift;
    my $ct = $self->ct->clone(@_);
    my $af = $self->ct->autofail
          unless $_[0] and (ref($_[0]) eq 'HASH') and exists $_[0]->{autofail};
    $ct->autofail($af) if $af && ref($af); #Cloning doesn't share the value
    return $ct;
}

sub gen_accessors {
    my @key = map {uc} @_;
    no strict 'refs';
    for (@key) {
	my $var = "ST_$_";
	my $meth = lc;
	*$meth = sub {
	    my $self = shift;
	    $self->{$var} = shift if @_;
	    return $self->{$var};
	}
    }
}
gen_accessors(qw(protect remove reuse vreuse lblver ignore_co overwrite_co
		 snapdest ctime lbtype inclb cmp_func rellinks dstview));
sub gen_flags {
    my @key = map {uc} @_;
    no strict 'refs';
    for (@key) {
	my $var = "ST_$_";
	my $meth = lc;
	*$meth = sub {
	    my $self = shift;
	    $self->{$var} = 1 if $_[0] || !defined(wantarray);
	    return $self->{$var};
	}
    }
}
gen_flags(qw(label_mods no_cr no_cmp));

sub comment {
    my $self = shift;
    my $cmnt = shift;
    if (ref $cmnt) {
	$self->{ST_COMMENT} = $cmnt;
    } elsif ($cmnt) {
	$self->{ST_COMMENT} = ['-c', $cmnt];
    }
    return $self->{ST_COMMENT};
}

sub normalize {
    my $self = shift;
    chomp(my $path = shift);
    my $dv = $self->dstview;
    my $md = $self->mvfsdrive if MSWIN;
    for ($path) {
	if (MSWIN) {
	    s%^$md:%%;
	    s%^[\\/]\Q$dv%%;
	    s%\\%/%g;
	    $_ = "$md:/$dv$_";
	} elsif (CYGWIN) {
	    # 4 cases: unc; /view/x user mount; view drive; mvfs drive/tag
	    s%^/(/?view/$dv|cygdrive/\w(/$dv)?)%%;
	    $_ = "//view/$dv$_";
	} else {
	    s%^/view/$dv%%;
	    $_ =  "/view/$dv$_";
	}
	s%/\.?$%%;
    }
    return $path;
}

sub canonicalize {
    my $self = shift;
    my $base = shift;
    for (@_) {
	$_ = File::Spec->canonpath(join('/', $base, $_))
			if $_ && ! File::Spec->file_name_is_absolute($_);
    }
}

# Returns -other and -do private files. Checkouts are handled separately.
sub _lsprivate {
    my $self = shift;
    my $implicit_dirs = shift;
    my $base = $self->dstbase;
    my $dv = $self->dstview;
    my $ct = $self->clone_ct({autofail=>0, stderr=>0});
    my @vp;
    for ($ct->argv('lsp', [qw(-oth -do -s -inv), "$base/.", '-tag', $dv])->qx) {
	$_ = $self->normalize($_);
	push(@vp, $_) if m%^\Q$base/%;
    }
    push(@vp, grep {$ct->des([qw(-s)], "$_/.\@\@")->stdout(0)->system}
	   @{$self->{ST_IMPLICIT_DIRS}})
			         if $self->{ST_IMPLICIT_DIRS} && $implicit_dirs;
    return @vp;
}

sub _lsco {
    my $self = shift;
    my $base = $self->_mkbase;
    my $ct = $self->clone_ct;
    my $sil = $self->clone_ct(stderr=>0, autofail=>0);
    my %co;
    for ($ct->lsco([qw(-s -cvi -a)], $base)->qx) {
	$_ = $self->normalize($_);
	$co{$_}++ if m%^\Q$base/% || $_ eq $base;
    }
    for my $dir (@{$self->{ST_IMPLICIT_DIRS}}) {
	my $dad = dirname($dir);
	$co{$dad}++ if $sil->lsco([qw(-s -cvi -d)], $dad)->qx;
    }
    return wantarray? sort keys %co : scalar keys %co;
}

sub mvfsdrive {
    my $self = shift;
    if (MSWIN && ! $self->{ST_MVFSDRIVE}) {
       no strict 'subs';
       use vars '$Registry';
       require Win32::TieRegistry;
       # HKLM is read-only for non-admins so open read-only
       Win32::TieRegistry->import('TiedRef', '$Registry', qw(KEY_READ));
       my $LMachine = $Registry->Open('LMachine', {Access => KEY_READ});
       $self->{ST_MVFSDRIVE} = $LMachine->{SYSTEM}->
	        {CurrentControlSet}->{Services}->{Mvfs}->{Parameters}->{drive};
       die "$0: Error: unable to find MVFS drive" unless $self->{ST_MVFSDRIVE};
    }
    return $self->{ST_MVFSDRIVE};
}

sub ccsymlink {
    my $dst = shift;
    return 1 if -l $dst;
    return 0 unless MSWIN || CYGWIN;
    my $ct = new ClearCase::Argv({autochomp=>1, stderr=>0});
    return $ct->des([qw(-fmt %m)], $dst)->qx eq 'symbolic link';
}

# readlink might work under some conditions (CC version, mount options, ...)
sub readcclink {
    my $dst = shift;
    my $ret = readlink $dst;
    return $ret if $ret || !(MSWIN || CYGWIN);
    my $ct = new ClearCase::Argv({autochomp=>1});
    $ret = $ct->ls($dst)->qx;
    $ret =~ s%\\%/%g if MSWIN;
    return (($ret =~ s/^.*? --> (.*)$/$1/)? $ret : '');
}

sub srcbase {
    my $self = shift;
    if (@_) {
	my $sbase = File::Spec->rel2abs(shift);
	$sbase =~ s%\\%/%g;	# rel2abs forces native (\) separator
	$sbase =~ s%/\.$%%;	# workaround for bug in File::Spec 0.82
	# File::Spec::Win32::rel2abs leaves trailing / on drive letter root.
	$sbase =~ s%/*$%% if $sbase ne '/';
	$self->{ST_SRCBASE} = $sbase;
	*src_slink = sub { return -l shift };
	*src_rlink = sub { return readlink shift };
	if (MSWIN || CYGWIN) {
	    my $ct = $self->clone_ct({autofail=>1, autochomp=>1});
	    my $olddir = getcwd;
	    $ct->_chdir($sbase) || die "$0: Error: $sbase: $!";
	    if ($ct->pwv(['-s'])->qx !~ /\s+NONE\s+/) {
		*src_slink = \&ccsymlink;
		*src_rlink = \&readcclink;
	    }
	    $ct->_chdir($olddir);
	}
    }
    return $self->{ST_SRCBASE};
}

sub dstbase {
    my $self = shift;
    if (@_) {
	my $dbase = shift;
	-e $dbase || mkpath($dbase, 0, 0777) || die "$0: Error: $dbase: $!";
	my $ct = $self->clone_ct({autofail=>1, autochomp=>1});
	my $olddir = getcwd;
	$ct->_chdir($dbase) || die "$0: Error: $dbase: $!";
	$dbase = getcwd;
	my $dv = $ct->pwv(['-s'])->qx;
	die "$0: Error: destination base ($dbase) not in a view/VOB context"
						if !$dv || $dv =~ m%\sNONE\s%;
	$self->dstview($dv);
	# We need to derive the current vob of the dest path, which we
	# do by cd-ing there temporarily and running "ct desc -s vob:.".
	# But with a twist because of @%$*&# Windows.
	my $dvob;
	if (!($dvob = $self->dstvob)) {
	    # We need this weird hack to get a case-correct version of the
	    # dest path, in case the user typed it in random case. There
	    # appears to be a bug in CC 4.2; "ct desc vob:foo" fails if
	    # "foo" is not the right case even if MVFS is set to be
	    # case insensitive. This is caseid v0869595, bugid CMBU00055321.
	    # Since Windows mount points must be at the root level,
	    # we assume the vob tag must be the root dir name. We must
	    # still then look that up in lsvob to get the tag case right.
	    if (MSWIN) {
		my @vobs = $ct->lsvob(['-s'])->qx;
		my $dirpart = (File::Spec->splitpath($dbase, 1))[1];
		for my $name (File::Spec->splitdir($dirpart)) {
		    last if $dvob;
		    next unless $name;
		    for my $vob (@vobs) {
			if ($vob =~ m%^[/\\]$name$%i) {
			    ($dvob = $vob) =~ s%\\%/%g;
			    last;
			}
		    }
		}
	    } else {
		$dvob = $ct->desc(['-s'], "vob:.")->qx;
	    }
	    $self->dstvob($dvob);
	}
	# On Windows, normalize the specified dstbase to use the
	# MVFS drive (typically M:), e.g. M:\view-name\vob-tag\path...
	# This avoids all kinds of problems with using the view
	# via a different drive letter or a UNC (\\view) path.
	# Similarly, on UNIX we normalize to a view-extended path
	# even if we're already in a set view because it's the
	# lowest common denominator. Also, if the set view differs
	# from the 'dest view', the dest view should win.
	if (MSWIN) {
	    $dbase =~ s%\\%/%g;
	    use vars '%RegHash';
	    require Win32::TieRegistry;
	    Win32::TieRegistry->import('TiedHash', '%RegHash');
	    my $mdrive = $self->mvfsdrive;
	    $dbase = getcwd;
	    $dbase =~ s%.*?$dvob%$mdrive:/$dv$dvob%i;
	} else {
	    $dbase = getcwd;
	    if (CYGWIN) {
	        $dbase =~ s%^/(/?view/$dv|cygdrive/\w)%%;
		$dbase = "//view/$dv$dbase";
	    } else {
	        $dbase =~ s%^/view/$dv%%;
		$dbase = "/view/$dv$dbase";
	    }
	}
	$ct->_chdir($olddir) || die "$0: Error: $olddir: $!";
	$self->{ST_DSTBASE} = $dbase;
	(my $dvb = $dbase) =~ s%^(.*?$dvob).*$%$1%;
	$self->snapdest(1) unless -e "$dvb/@@";
    }
    return $self->{ST_DSTBASE};
}

# We may have created a view-private parent tree, so must
# work our way upwards till we get to a versioned dir.
sub _mkbase {
    my $self = shift;
    if (! $self->{ST_MKBASE}) {
	my $mbase = $self->dstbase;
	my $dvob = $self->dstvob;
	(my $dext = $mbase) =~ s%(.*?$dvob)/.*%$1%;
	my $ct = $self->clone_ct({stdout=>0, stderr=>0, autofail=>0});
	while (1) {
	    last if length($mbase) <= length($dext);
	    last if -d $mbase && ! $ct->desc(['-s'], "$mbase/.@@")->system;
	    push(@{$self->{ST_IMPLICIT_DIRS}}, $mbase);
	    $mbase = dirname($mbase);
	}
	$self->{ST_MKBASE} = $mbase;
    }
    return $self->{ST_MKBASE};
}

sub dstvob {
    my $self = shift;
    if (@_) {
	$self->{ST_DSTVOB} = shift;
	$self->{ST_DSTVOB} =~ s%\\%/%g;
    }
    return $self->{ST_DSTVOB};
}

sub srclist {
    my $self = shift;
    my $type = ref($_[0]) ? ${shift @_} : 'NORMAL';
    my $sbase = $self->srcbase;
    die "$0: Error: must specify src base before src list" if !$sbase;
    for (@_) {
	next if $_ eq $sbase;
	if (m%^(?:[a-zA-Z]:)?$sbase[/\\]*(.+)%) {
	    $self->{ST_SRCMAP}->{$1}->{type} = $type;
	} elsif (-e "$sbase/$_") {
	    $self->{ST_SRCMAP}->{$_}->{type} = $type;
	} else {
	    warn "Warning: $_: no such file or directory\n";
	}
    }
}

sub srcmap {
    my $self = shift;
    my $type = ref($_[0]) ? ${shift @_} : 'NORMAL';
    my %sdmap = @_;
    my $sbase = $self->srcbase;
    my $dbase = $self->dstbase;
    die "$0: Error: must specify src base before src map" if !$sbase;
    die "$0: Error: must specify dst base before src map" if !$dbase;
    for (keys %sdmap) {
	if (m%^(?:[a-zA-Z]:)?\Q$sbase\E[/\\]*(.*)$%) {
	    my $key = $1;
	    $self->{ST_SRCMAP}->{$key}->{type} = $type;
	    my($dst) = ($sdmap{$_} =~ m%^\Q$dbase\E[/\\]*(.+)$%);
	    $self->{ST_SRCMAP}->{$key}->{dst} = $dst;
	} elsif (-e $_) {
	    $self->{ST_SRCMAP}->{$_}->{type} = $type;
	    if ($sdmap{$_} =~ m%^\Q$dbase\E[/\\]*(.+)$%) {
		$self->{ST_SRCMAP}->{$_}->{dst} = $1;
	    } else {
		$self->{ST_SRCMAP}->{$_}->{dst} = $sdmap{$_};
	    }
	} elsif (-e "$sbase/$_") {
	    $self->{ST_SRCMAP}->{$_}->{type} = $type;
	    $self->{ST_SRCMAP}->{$_}->{dst} = $sdmap{$_};
	} else {
	    warn "Warning: $_: no such file or directory\n";
	}
    }
}

sub eltypemap {
    my $self = shift;
    %{$self->{ST_ELTYPEMAP}} = @_ if @_;
    return $self->{ST_ELTYPEMAP} ? %{$self->{ST_ELTYPEMAP}} : ();
}

sub dstcheck {
    my $self = shift;
    my $dbase = $self->dstbase;
    die "$0: Error: must specify dest base before dstcheck" if !$dbase;
    my @existing = ();
    if (-e $dbase) {
	# Check for view private files under the dest base.
	my @vp = $self->_lsprivate(0);
	my $n = @vp;
	my $s = $n == 1 ? '' : 's';
	my $es = $n == 1 ? 's' : '';
	die "$0: Error: $n view-private file$s exist$es under $dbase:\n @vp\n"
									if @vp;
	# Check for checkouts under the dest base.
	@existing = $self->_lsco;
	$n = @existing;
	$s = $n >= 2 ? 's' : '';
	if ($n == 0) {
	    # do nothing
	} elsif ($self->ignore_co) {
	    warning "skipping $n checkout$s under $dbase";
	} elsif ($self->overwrite_co) {
	    warning "overwriting $n checkout$s under $dbase";
	} else {
	    fatal("$n checkout$s found under $dbase");
	}
    }
    $self->{ST_PRE} = { map {$_ => 1} @existing };
}

# Comparator function used to implement the -vreuse option
# If the default comparaison fails, look at versions of suitable size
# in the version tree, and apply the comparaison to them.
# If a suitable version is found, add it to a list of versions on which
# to apply a label.
sub vtcomp {
    my($self, $src, $dst) = @_;
    my $cmp = $self->cmp_func;
    my $lb = $self->lblver;
    if ($lb) {
        my $lblver = "$dst\@\@/$lb";
	$dst = $lblver if -r $lblver;
    }
    return 0 unless $cmp->($src, $dst);
    my $vt = ClearCase::Argv->lsvtree([qw(-a -s -nco)]);
    my @vt = reverse grep {m%[\\/]\d*$%} $vt->args($dst)->qx;
    chomp @vt;
    my $sz = -s $src;
    for (@vt) {
        next if -s $_ != $sz;
	if (!$cmp->($src, $_)) {
	    push @{$self->{ST_LBL}}, $_;
	    return 0;
	}
    }
    return 1;
}

sub _needs_update {
    my($self, $src, $dst, $comparator) = @_;
    my $update = 0;
    if (src_slink($src) && ccsymlink($dst)) {
	my $srctext = src_rlink($src);
	my $desttext = readcclink $dst;
	$update = !defined($comparator) || ($srctext ne $desttext);
    } elsif (! src_slink($src) && ! ccsymlink($dst)) {
	if (!defined($comparator)) {
	    $update = 1;
	} elsif ($self->vreuse) {
	    $update = $self->vtcomp($src, $dst);
	} elsif (-s $src != -s $dst) {
	    $update = 1;
	} else {
	    $update = &$comparator($src, $dst);
	}
	$self->failm("failed comparing $src vs $dst: $!") if $update < 0;
    } else {
	$update = 1;
    }
    if ($update && (!exists($self->{ST_PRE}->{$dst}) || $self->overwrite_co)) {
	return 1;
    } else {
	return 0;
    }
}

sub checkcs {
    my $self = shift;
    my($dest) = @_;
    my $ct = ClearCase::Argv->new({autofail=>1, autochomp=>1});
    my $pwd = getcwd;
    $ct->_chdir($dest) || die "$0: Error: $dest: $!";
    $dest = getcwd;
    my @cs = grep /^\#\#:BranchOff: *root/, $ct->argv('catcs')->qx;
    $ct->_chdir($pwd) || die "$0: Error: $pwd: $!";
    return scalar @cs;
}

sub analyze {
    my $self = shift;
    my $type = ref($_[0]) ? ${shift @_} : 'NORMAL';
    my $sbase = $self->srcbase;
    my $dbase = $self->dstbase;
    die "$0: Error: must specify dest base before analyzing" if !$dbase;
    die "$0: Error: must specify dest vob before analyzing" if !$self->dstvob;
    $self->_mkbase;
    $self->{branchoffroot} = $self->checkcs($dbase);
    # Derive the add and modify lists by traversing the src map and
    # comparing src/dst files.
    delete $self->{ST_ADD};
    delete $self->{ST_MOD};
    my @sl = $dbase eq $self->{ST_MKBASE}? sort grep{-d $_}
      $self->clone_ct->find($dbase, qw(-type l -print))->qx : ();
    map { $_ = "/$_" } @sl if CYGWIN; # mismatch between conventions
    if (@sl) {
	my %sl = map{ $_ => 1} @sl;
	for my $l (@sl) {
	    my $s = $l;
	    $s =~ s%^\Q$dbase\E/(.*)$%$1%;
	    if (exists $self->{ST_SRCMAP}->{$s}) {
		$s = join('/', $sbase, $s);
		delete $sl{$l} if src_slink($s);
	    }
	}
	@sl = sort keys %sl;
    }
    my $comparator = $self->no_cmp ? undef : $self->cmp_func;
    SRC: for (sort keys %{$self->{ST_SRCMAP}}) {
	next if $self->{ST_SRCMAP}->{$_}->{type} &&
		$self->{ST_SRCMAP}->{$_}->{type} !~ /$type/;
	my $src = join('/', $sbase, $_);
	$src = $_ unless -e $src || src_slink($src);
	my $dst = join('/', $dbase, $self->{ST_SRCMAP}->{$_}->{dst} || $_);
	for my $s (@sl) {
	    if ($dst =~ /^\Q$s\E/) {
		$self->{ST_DIRLNK}->{$s} = 1;
		$self->{ST_ADD}->{$_}->{src} = $src;
		$self->{ST_ADD}->{$_}->{dst} = $dst;
		next SRC;
	    }
	}
	# It's possible for a symlink to not satisfy -e if it's dangling.
	# Case-insensitive file test operators are a problem on Windows.
	# You cannot modify files when they don't exist under the proper name.
	if (! ecs($dst) && ! ccsymlink($dst)) {
	    $self->{ST_ADD}->{$_}->{src} = $src;
	    $self->{ST_ADD}->{$_}->{dst} = $dst;
	} elsif (! -d $src || src_slink($src)) {
	    if ($self->_needs_update($src, $dst, $comparator)) {
		$self->{ST_MOD}->{$_}->{src} = $src;
		$self->{ST_MOD}->{$_}->{dst} = $dst;
	    }
	}
    }
    if ($self->{ST_DIRLNK}) {
	my @rem;
	my @slst = sort keys %{$self->{ST_DIRLNK}};
	for (reverse @slst) {
	    for my $l (@slst) {
		if (/^\Q$l\E./) {
		    push @rem, $_;
		    last;
		}
	    }
	}
	delete @{$self->{ST_DIRLNK}}{@rem} if @rem;
	unlink $self->{ST_DIRLNK} unless keys %{$self->{ST_DIRLNK}};
    }
    # Last, check for subtractions but only if asked - it's potentially
    # expensive and error-prone.
    return unless $self->remove;
    my(%dirs, %files, %xfiles);
    my $wanted = sub {
	my $path = $File::Find::name;
	return if $path eq $dbase;
	if ($path =~ /lost\+found/) {
	    $File::Find::prune = 1;
	    return;
	}
	# Get a relative path from the absolute path.
	(my $relpath = $path) =~ s%^\Q$dbase\E\W?%%;
	if (ccsymlink($path)) { # Vob link
	    $files{$relpath} = $path;
	} elsif (-d $path) {
	    $dirs{$path} = $relpath;
	} elsif (-f $path) {
	    $files{$relpath} = $path;
	}
    };
    find($wanted, $dbase);
    my %dst2src;
    for (keys %{$self->{ST_SRCMAP}}) {
	my $dst = $self->{ST_SRCMAP}->{$_}->{dst};
	$dst2src{$dst} = $_ if $dst;
    }
    for (sort keys %files) {
	next if $self->{ST_SRCMAP}->{$_} && !$self->{ST_SRCMAP}->{$_}->{dst};
	$xfiles{$files{$_}}++ if !$dst2src{$_};
    }
    $self->{ST_SUB}->{exfiles} = \%xfiles;
    $self->{ST_SUB}->{dirs} = \%dirs;
}

sub preview {
    my $self = shift;
    my $indent = ' ' x 4;
    my($adds, $mods, $subs) = (0, 0, 0);
    if ($self->{ST_DIRLNK}) {
	my $dl = keys %{$self->{ST_DIRLNK}};
	print "Removing $dl directory symlinks:\n";
	for (sort keys %{$self->{ST_DIRLNK}}) {
	    print "${indent}$_\n";
	}
    }
    if ($self->{ST_ADD}) {
	$adds = keys %{$self->{ST_ADD}};
	print "Adding $adds elements:\n";
	for (sort keys %{$self->{ST_ADD}}) {
	    printf "$indent%s +=>\n\t%s\n", $self->{ST_ADD}->{$_}->{src},
			 $self->{ST_ADD}->{$_}->{dst};
	}
    }
    if ($self->{ST_MOD}) {
	$mods = keys %{$self->{ST_MOD}};
	print "Modifying $mods elements:\n";
	for (sort keys %{$self->{ST_MOD}}) {
	    printf "$indent%s ==>\n\t%s\n", $self->{ST_MOD}->{$_}->{src},
			 $self->{ST_MOD}->{$_}->{dst};
	}
    }
    if ($self->remove && $self->{ST_SUB}) {
	my @exfiles = sort keys %{$self->{ST_SUB}->{exfiles}};
	$subs = @exfiles;
	print "Subtracting $subs elements:\n" if $subs;
	for (@exfiles) {
	    printf "$indent%s\n", $_;
	}
    }
    my $total = $adds + $mods + $subs;
    print "Element change summary: add=$adds modify=$mods subtract=$subs\n";
    return $total;
}

sub pbrtype {
    my $self = shift;
    my $bt = shift;
    my $ct = $self->clone_ct;
    my $vob = $self->{ST_DSTVOB};
    if (!defined($self->{ST_PBTYPES}->{$bt})) {
	my $tc = $ct->des([qw(-fmt %[type_constraint]p)],
			                              "brtype:$bt\@$vob")->qx;
	$self->{ST_PBTYPES}->{$bt} = ($tc =~ /one version per branch/);
    }
    return $self->{ST_PBTYPES}->{$bt};
}

sub branchco {
    my $self = shift;
    my $dir = shift;
    my @ele = @_;
    my $ct = $self->clone_ct({autochomp=>0});
    my $rc;
    if ($self->{branchoffroot}) {
	foreach my $e (@ele) {
	    my $sel = $ct->ls(['-d'], $e)->autochomp(1)->qx;
	    if ($sel =~ /^(.*?) +Rule:.*-mkbranch (.*?)\]?$/) {
		my ($ver, $bt) = ($1, $2);
		my $sil = $self->clone_ct({stdout=>0, stderr=>0});
		my $main = 'main';
		if ($sil->des(['-s'], "$e\@\@/main/0")->system) {
		    $main = ($ct->lsvtree($e)->autochomp(1)->qx)[0];
		    $main =~ s%^[^@]*\@\@[\\/](.*)\r?$%$1%;
		}
		my $re = $self->pbrtype($bt) ?
		  qr([\\/]${main}[\\/]$bt[\\/]\d+$) : qr([\\/]$bt[\\/]\d+$);
		if ($ver =~ m%$re%) {
		    $rc |= $ct->co($self->comment, $e)->system;
		} else {
		    my $r = $ct->mkbranch([@{$self->comment}, '-ver',
					      "/${main}/0", $bt], $e)->system;
		    if ($r) {
			$rc = 1;
		    } else {
			if ($ver !~ m%\@\@[\\/]${main}[\\/]0$%) {
			    $rc |= $dir ?
				$ct->merge(['-to', $e],
					   $ver)->stdout(0)->system :
				$ct->merge(['-ndata', '-to', $e],
					   $ver)->stdout(0)->system;
			    unlink("$e.contrib");
			}
		    }
		}
	    } else {
		$rc |= $ct->co($self->comment, $e)->system;
	    }
	}
    } else {
	$rc = $ct->co($self->comment, @ele)->system;
    }
    return $rc;
}

sub rmdirlinks {
    my $self = shift;
    return unless $self->{ST_DIRLNK};
    my $lsco = ClearCase::Argv->lsco([qw(-s -d -cview)]);
    for (sort {$b cmp $a} keys %{$self->{ST_DIRLNK}}) {
	my $dad = dirname $_;
	$self->branchco(1, $dad) unless $lsco->args($dad)->qx;
	$self->clone_ct->rm($_)->system;
	delete $self->{ST_SUB}->{exfiles}->{$_}; #If it is there
    }
}

sub mkrellink {
    my ($self, $src) = @_;
    my $txt = src_rlink($src);
    my $sbase = $self->srcbase;
    return $txt unless $self->{ST_RELLINKS} and ($txt =~ /^$sbase/);
    $txt =~ s%^$sbase/(.*)%$1%;
    $src =~ s%^$sbase/(.*)%$1%;
    my @t = split m%/%, $txt;
    my @s = split m%/%, $src;
    my $i = 0;
    while ($t[$i] eq $s[$i]) {
	$i++;
	shift @t;
	shift @s;
    }
    while ($i++ < $#s) { unshift @t, '..'; }
    $txt = join '/', @t;
    return $txt;
}

# Remove spurious names from restored directory
sub skimdir {
    my ($self, $dst, $pfx) = @_;
    my $flt = qr{^(\Q$pfx\E.*?)(?:/.*)?$}; # paths normalized
    opendir(DIR, $dst);
    my @f = grep !m%^\.\.?$%, readdir DIR;
    closedir DIR;
    my %ok = map {$_ => 1} grep s%$flt%$1%, keys %{$self->{ST_SRCMAP}};
    for (@f) {
	my $f = $pfx . $_;
	$self->{ST_SUB}->{exfiles}->{join('/', $dst, $_)}++ unless $ok{$f};
    }
}

sub vtree {
    my ($self, $dir) = @_;
    if (!exists $self->{ST_VT}->{$dir}) {
	my $vt = ClearCase::Argv->lsvtree({autochomp=>1}, [qw(-a -s -nco)]);
	# optimization: branch/0 of a directory is either empty or duplicate
	my @vt = reverse grep { m%[/\\](\d+)$% && $1>=1 } $vt->args($dir)->qx;
	$self->{ST_VT}->{$dir} = \@vt;
    }
    return $self->{ST_VT}->{$dir};
}

# Once a directory version was found, move it first in the list for next tries
sub raise_dver {
    my ($self, $i, $dir) = @_;
    return unless $i;
    my $vt = $self->{ST_VT}->{$dir};
    my $ver = splice @{$vt}, $i, 1;
    unshift @{$vt}, $ver;
}

# Reuse from removed elements, or create as view private, directories
sub reusemkdir {
    my ($self, $dref, $rref) = @_;
    my (%found, %dfound, %priv);
    my $snapview = $self->snapdest;
    my $ds = ClearCase::Argv->desc({stderr=>1},[qw(-s)]);
    my $dm = ClearCase::Argv->desc([qw(-fmt %m)]);
    my $rm = ClearCase::Argv->rm;
    my $lsco = ClearCase::Argv->lsco([qw(-s -d -cview)]);
    my $ln = ClearCase::Argv->ln;
    for my $dst (sort keys %{$dref}) {
	next if $dfound{$dst};
	my $reused;
	my($name, $dir) = fileparse($dst);
	if (!$priv{$dir}) {
	  if ($rref->{$dst}) {
	    $self->branchco(1, $dir) unless $lsco->args($dir)->qx;
	    $rm->args($dst)->system;
	  }
	  my $i = -1; #index in the vtree list
	VER: for (@{$self->vtree($dir)}) {
	    $i++;
	    my $dirext = "$_/$name";
	    # case-insensitive file test operator on Windows is a problem
	    if ($snapview ? $ds->args($dirext)->qx !~ /Error:/ : ecs($dirext)) {
	      next if $dm->args($dirext)->qx eq 'file element';
	      while (ccsymlink($dirext)) {
		$name = readcclink $dirext;
		$name =~ s/\@\@$//;
		$dirext = "$_/$name";
		# consider only relative, and local symlinks
		next VER if !ecs($dirext) ||
		  $dm->args($dirext)->qx eq 'file element';
	      }
	      $reused = 1;
	      $self->raise_dver($i, $dir);
	      $self->branchco(1, $dir) unless $lsco->args($dir)->qx;
	      $ln->args($dirext, $dst)->system;
	      # Need to reevaluate all the files under this dir
	      # The case of implicit dirs, is recorded as '.'
	      my $d = $dref->{$dst} eq '.'? '' : $dref->{$dst} . '/';
	      $self->skimdir($dst, $d) if $self->remove;
	      my $cmp = $self->no_cmp ? undef : $self->cmp_func;
	      my @keys = sort $d? grep m%^\Q$d\E%, keys %{$self->{ST_ADD}}
		: keys %{$self->{ST_ADD}};
	      for my $e (@keys) {
		my $edst = join '/', $self->dstbase, $e;
		my @intdir = split m%/%, $e;
		pop @intdir;
		if (@intdir) {
		  my $dd = $self->dstbase;
		  my $pf = '';
		  while (my $id = shift @intdir) {
		    $dd = join '/', $dd, $id;
		    $pf = $pf . $id . '/';
		    $self->skimdir($dd, $pf) if -d $dd && !$dfound{$dd}++;
		  }
		}
		# Problem: does it match the type under srcbase?
		if (-d $edst and !ccsymlink($edst)) { # We know it is empty
		  opendir(DIR, $edst);
		  my @f = grep !m%^\.\.?$%, readdir DIR;
		  closedir DIR;
		  if (@f) {
		    $self->branchco(1, $edst)
		      unless $lsco->args($edst)->qx;
		    $rm->args(map{join '/', $edst, $_} @f)->system;
		  }
		  $dfound{$edst}++; #Skip in this loop
		  next;
		}
		if (exists($self->{ST_ADD}->{$e}->{dst})) {
		  my $src = $self->{ST_ADD}->{$e}->{src};
		  my $dst = $self->{ST_ADD}->{$e}->{dst};
		  if (-e $dst) {
		    $self->{ST_MOD}->{$e} = $self->{ST_ADD}->{$e}
		      if $self->_needs_update($src, $dst, $cmp);
		    $found{$e}++; #Remove from the add list
		  }
		}
	      }
	      last;
	    }
	  }
	}
	if (!$reused) {
	    my $err;
	    mkpath($dst, {error => \$err, verbose => 0, mode => 0777});
	    $self->failm(join(': ', %{$err->[0]})) if $err and @{$err};
	    $priv{"${dst}/"}++;
	}
    }
    return %found;
}

# recursively record parent directories, and clashing objects to remove
sub recadd {
    my ($self, $src, $dst, $dir, $rm, $seen) = @_;
    my $dad = dirname($dst);
    return if $seen->{$dad}++ || (-d $dad && !ccsymlink($dad)); #exists, normal
    my $sdad = dirname($src);
    $self->recadd($sdad, $dad, $dir, $rm, $seen);
    $rm->{$dad}++ if -f $dad || ccsymlink($dad); #something clashing: remove
    $dir->{$dad} = $sdad;
}

sub add {
    my $self = shift;
    my $sbase = $self->srcbase;
    my $mbase = $self->_mkbase;
    my $ct = $self->clone_ct;
    return if ! $self->{ST_ADD};
    if ($self->reuse) { # First, reuse parent directories
	my (%dir, %rm, %dseen);
	# in the way if added in _mkbase as view private; ignore failures
	rmdir($_) for reverse sort @{$self->{ST_IMPLICIT_DIRS}};
	for my $d (sort keys %{$self->{ST_ADD}}) {
	    my $src = $self->{ST_ADD}->{$d}->{src};
	    my $dst = $self->{ST_ADD}->{$d}->{dst};
	    $dir{$dst} = $d if -d $src && !src_slink($src); # empty dir
	    $self->recadd($d, $dst, \%dir, \%rm, \%dseen);
	}
	my %found = $self->reusemkdir(\%dir, \%rm);
	delete $self->{ST_ADD}->{$_} for keys %found;
    }
    for (sort keys %{$self->{ST_ADD}}) {
	my $src = $self->{ST_ADD}->{$_}->{src};
	my $dst = $self->{ST_ADD}->{$_}->{dst};
	my $err;
	if (-d $src && ! src_slink($src)) { # Already checked in the reuse case
	    -e $dst || mkpath($dst, {error=>\$err, verbose=>0, mode=>0777});
	    $self->failm(join(': ', %{$err->[0]})) if $err and @{$err};
	} elsif (-e $src) {
	    my $dad = dirname($dst);
	    -d $dad || mkpath($dad, {error=>\$err, verbose=>0, mode=>0777});
	    $self->failm(join(': ', %{$err->[0]})) if $err and @{$err};
	    if (src_slink($src)) {
		open(SLINK, ">$dst$lext") || $self->failm("$dst$lext: $!");
		print SLINK $self->mkrellink($src), "\n";;
		close(SLINK);
	    } else {
		$self->{ST_CI_FROM}->{$_} = $self->{ST_ADD}->{$_}
					   if !exists($self->{ST_PRE}->{$dst});
	    }
	} elsif (src_slink($src)) { #Dangling symlink: import
	    open(SLINK, ">$dst$lext") || $self->failm("$dst$lext: $!");
	    print SLINK $self->mkrellink($src), "\n";;
	    close(SLINK);
	} else {
	    $ct->failm("$src: no such file or directory");
	}
    }
    my @candidates = sort $self->_lsprivate(1),
			  map { $_->{dst} } values %{$self->{ST_CI_FROM}};
    return if !@candidates;
    # We'll be separating the elements-to-be into files and directories.
    my(%files, @symlinks, %dirs);
    # If the parent directories of any of the candidates are
    # already versioned, we'll need to check them out unless
    # it's already been done.
    my @dads = sort map {dirname($_)} @candidates;
    my %lsd = map {split(/\s+Rule:\s+/, $_, 2)}
			$ct->argv('ls', [qw(-d -nxn -vis -vob)], @dads)->qx;
    for my $dad (keys %lsd) {
	# If already checked out, nothing to do.
	next if ! $lsd{$dad} || $lsd{$dad} =~ /CHECKEDOUT$/;
	# Now we know it's an element which needs to be checked out.
	$dad =~ s%\\%/%g if MSWIN;
	$dirs{$dad}++;
    }
    $self->branchco(1, keys %dirs) if keys %dirs;
    # Process candidate directories here, then do files below.
    my $mkdir = $self->clone_ct->mkdir({autofail=>0, autochomp=>0},
				                               $self->comment);
    for my $cand (@candidates) {
	if (! -d $cand) {
	    if ($cand =~ /$lext$/) {
		push(@symlinks, $cand);
	    } else {
		$files{$cand} = 1;
	    }
	    next;
	}
	# Now we know we're dealing with directories.  These cannot
	# exist at mkelem time so we move them aside, make
	# a versioned dir, then move all the files from the original
	# back into the new dir (still as view-private files).
	my $tmpdir = "$cand.$$.keep.d";
	if (!rename($cand, $tmpdir)) {
	    warn "$0: Error: can't rename '$cand' to '$tmpdir': $!\n";
	    $ct->fail;
	    next;
	}
	if ($mkdir->args($cand)->system) {
	    warn "Warning: unable to rename $tmpdir back to $cand!"
		                                unless rename($tmpdir, $cand);
	    $ct->fail;
	    next;
	}
	if (!opendir(DIR, $tmpdir)) {
	    warn "$0: Error: $tmpdir: $!";
	    $ct->fail;
	    next;
	}
	while (defined(my $i = readdir(DIR))) {
	    next if $i eq '.' || $i eq '..';
	    rename("$tmpdir/$i", "$cand/$i") || $self->failm("$cand/$i: $!");
	}
	closedir DIR;
	rmdir $tmpdir || warn "$0: Error: $tmpdir: $!";
    }

    # Optionally, reconstitute an old element of the same name if present.
    if ($self->reuse) {
	my $snapview = $self->snapdest;
	my $ds = ClearCase::Argv->desc({stderr=>1}, [qw(-s)]);
	my $dm = ClearCase::Argv->desc([qw(-fmt %m)]);
	my $ln = ClearCase::Argv->ln;
	my %reused;
	for my $elem (keys %files) {
	    my($name, $dir) = fileparse($elem);
	    my $i = -1;
	  DVER:
	    for (@{$self->vtree($dir)}) {
		$i++;
		my $dirext = "$_/$name@@";
		# case-insensitive file test operator on Windows is a problem
		if ($snapview ? $ds->args($dirext)->qx !~ /Error:/ :
							    ecs("$_/$name")) {
		    next if $dm->args("$_/$name")->qx =~ /^directory /;
		    while (ccsymlink("$_/$name")) {
		        $name = readcclink "$_/$name";
			$name =~ s/\@\@$//;
			next DVER if !ecs("$_/$name") ||
			            $dm->args("$_/$name")->qx =~ /^directory /;
		    }
		    $reused{$elem} = 1;
		    delete $files{$elem};
		    unlink($elem);
		    $ln->args("$_/$name", $elem)->system;
		    $self->raise_dver($i, $dir);
		    last;
		}
	    }
	}
	# If any elements were "reconstituted", they must be taken off the
	# list of elems to be checked in explicitly, since 'ct ln' is
	# just a directory op.
	my %xkeys;
	if (!$self->no_cr && %reused) {
	    for (keys %{$self->{ST_CI_FROM}}) {
		if (exists($self->{ST_CI_FROM}->{$_})
			&& exists($self->{ST_CI_FROM}->{$_}->{dst})
			&& exists($reused{$self->{ST_CI_FROM}->{$_}->{dst}})) {
		    $xkeys{$_} = 1;
		}
	    }
	    for (keys %xkeys) {
		delete $self->{ST_CI_FROM}->{$_};
	    }
	}
	# Also, reconstituted elements may now be candidates for
	# modification. Re-analyze the status for these. If any of
	# them differ from their counterparts in the src area, copy
	# them from the ADD list to the MOD list.
	my $comparator = $self->no_cmp ? undef : $self->cmp_func;
	for my $elem (keys %{$self->{ST_ADD}}) {
	    if (exists($reused{$self->{ST_ADD}->{$elem}->{dst}})) {
		my $src = $self->{ST_ADD}->{$elem}->{src};
		my $dst = $self->{ST_ADD}->{$elem}->{dst};
		if ($self->_needs_update($src, $dst, $comparator)) {
		    $self->{ST_MOD}->{$elem} = $self->{ST_ADD}->{$elem};
		}
	    }
	}
    }
    for (sort keys %{$self->{ST_CI_FROM}}) {
	my $dst = $self->{ST_CI_FROM}->{$_}->{dst};
	if ($files{$dst}) {
	    my $src = $self->{ST_CI_FROM}->{$_}->{src};
	    copy($src, $dst) || $ct->failm("$_: $!");
	    utime(time(), (stat $src)[9], $dst) ||
	                                    warn "Warning: $dst: touch failed";
	}
    }
    # Now do the files in one fell swoop.
    $ct->mkelem($self->comment, sort keys %files)->system if %files;

    # Deal with symlinks.
    for my $symlink (@symlinks) {
	(my $lnk = $symlink) =~ s/$lext$//;
	if (!open(SLINK, $symlink)) {
	    warn "$symlink: $!";
	    next;
	}
	chomp(my $txt = );
	close SLINK;
	unlink $symlink;
	$ct->ln(['-s'], $txt, $lnk)->system;
    }
}

# Tried to use Cwd::abs_path, but it behaves differently on Cygwin and UNIX
sub absdst {
    my ($self, $dir, $f) = @_;
    if ($f =~ /^\./) {
	my $sep = qr{[/\\]};
	my @d = split $sep, $dir;
	while ($f =~ s/^(\.\.?$sep)//) {
	    pop @d if $1 =~ /^\.{2}/;
	}
	$dir = join '/', @d;
    }
    return File::Spec->catfile($dir, $f);
}

sub modify {
    my $self = shift;
    return if !keys %{$self->{ST_MOD}};
    my(%files, %symlinks);
    for (keys %{$self->{ST_MOD}}) {
	if (src_slink($self->{ST_MOD}->{$_}->{src})) {
	    $symlinks{$_}++;
	} else {
	    $files{$_}++;
	}
    }
    my $rm = $self->clone_ct('rmname');
    my $ln = $self->clone_ct('ln');
    $ln->opts('-s', $ln->opts);
    my $lsco = ClearCase::Argv->lsco([qw(-s -d -cview)]);
    my $comparator = $self->no_cmp ? undef : $self->cmp_func;
    if (keys %files) {
	my (@toco, @del);
	for my $key (sort keys %files) {
	    my $src = $self->{ST_MOD}->{$key}->{src};
	    my $dst = $self->{ST_MOD}->{$key}->{dst};
	    my $new;
	    if (ccsymlink($dst)) {
	        # The source is a file, but the destination is a symlink: look
	        # (recursively) at what this one points to, and link in this
	        # file.
	        # Build up the path of the destination, in such a way that it
	        # may be found, or not, in the hash.
		my $dangling;
		my $sep = qr%[/\\]%;
		my $dst1 = $dst;
	        while (ccsymlink($dst1)) {
		    my $tgt = readcclink $dst1;
		    my $dir = dirname $dst1;
		    $tgt = $self->absdst($dir, $tgt) unless $tgt =~ m%^[/\\]%;
		    $tgt =~ s%\\%/%g if MSWIN;
		    if (-e $tgt) {
			$dst1 = $tgt;
		    } else {
			$dangling = 1;
			last;
		    }
		}
		my $dir = dirname($dst);
		$self->branchco(1, $dir) unless $lsco->args($dir)->qx;
		$self->clone_ct->rm($dst)->system; #remove the first symlink
		if ($dangling || !$self->{ST_SUB}->{exfiles}->{$dst1}) {
		    if (!copy($src, $dst)) {
			warn "$0: Error: $dst: $!\n";
			$rm->fail;
		    }
		    utime(time(), (stat $src)[9], $dst) ||
		      warn "Warning: $dst: touch failed";
		    $self->clone_ct->mkelem($self->comment, $dst)->system;
		    $new = 1;
		    delete $self->{ST_MOD}->{$key};
		    push @del, $key;
		} else {
		    my $dir1 = dirname($dst1);
		    $self->branchco(1, $dir1)
		              unless ($dir eq $dir1) || $lsco->args($dir1)->qx;
		    $self->clone_ct->mv($dst1, $dst)->system;
		    delete $self->{ST_SUB}->{exfiles}->{$dst1}; #done already
		    if (!$self->_needs_update($src, $dst, $comparator)) {
			delete $self->{ST_MOD}->{$key};
			push @del, $key;
		    }
		}
	    }
	    push(@toco, $dst) unless exists($self->{ST_PRE}->{$dst}) || $new;
	}
	$self->branchco(0, @toco) if @toco;
	delete @files{@del};
	for (sort keys %files) {
	    my $src = $self->{ST_MOD}->{$_}->{src};
	    my $dst = $self->{ST_MOD}->{$_}->{dst};
	    next if exists($self->{ST_PRE}->{$dst});
	    if ($self->no_cr) {
		if (!copy($src, $dst)) {
		    warn "$0: Error: $dst: $!\n";
		    $rm->fail;
		    next;
		}
		utime(time(), (stat $src)[9], $dst) ||
				            warn "Warning: $dst: touch failed";
	    } else {
		$self->{ST_CI_FROM}->{$_} = $self->{ST_MOD}->{$_};
	    }
	}
    }
    if (keys %symlinks) {
	my %checkedout = map {$_ => 1} $self->_lsco;
	for (sort keys %symlinks) {
	    my $txt = $self->mkrellink($self->{ST_MOD}->{$_}->{src});
	    my $lnk = $self->{ST_MOD}->{$_}->{dst};
	    my $dad = dirname($lnk);
	    if (!$checkedout{$dad}) {
		$checkedout{$dad} = 1 if ! $self->branchco(1, $dad);
	    }
	    if (!$rm->args($lnk)->system) {
	        my @fil = grep /^\Q$lnk\E/, keys %{$self->{ST_SUB}->{exfiles}};
	        delete @{$self->{ST_SUB}->{exfiles}}{@fil};
		delete $self->{ST_SUB}->{dirs}{$lnk};
	    }
	    $ln->args($txt, $lnk)->system;
	}
    }
}

sub subtract {
    my $self = shift;
    return unless $self->{ST_SUB};
    my $ct = $self->clone_ct;
    my %co = map {$_ => 1} $self->_lsco;
    my $exnames = $self->{ST_SUB}->{exfiles}; # Entries to remove
    my (%dir, %keep); # Directories respectively to inspect, and to keep
    $dir{dirname($_)}++ for keys %{$exnames};
    $dir{$_}++ for keys %{$self->{ST_SUB}->{dirs}}; # Existed originally
    my $dbase = $self->dstbase;
    for my $d (sort {$b cmp $a} keys %dir) {
	next if $keep{$d};
	my ($k) = ($d =~ m%^\Q$dbase\E/(.*)$%);
	if ($k and $self->{ST_SRCMAP}->{$k}) {
	    delete $exnames->{$d};
	    my $dad = $d;
	    $keep{$dad}++ while $dad = dirname($dad) and $dad gt $dbase;
	    next;
	}
	if (opendir(DIR, $d)) {
	    my @entries = grep !/^\.\.?$/, readdir DIR;
	    closedir(DIR);
	    map { $_ = join('/', $d, $_) } @entries;
	    if (grep { !$exnames->{$_} and $ct->ls(['-s'], $_)->qx !~ /\@$/}
		  @entries) { # Something not to delete--some version selected
		my $dad = $d;
		$keep{$dad}++ while $dad = dirname($dad) and $dad gt $dbase;
	    } else {
		if (@entries) {
		    my @co = grep {$co{$_}} @entries; # Checkin before removing
		    $ct->ci($self->comment, @co)->system if @co;
		    delete @$exnames{@entries}; # Remove the contents
		}
		$exnames->{$d}++; # Add the container
	    }
	}
    }
    delete @$exnames{keys %keep};
    my @exnames = keys %{$exnames};
    for my $dad (map {dirname($_)} @exnames) {
	$self->branchco(1, $dad) unless $co{$dad}++;
    }
    # Force because of possible checkouts in other views. Fail for unreachable
    $ct->rm([@{$self->comment}, '-f'], @exnames)->system if @exnames;
}

sub label {
    my $self = shift;
    my $lbtype = shift || $self->lbtype;
    return unless $lbtype;
    my $dbase = $self->dstbase;
    my $ct = $self->clone_ct({autochomp=>0});
    my $ctq = $self->clone_ct({stdout=>0});
    my $ctbool = $self->clone_ct({autofail=>0, stdout=>0, stderr=>0});
    my $dvob = $self->dstvob;
    my $locked;
    if ($ctbool->lstype(['-s'], "lbtype:$lbtype\@$dvob")->system) {
	$ct->mklbtype($self->comment, "lbtype:$lbtype\@$dvob")->system;
    } elsif (!$self->inclb) {
	$locked = $ct->lslock(['-s'], "lbtype:$lbtype\@$dvob")->qx;
	$ct->unlock("lbtype:$lbtype\@$dvob")->system if $locked;
    }
    # Allow for labelling errors, in case of hard links: only the link
    # recorded can be labelled, the other being seen as 'removed'
    if ($self->label_mods || $self->inclb) {
	my @mods = $self->_lsco;
	push @mods, @{$self->{ST_LBL}} if $self->{ST_LBL};
	if (@mods) {
	    $ctbool->mklabel([qw(-nc -rep), $self->inclb], @mods)->system
	                                                      if $self->inclb;
	    $ctbool->mklabel([qw(-nc -rep), $lbtype], @mods)->system;
	}
    } else {
	my $lbl = $self->lblver;
        if ($lbl) {
	    my $ct = $self->clone_ct({autochomp=>1, autofail=>0, stderr=>0});
	    my @rv = grep{ s/^(.*?)(?:@@(.*))/$1/ &&
			     ($2 =~ /CHECKEDOUT$/ || !-r "$_\@\@/$lbl") }
	      $ct->ls([qw(-r -vob -s)], $dbase)->qx,
	      $ct->ls([qw(-d -vob -s)], $dbase)->qx;
	    $ctbool->mklabel([qw(-nc -rep), $lbtype], $dbase, @rv)->system;
        } else {
	    $ctbool->mklabel([qw(-nc -rep -rec), $lbtype], $dbase)->system;
	}
	# Possibly move the label back to the right versions
	$ctbool->mklabel([qw(-nc -rep), $lbtype], @{$self->{ST_LBL}})->system
	                                                   if $self->{ST_LBL};
	# Last, label the ancestors of the destination back to the vob tag.
	my($dad, @ancestors);
	my $min = length($self->normalize($dvob));
	for ($dad = dirname($dbase);
			         length($dad) >= $min; $dad = dirname($dad)) {
	    push(@ancestors, $dad);
	}
	$ctq->mklabel([qw(-rep -nc), $lbtype], @ancestors)->system
								if @ancestors;
    }
    $self->clone_ct->lock("lbtype:$lbtype\@$dbase")->system if $locked;
}

sub get_addhash {
    my $self = shift;
    if ($self->{ST_ADD}) {
	return
	    map { $self->{ST_ADD}->{$_}->{src}, $self->{ST_ADD}->{$_}->{dst} }
		keys %{$self->{ST_ADD}};
    } else {
	return ();
    }
}

sub get_modhash {
    my $self = shift;
    if ($self->{ST_MOD}) {
	return
	    map { $self->{ST_MOD}->{$_}->{src}, $self->{ST_MOD}->{$_}->{dst} }
		keys %{$self->{ST_MOD}};
    } else {
	return ();
    }
}

sub get_sublist {
    my $self = shift;
    if ($self->{ST_SUB}) {
	return sort keys %{$self->{ST_SUB}->{exfiles}};
    } else {
	return ();
    }
}

sub checkin {
    my $self = shift;
    my $mbase = $self->_mkbase;
    my $dad = dirname($mbase);
    my @ptime = qw(-pti) unless $self->ctime;
    my @cmnt = @{$self->comment};
    my $ct = $self->clone_ct({autochomp=>0});
    # If special eltypes are registered, chtype them here.
    if (my %emap = $self->eltypemap) {
	for my $re (keys %emap) {
	    my @chtypes = grep {/$re/} map {$self->{ST_ADD}->{$_}->{dst}}
				       keys %{$self->{ST_ADD}};
	    next unless @chtypes;
	    $ct->chtype([@cmnt, '-f', $emap{$re}], @chtypes)->system;
	}
    }
    # Do one-by-one ci's with -from (to preserve CR's) unless
    # otherwise requested.
    if (! $self->no_cr) {
	for (keys %{$self->{ST_CI_FROM}}) {
	    my $src = $self->{ST_CI_FROM}->{$_}->{src};
	    my $dst = $self->{ST_CI_FROM}->{$_}->{dst};
	    $ct->ci([@ptime, @cmnt, qw(-ide -rm -from), $src], $dst)->system;
	}
	delete @{$self->{ST_MOD}}{keys %{$self->{ST_CI_FROM}}};
    }
    # Check-in first the files modified under the recorded names,
    # in case of hardlinks, since checking the other link first
    # in a pair would fail.
    my @mods;
    push @mods, $self->{ST_MOD}->{$_}->{dst} for
       grep {!ccsymlink($self->{ST_MOD}->{$_}->{dst})} keys %{$self->{ST_MOD}};
    $ct->ci([@cmnt, '-ide', @ptime], sort @mods)->system if @mods;
    # Check in anything not handled above.
    my %checkedout = map {$_ => 1} $self->_lsco;
    my @todo = grep {m%^\Q$mbase%} keys %checkedout;
    @todo = grep {!exists($self->{ST_PRE}->{$_})} @todo if $self->ignore_co;
    unshift(@todo, $dad) if $checkedout{$dad};
    # Sort reverse in case the checked in versions are not selected by the view
    $ct->argv('ci', [@cmnt, '-ide', @ptime], sort {$b cmp $a} @todo)->system
                                                                      if @todo;
    # Fix the protections of the target files if requested. Unix files
    # get careful consideration of bitmasks etc; Windows files just get
    # promoted to a+x if their extension looks executable.
    if ($self->protect) {
	if (MSWIN) {
	    my @exes;
	    for (keys %{$self->{ST_ADD}}) {
		next unless m%\.(bat|cmd|exe|dll|com|cgi|.?sh|pl)$%i;
		push(@exes, $self->{ST_ADD}->{$_}->{dst});
	    }
	    $ct->argv('protect', [qw(-chmod a+x)], @exes)->system if @exes;
	} else {
	    my %perms;
	    for (keys %{$self->{ST_ADD}}) {
		my $src = $self->{ST_ADD}->{$_}->{src};
		my $dst = $self->{ST_ADD}->{$_}->{dst};
		my $src_mode = (stat $src)[2];
		my $dst_mode = (stat $dst)[2];
		# 07551 represents the only bits that matter to clearcase
		if (($src_mode & 07551) ne ($dst_mode & 07551) &&
			$src !~ m%\.(?:p|html?|gif|mak|rc|ini|java|
				    c|cpp|cxx|h|bmp|ico)$|akefile%x) {
		    my $sym = sprintf("%o", ($src_mode & 07775) | 0444);
		    push(@${$perms{$sym}}, $dst);
		}
	    }
	    for (keys %{$self->{ST_MOD}}) {
		my $src = $self->{ST_MOD}->{$_}->{src};
		my $dst = $self->{ST_MOD}->{$_}->{dst};
		my $src_mode = (stat $src)[2];
		my $dst_mode = (stat $dst)[2];
		# 07551 represents the only bits that matter to clearcase
		if (($src_mode & 07551) ne ($dst_mode & 07551) &&
			$src !~ m%\.(?:p|html?|gif|mak|rc|ini|java|
				    c|cpp|cxx|h|bmp|ico)$|akefile%x) {
		    my $sym = sprintf("%o", ($src_mode & 07775) | 0444);
		    push(@${$perms{$sym}}, $dst);
		}
	    }
	    for (keys %perms) {
		$ct->argv('protect', ['-chmod', $_], @${$perms{$_}})->system;
	    }
	}
    }
}

sub cleanup {
    my $self = shift;
    my $mbase = $self->_mkbase;
    my $dad = dirname($mbase);
    my $ct = $self->clone_ct({autofail=>0});
    my @vp = $self->_lsprivate(1);
    for (sort {$b cmp $a} @vp) {
	if (-d $_) {
	    rmdir $_ || warn "$0: Error: unable to remove $_\n";
	} else {
	    unlink $_ || warn "$0: Error: unable to remove $_\n";
	}
    }
    my %checkedout = map {$_ => 1} $self->_lsco;
    my @todo = grep {m%^\Q$mbase%} keys %checkedout;
    @todo = grep {!exists($self->{ST_PRE}->{$_})} @todo
				    if $self->ignore_co || $self->overwrite_co;
    unshift(@todo, $dad) if $checkedout{$dad};
    if ($self->{branchoffroot}) {
	for (sort {$b cmp $a} @todo) {
	    my $b = $ct->ls([qw(-s -d)], $_)->qx;
	    $ct->unco([qw(-rm)], $_)->system;
	    if ($b =~ s%^(.*)[\\/]CHECKEDOUT$%$1%) {
		opendir BR, $b or next;
		my @f = grep !/^(\.\.?|0|LATEST)$/, readdir BR;
		closedir BR;
		$ct->rmbranch([qw(-f)], $b)->system unless @f;
	    }
	}
    } else {
	$ct->unco([qw(-rm)], sort {$b cmp $a} @todo)->system if @todo;
    }
}

# Undo current work and exit. May be called from an exception handler.
sub fail {
    my $self = shift;
    my $rc = shift;
    $self->ct->autofail(0);	# avoid exception-handler loop
    $self->cleanup;
    exit(defined($rc) ? $rc : 2);
}

sub failm {
    my ($self, $msg, $rc) = @_;
    warn "$0: Error: $msg\n";
    $self->fail($rc);
}

sub version {
    my $self = shift;
    return $ClearCase::SyncTree::VERSION;
}

# Here 'ecs' means Exists Case Sensitive. We don't generally
# want the case-insensitive file test operators on Windows.
# The underlying problem is that cleartool is always case
# sensitive. I.e. you can mkelem 'Foo' and then open 'foo'
# if you have the right MVFS settings, but you cannot check
# out or describe 'foo', only 'Foo'.
# This could lead to other problems on Windows though, since you
# may create evil twins if you subtract an old name and
# then add it under a name which differs only by case.  But at
# least that does work, whereas trying to checkout a path
# with the wrong case does not work at all.  Let the evil twin
# trigger handle the evil twin scenario.
sub ecs {
    my $file = shift;
    my $rc = 0;
    if (MSWIN || CYGWIN) {
	if (opendir DIR, dirname($file)) {
	    my $match = basename($file);
	    # Faster than for/last when not found!
	    $rc = 1 if grep {$_ eq $match} readdir DIR;
	    closedir DIR;
	}
    } else {
	$rc = -e $file;
    }
    return $rc;
}

1;

__END__