view release on metacpan or  search on metacpan

SyncTree.pm  view on Meta::CPAN

}

# 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}) {