view release on metacpan or  search on metacpan

SyncTree.pm  view on Meta::CPAN

    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;