File Coverage

blib/lib/ClearCase/Wrapper/MGi.pm

Criterion	Covered	Total	%
statement	39	377	10.3
branch	1	188	0.5
condition	0	85	0.0
subroutine	13	37	35.1
pod			n/a
total	53	687	7.7

package ClearCase::Wrapper::MGi;

$VERSION = '1.00';

use warnings;
use strict;
use constant CYGWIN => $^O =~ /cygwin/i ? 1 : 0;
use vars qw($CT $EQHL $PRHL $STHL $FCHL %Xfer $Benchstart);
use File::Find;
($EQHL, $PRHL, $STHL, $FCHL) = qw(EqInc PrevInc StBr FullCpy);

# Note: only wrapper supported functionality--possible fallback to cleartool
sub _Wrap {
  local @ARGV = @_;
  ClearCase::Wrapper::Extension($ARGV[0]);
  no strict 'refs';
  my $rc = eval { "ClearCase::Wrapper::$ARGV[0]"->(@ARGV) };
  if ($@) {
    chomp $@;		 #One extra newline to avoid dumping the stack
    if ($@ =~ m%^\d+$%) {
      $rc = $@;
    } elsif ($@) {
      print STDERR "$@\n";
      $rc = 1;
    } else {
      $rc = 0;
    }
  } else {
    $rc = ClearCase::Argv->new(@ARGV)->system unless $rc; # fallback!
  }
  return $rc;			# Completed, successful or not
}
## Internal service routines, undocumented.
sub _Compareincs {
  my ($t1, $t2) = @_;
  my ($p1, $M1, $m1, $s1) = pfxmajminsfx($t1);
  my ($p2, $M2, $m2, $s2) = pfxmajminsfx($t2);
  if (!(defined($p1) and defined($p2) and ($p1 eq $p2) and ($s1 eq $s2))) {
    warn Msg('W', "$t1 and $t2 not comparable\n");
    return 1;
  }
  return ($M1 <=> $M2 or (defined($m1) and defined($m2) and $m1 <=> $m2));
}
sub _Samebranch {		# same branch
  my ($cur, $prd) = @_;
  $cur =~ s:/\d+$:/:; # Treat CHECKEDOUT as other branch
  $prd =~ s:/\d+$:/:;
  return $cur eq $prd;
}
sub _Sosbranch {		# same or sub- branch
  my ($cur, $prd) = @_;
  $cur =~ s:/\d+$:/:;
  $prd =~ s:/\d+$:/:;
  return $cur =~ /^\Q$prd\E/;
}
sub _Printoffspring {
  no warnings 'recursion';
  my ($id, $gen, $opt, $ind, $seen, $out) = @_;
  my $top = $out? 0 : ($out = [], $seen = {}, 1);
  if ($seen->{$id}++) {
    push @{$out}, sprintf("%${ind}s\[alternative: ${id}\]", '')
      unless $opt->{short} or $opt->{fmt};
    return;
  }
  my @p = @{ $gen->{$id}{parents} || [] };
  my @c = @{ $gen->{$id}{children} || [] };
  my $l = $gen->{$id}{labels} || '';
  my ($s, $u) = ([], []);
  push @{$seen->{$_}? $s : $u}, $_ for @p;
  if (@{$u} and !($opt->{short} or $opt->{fmt})) {
    my $pprinted = 0;
    map{$pprinted++ if $gen->{$_}{printed}} @{$s};
    push @{$out}, ' 'x($ind-1) . '[contributor' . (@{$u}>1? 's' : '') . ': '
      . join(' ', @{$u}) . ']' if $pprinted and $ind;
  }
  my $yes = ($opt->{all} or (@c != 1) or (@{$s} != 1)
	       or !_Samebranch($id, $s->[0]) or !_Sosbranch($c[0], $id));
  if ($l or $yes) {
    if ($opt->{short}) {
      if ($yes) {
	# the arg (0-indented) is being printed with its parents
	push @{$out}, sprintf("%${ind}s${id}", '') if $ind;
	$gen->{$id}{printed}++;
	$ind++; # increase only if printed
      }
    } else {
      if ($ind) {
	my $data = $opt->{fmt}? $l : "$id$l";
	$data =~ s/\%/\%\%/g;	#Escape possible percent signs
	push @{$out}, sprintf("%${ind}s$data", '');
      }
      $gen->{$id}{printed}++;
      $ind++;
    }
  }
  _Printoffspring($_, $gen, $opt, $ind, $seen, $out) for @c;
  map{print "$_\n"} reverse @{$out} if $top; # only once
}
sub _Printparents {
  no warnings 'recursion';
  my ($id, $gen, $seen, $opt, $ind) = @_;
  if ($seen->{$id}++) {
    printf("%${ind}s\[alternative: ${id}\]\n", '')
      unless $opt->{short} or $opt->{fmt};
    return;
  }
  my @p = @{ $gen->{$id}{parents} || [] };
  my @c = @{ $gen->{$id}{children} || [] };
  my $l = $gen->{$id}{labels} || '';
  my (@s, @u) = ();
  foreach my $c (@c) {
    if ($seen->{$c}) {
      push @s, $c;
    } else {
      push @u, $c;
    }
  }
  if (scalar(@u) and !($opt->{short} or $opt->{fmt})) {
    my $cprinted = 0;
    for my $c (@s) {
      $cprinted++ if $gen->{$c}{printed};
    }
    if (($cprinted or !$ind) and !$opt->{offspring}) {
      my $plural = @u>1? 's' : '';
      if ($ind == 0) {
	print "\[offspring: ";
      } else {
	my $pind = $ind - 1;
	print ' 'x$pind, "\[sibling${plural}: ";
      }
      print join(' ', @u), "\]\n";
    }
  }
  my $yes = ($opt->{all} or (scalar(@p) != 1) or (scalar(@s) != 1)
	       or !_Samebranch($id, $s[0]) or !_Sosbranch($id, $p[0]));
  if ($l or $yes) {
    if ($opt->{short}) {
      if ($yes) {
	printf("%${ind}s${id}\n", '');
	$gen->{$id}{printed}++;
	$ind++;
      }
    } else {
      my $data = $opt->{fmt}? $l : "$id$l";
      $data =~ s/\%/\%\%/g; #Escape possible percent signs
      printf "%${ind}s$data\n", '';
      $gen->{$id}{printed}++;
      $ind++;
    }
  }
  return if (defined($opt->{depth})) and ($opt->{depth} < $ind);
  foreach my $p (@p) {
    if ($gen->{$id}{depth} < $gen->{$p}{depth}) {
      _Printparents($p, $gen, $seen, $opt, $ind);
    } elsif (!($opt->{short} or $opt->{fmt})) {
      printf("%${ind}s\[alternative: ${p}\]\n", '');
    }
  }
}
sub _Findpredinstack {
  my ($g, $stack) = @_;
  while ($$stack[-1]) {
    return $$stack[-1] if _Sosbranch($g, $$stack[-1]);
    pop @{$stack};
  }
  return 0;
}
sub _Setdepths {
  no warnings 'recursion';
  my ($id, $dep, $gen) = @_;
  if (defined($gen->{$id}{depth})) {
    if ($gen->{$id}{depth} > $dep) {
      $gen->{$id}{depth} = $dep;
    } else {
      return;
    }
  } else {
    $gen->{$id}{depth} = $dep;
  }
  my @p = defined($gen->{$id}{parents}) ? @{ $gen->{$id}{parents} } : ();
  foreach my $p (@p) {
    _Setdepths($p, $gen->{$id}{depth} + 1, $gen);
  }
}
sub _Checkcs {
  use File::Basename;
  use Cwd;
  my ($v) = @_;
  $v =~ s/^(.*?)\@\@.*$/$1/;
  my $dest = dirname($v);
  $dest .= '/' unless $dest =~ m%/$%;
  my $pwd = getcwd();
  $CT->cd($dest)->system if $dest;
  my @cs = grep /^\#\#:BranchOff: *root/, $CT->argv('catcs')->qx;
  $CT->cd($pwd)->system if $dest;
  return scalar @cs;
}
sub _Pbrtype {
  my ($pbrt, $bt) = @_;
  if (!defined($pbrt->{$bt})) {
    my $tc = $CT->argv('des', qw(-fmt %[type_constraint]p),
		       "brtype:$bt")->qx;
    $pbrt->{$bt} = ($tc =~ /one version per branch/);
  }
  return $pbrt->{$bt};
}
sub _Parsevtree {
  my ($ele, $obs, $sel) = @_;
  $CT->lsvtree;
  my @opt = qw(-merge -all);
  push @opt, '-obs' if $obs;
  $CT->opts(@opt);
  my @vt = $CT->args($ele)->qx;
  my $v0 = $vt[1];
  @vt = grep m%(^$sel|[\\/]([1-9]\d*|CHECKEDOUT))( .*)?$%, @vt;
  map { s%\\%/%g } @vt, $v0;
  my (%gen, @root);
  $gen{$v0}{labels} = $1 if $v0 =~ s%/0( \(.*)$%/0%;
  my @stack = ();
  foreach my $g (@vt) {
    $g =~ s%^(.*/CHECKEDOUT) view ".*"(.*)$%$1$2%;
    if ($g =~ m%^(.*)( \(.*\))$%) {
      $g = $1;
      $gen{$g}{labels} = $2;
    }
    if ($g =~ /^  -> (.*)$/) {
      my $v = $1;
      my $n = "$ele\@\@$v";
      push @{ $gen{$stack[-1]}{children} }, $n;
      push @{ $gen{$n}{parents} }, $stack[-1];
      next;
    }
    if (_Findpredinstack($g, \@stack)) {
      push @{ $gen{$g}{parents} }, $stack[-1];
      push @{ $gen{$stack[-1]}{children} }, $g;
    } elsif ($g ne $v0 and !$gen{$g}{parents}) {
      push @root, $g; #come back later
    }
    push @stack, $g;
  }
  for (@root) {
    next if $gen{$_}{parents};
    push @{ $gen{$_}{parents} }, $v0;
    push @{ $gen{$v0}{children} }, $_;
  }
  return \%gen;
}
sub _Parents {
  my ($ver, $ele) = @_;
  # v0 is $ele@@/main/0, whatever the actual name of 'main' for $ele
  # Only mention v0 as last recourse, if there is nothing else
  my $pred = $CT->des([qw(-fmt %En@@%PVn)], $ver)->qx;
  return if $pred eq "$ele@@";	# Only v0 has no parent
  my @ret = grep s/^<- .*?(@.*)/$ele$1/,
    $CT->des([qw(-s -ahl Merge)], $ver)->qx;
  $pred = $CT->des([qw(-fmt %En@@%PVn)], $pred)->qx
    while $pred =~ m%\@[^@]*[/\\][^@]+[/\\][^@]+[/\\]0$%;
  s%\\%/%g for grep $_, $pred, @ret; # Windows...
  push @ret, $pred unless $pred =~ m%/0$% and @ret;
  return @ret
}
sub _Offspring {
  my ($ele, $sel, $gen) = @_;
  my @offsp = grep s/^-> .*?(@.*)/$ele$1/,
    $CT->des([qw(-s -ahl Merge)], $sel)->qx;
  my ($br, $nr) = ($sel =~ m%^(.*)/(\d+)$%); # $sel is normalized
  if ($br and opendir BR, $br) {	     # Skip for CHECKEDOUT
    my @f = grep !/^\.\.?/, readdir BR;
    closedir BR;
    my @n = sort {$a <=> $b} grep { /^\d+$/ and $_ > $nr } @f;
    push @offsp, join('/', $br, $n[0]) if @n;
    my $sil = new ClearCase::Argv({autochomp=>1, stderr=>0});
    push @offsp, grep {$sil->des([qw(-fmt %Pn)], $_)->qx eq $sel}
      join('/', $br, $_, '0')
      for grep { /^\D/ and $sil->des(['-s'], "brtype:$_")->qx } @f;
    push @offsp, join('/', $br, 'CHECKEDOUT')
      if $sil->lsco([qw(-fmt %En@@%PVn)], $ele)->qx eq $sel;
    my %chld = map{$_ => 1} @{ $gen->{$sel}{children} }; # no duplicates
    push @{ $gen->{$sel}{children} }, grep{!$chld{$_}} @offsp;
  }
}
sub _DesFmt {
  my ($fmt, $arg) = @_;
  my $ph = 'PlAcEhOlDeR';
  if ($fmt =~ s/\%\[(.*?)\](N?)l/$ph/) {
    my ($re, $ncom) = (qr($1), $2);
    $CT = new ClearCase::Argv({autochomp=>1}) unless $CT;
    my @lb = grep /$re/, split / /, $CT->des([qw(-fmt %Nl)], $arg)->qx;
    my $lb = $ncom? join(' ', @lb) : @lb? '(' . join(', ', @lb) . ')' : '';
    $fmt =~ s/$ph/$lb/;
  }
  return $CT->des(['-fmt', $fmt], $arg)->qx;
}
sub _DepthGen {
  my ($ele, $dep, $sel, $verbose, $fmt, $gen) = @_;
  $gen = {} unless $gen;
  _Offspring($ele, $sel, $gen) if $verbose;
  if ($dep--) {
    return if defined $gen->{$sel}{parents};
    my @p = _Parents($sel, $ele);
    @{ $gen->{$sel}{parents} } = @p;
    $gen->{$sel}{labels} = _DesFmt($fmt, $sel) if $fmt;
    push @{ $gen->{$_}{children} }, $sel for @p;
    _DepthGen($ele, $dep, $_, $verbose, $fmt, $gen) for @p;
  } elsif ($fmt) {
    $gen->{$sel}{labels} = _DesFmt($fmt, $sel);
  }
  return $gen;
}
sub _RecOff {
  my ($ele, $sel, $fmt, $gen, $seen) = @_;
  return if $seen->{$sel}++;
  ($gen->{$sel}{labels}) = grep /\S/, _DesFmt($fmt, $sel);
  my %par = map{$_ => 1} @{ $gen->{$sel}{parents} }; # no duplicates
  push @{ $gen->{$sel}{parents} }, grep{!$par{$_}} _Parents($sel, $ele);
  _Offspring($ele, $sel, $gen);
  _RecOff($ele, $_, $fmt, $gen, $seen) for @{ $gen->{$sel}{children} };
}
sub _RecGen {
  my ($ele, $sel, $opt) = @_;
  my $fmt = $opt->{fmt} || ' %l';
  my $gen = _DepthGen($ele, $opt->{depth}, $sel, !$opt->{short}, $fmt);
  if ($opt->{offspring}) {
    my $seen = {};
    _RecOff($ele, $sel, $fmt, $gen, $seen)
  }
  return $gen;
}
sub _Ensuretypes {
  my @typ = ($EQHL, $PRHL); # Default value
  @typ = @{shift @_} if ref $_[0] eq 'ARRAY';
  my @vob = @_;
  my %cmt = ($EQHL => q(Equivalent increment),
	     $PRHL => q(Previous increment in a type chain),
	     $FCHL => q(Full Copy of increment));
  my $silent = $CT->clone({stdout=>0, stderr=>0});
  my $die = $CT->clone({autofail=>1});
  for my $t (@typ) {
    for my $v (@vob) {
      my $t2 = "$t\@$v";
      $die->mkhltype([qw(-shared -c), $cmt{$t}], $t2)->system
	if $silent->des(['-s'], "hltype:$t2")->system;
    }
  }
}
sub _Pfxmajminsfx {
  my $t = shift;
  if ($t =~ /^([\w.-]+[-_])(\d+)(?:\.(\d+))?(\@.*)?$/) {
    my $min = ($3 or '');
    my $sfx = ($4 or '');
    return ($1, $2, $min, $sfx);
  } else {
    warn Msg(
      'W', "$t doesn't match the pattern expected for an incremental type\n");
  }
}
sub _Nextinc {
  my $inc = shift;
  my ($pfx, $maj, $min, $sfx) = _Pfxmajminsfx($inc);
  return '' unless $pfx and $maj;
  my $count = defined($min)? $maj . q(.) . ++$min : ++$maj;
  return $pfx . $count . $sfx;
}
sub _Findnext {		# on input, the type exists
  my $c = shift;
  my @int = grep { s/^<- lbtype:(.*)$/$1/ }
    $CT->argv(qw(des -s -ahl), $PRHL, "lbtype:$c")->qx;
  if (@int) {
    my @i = ();
    for (@int) {
      push @i, _Findnext($_);
    }
    return @i;
  } else {
    return ($c);
  }
}
sub _Findfreeinc {	   # on input, the values may or may not exist
  my ($nxt, %n) = shift;
  while (my ($k, $v) = each %{$nxt}) {
    while ($CT->des(['-s'], "lbtype:$v")->stderr(0)->qx) { #exists
      my @cand = sort _Compareincs _Findnext($v);
      $v = _Nextinc($cand[$#cand]);
    }
    $n{$k} = $v;
  }
  while (my ($k, $v) = each %n) { $$nxt{$k} = $v }
}
sub _Wanted {
  my $path = File::Spec->rel2abs($File::Find::name);
  $path =~ s%\\%/%g if $^O =~ /MSWin32|Windows_NT/i;
  if (-f $_ || -l $_) {
    if (-r _) {
      # Passed all tests, put it on the list.
      $Xfer{$path} = $path;
    } else {
      warn Msg('E', "permission denied: $path");
    }
  } elsif (-d _) {
    if ($_ eq 'lost+found') {
      $File::Find::prune = 1;
      return;
    }
    # Keep directories in the list only if they're empty.
    opendir(DIR, $_) || warn Msg('E', "$_: $!");
    my @entries = readdir DIR;
    closedir(DIR);
    $Xfer{$path} = $path if @entries == 2;
  } elsif (! -e _) {
    die Msg('E', "no such file or directory: $path");
  } else {
    warn Msg('E', "unsupported file type: $path");
  }
}
sub _Yesno {
  my ($cmd, $fn, $yn, $test, $errmsg) = @_;
  my $ret = 0;
  my @opts = $cmd->opts;
  for my $arg ($cmd->args) {
    $cmd->opts(@opts); #reset
    if ($test) {
      my $res = $test->($arg);
      if (!$res) {
	warn ($res or Msg('E', $errmsg . '"' . $arg . "\".\n"));
	next;
      } elsif ($res == -1) { # Skip interactive part
	$ret |= $fn->($cmd);
	next;
      }
    }
    printf $yn->{format}, $arg;
    my $ans = ; chomp $ans; $ans = lc($ans);
    $ans = $yn->{default} unless $ans;
    while ($ans !~ $yn->{valid}) {
      print $yn->{instruct};
      $ans = ; chomp $ans; $ans = lc($ans);
      $ans = $yn->{default} unless $ans;
    }
    if ($yn->{opt}->{$ans}) {
      $cmd->opts(@opts, $yn->{opt}->{$ans});
      $cmd->args($arg);
      $ret |= $fn->($cmd);
    } else {
      $ret = 1;
    }
  }
  exit $ret;
}
use AutoLoader 'AUTOLOAD';

#############################################################################
# Usage Message Extensions
#############################################################################
{
  local $^W = 0;
  no strict 'vars';

  my $z = $ARGV[0] || '';
  $checkin = "\n* [-dir|-rec|-all|-avobs] [-ok] [-diff [diff-opts]] [-revert]";
  $lsgenealogy = "$z [-short] [-all] [-fmt format] [-obsolete] [-depth d]"
    . "\n[-offspring] pname ...";
  $mkbrtype = "\n* [-archive]";
  $mklabel = "\n* [-up] [-force] [-over type [-all]]";
  $mklbtype = "\n* [-family] [-increment] [-archive] [-fullcopy type] \n"
    . "[-config cr [-exclude vobs]]";
  $rmtype = "\n* [-family] [-increment]";
  $setcs = "\n* [-clone view-tag] [-expand] [-sync|-needed]";
  $mkview = "\n* [-clone view-tag [-equiv lbtype,timestamp]]";
  $describe = "\n* [-par/ents ] [-fam/ily ]";
  $rollout = "$z [-force] [-c comment] -to baseline brtype|lbtype";
  $rollback = "$z [-force] [-c comment] -to increment";
  $archive = "$z [-c comment|-nc] brtype|lbtype ...";
  $annotate = "\n* [-line|-grep regexp]";
  $synctree = "$z -from sbase [-c comment] [-quiet] [-force] [-rollback]"
    . "\n[-summary] [-label type] [pname ...]";
}

#############################################################################
# Command Aliases
#############################################################################
*co             = *checkout;
*ci		= *checkin;
*des            = *describe;
*desc           = *describe;
*lsg		= *lsgenealogy;
*lsge		= *lsgenealogy;
*lsgen		= *lsgenealogy;
*unco           = *uncheckout;
*ro             = *rollout;
*rb             = *rollback;
*ar             = *archive;
*arc            = *archive;
*arch           = *archive;
*an             = *annotate;
*ann            = *annotate;
*anno           = *annotate;
*st             = *synctree;
*sy             = *synctree;
*syn            = *synctree;
*sync           = *synctree;

1;

__END__