ClearCase::Wrapper::MGi - Support for an alternative to UCM.

package ClearCase::Wrapper::MGi;

$VERSION = '0.26';

use warnings;
use strict;
use vars qw($ct $eqhl $prhl $diat);
($eqhl, $prhl) = qw(EqInc PrevInc);

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));
}
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] [-obsolete] [-depth gen-depth] pname ...";
  $mkbrtype = "\n* [-archive]";
  $mklabel = "\n* [-up] [-force] [-over type [-all]]";
  $mklbtype = "\n* [-family] [-increment] [-archive]";
  $rmtype = "\n* [-family] [-increment]";
  $setcs = "\n* [-clone view-tag] [-expand] [-sync|-needed]";
  $mkview = "\n* [-clone view-tag [-equiv lbtype,timestamp]]";
  $describe = "\n* [-par/ents <n>] [-fam/ily <n>]";
}

#############################################################################
# Command Aliases
#############################################################################
*co             = *checkout;
*ci		= *checkin;
*des            = *describe;
*desc            = *describe;
*lsgen		= *lsgenealogy;
*unco           = *uncheckout;

1;

__END__

## Internal service routines, undocumented.
sub _Samebranch($$) {		# same branch
  my ($cur, $prd) = @_;
  $cur =~ s:/[0-9]+$:/:; # Treat CHECKEDOUT as other branch
  $prd =~ s:/[0-9]+$:/:;
  return ($cur eq $prd);
}
sub _Sosbranch($$) {		# same or sub- branch
  my ($cur, $prd) = @_;
  $cur =~ s:/[0-9]+$:/:;
  $prd =~ s:/[0-9]+$:/:;
  return ($cur =~ qr(^$prd));
}
sub _Printparents {
  no warnings 'recursion';
  my ($id, $gen, $seen, $ind) = @_;
  if ($$seen{$id}++) {
    printf("%${ind}s\[alternative path: ${id}\]\n", '')
      unless $opt{short};
    return;
  }
  my @p = defined($$gen{$id}{parents}) ? @{ $$gen{$id}{parents} } : ();
  my @c = defined($$gen{$id}{children}) ? @{ $$gen{$id}{children} } : ();
  my $l = defined($$gen{$id}{labels}) ? " $$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}) {
    my $cprinted = 0;
    for my $c (@s) {
      $cprinted++ if $$gen{$c}{printed};
    }
    if ($cprinted) {
      if ($ind == 0) {
	print "\[offsprings:";
      } else {
	my $pind = $ind - 1;
	printf("%${pind}s\[siblings:", '');
      }
      foreach (@u) {
	print " $_";
      }
      print "\]\n";
    }
  }
  my $yes = ($opt{all} or (scalar(@p) != 1) or (scalar(@s) != 1)
	       or !_Samebranch($id, $s[0]) or !_Sosbranch($p[0], $id));
  if ($l or $yes) {
    if ($opt{short}) {
      if ($yes) {
	printf("%${ind}s${id}\n", '');
	$$gen{$id}{printed}++;
	${ind}++;
      }
    } else {
      printf("%${ind}s${id}${l}\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, $ind);
    } else {
      printf("%${ind}s\[alternative path: ${p}\]\n", '')
	unless $opt{short};
    }
  }
}
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) = @_;
  $ct = $ct->clone();
  $v =~ s/^(.*?)\@\@.*$/$1/;
  my $dest = dirname($v);
  $dest = '' if $dest eq '.';
  my $pwd = getcwd();
  $ct->argv('cd', $dest)->system if $dest;
  my @cs = grep /^\#\#:BranchOff: *root/, $ct->argv('catcs')->qx;
  $ct->argv('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->argv('lsvtree');
  my @opt = qw(-merge -all);
  push @opt, '-obs' if $obs;
  $ct->opts(@opt);
  my @vt = grep m%(^$sel|[\\/]([1-9]\d*|CHECKEDOUT))( .*)?$%,
    $ct->args($ele)->qx;
  map { s%\\%/%g } @vt;
  my %gen = ();
  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;
    }
    push @stack, $g;
  }
  return %gen;
}
sub _Mkbco {
  my ($cmd, @cmt) = @_;
  my $rc = 0;
  my %pbrt = ();
  my $bt = $cmd->{bt};
  my @opts = $cmd->opts;
  if ($cmd->flag('nco')) { #mkbranch
    my @a = ($bt);
    push @a, $cmd->args;
    $cmd->args(@a);
    push @opts, @cmt;
    $cmd->opts(@opts);
    return $cmd->system;
  } elsif ($cmd->flag('branch')) { #co
    push @opts, @cmt;
    $cmd->opts(@opts);
    return $cmd->system;
  }
  die Msg('E', 'Element pathname required.') unless $cmd->args;
  foreach my $e ($cmd->args) {
    my $ver = $cmd->{ver};
    my $typ = $ct->argv(qw(des -fmt %m), $e)->qx;
    if ($typ !~ /(branch|version)$/) {
      warn Msg('W', "Not a vob object: $e");
      $rc = 1;
      next;
    }
    if ($ver) {
      $ver = "/$ver" unless $ver =~ m%^[\\/]%;
      $e =~ s%\@\@.*$%%;
      my $v = $e;
      $ver = "$v\@\@$ver";
    } elsif ($e =~ m%^(.*?)\@\@.*$%) {
      $ver = $e;
      $e = $1;
      $ver =~ s%[\\/]$%%;
      $ver .= '/LATEST' if $typ eq 'branch';
    }
    if (!$ver or !$bt) {
      my $sel = $ct->argv('ls', '-d', $e)->qx;
      if ($bt) {
	$ver = $1 if $sel =~ /^(.*?) +Rule/;
      } elsif ($sel =~ /^(.*?) +Rule:.*-mkbranch (.*?)\]?$/) {
	($ver, $bt) = ($ver? $ver : $1, $2);
      }
    }
    if ($bt and _Checkcs($e)) {
      my $main = ($ct->argv('lsvtree', $e)->qx)[0];
      $main =~ s%^[^@]*\@\@[\\/](.*)$%$1%;
      my $vob = $ct->argv('des', '-s', "vob:$e")->qx;
      my $re = _Pbrtype(\%pbrt, "$bt\@$vob") ?
	qr([\\/]${main}[\\/]$bt[\\/]\d+$) : qr([\\/]$bt[\\/]\d+$);
      if ($ver =~ m%$re%) {
	push @opts, @cmt, $e;
	$rc |= $ct->argv('co', @opts)->system;
      } else {
	my @mkbcopt = @cmt? @cmt : qw(-nc);
	if ($ct->argv('mkbranch', @mkbcopt, '-ver', "/$main/0", $bt, $e)
	      ->stderr(0)->system) {
	  $rc = 1;
	} else {
	  if ($ver !~ m%\@\@[\\/]${main}[\\/]0$%) {
	    my $lrc = $ct->argv('merge', '-to', $e, $ver)->stdout(0)->system;
	    unlink glob("$e.contrib*");
	    $rc |= $lrc;
	  }
	}
      }
    } else {
      my @args;
      push @args, @opts, @cmt;
      push @args, $bt if $bt;
      push @args, $e; # Ensure non empty array
      $rc |= $bt? $ct->argv('mkbranch', @args)->system
	: $ct->argv('co', @args)->system;
    }
  }
  return $rc;
}
sub _Ensuretypes($@) {
  my ($glb, @vob) = @_;
  my %cmt = ($eqhl => q(Equivalent increment),
	     $prhl => q(Previous increment in a type chain));
  my $silent = $ct->clone({stdout=>0, stderr=>0});
  my $die = $ct->clone({autofail=>1});
  my $gflg = $glb? '-glo' : '-ord';
  for my $t ($eqhl, $prhl) {
    for my $v (@vob) {
      my $t2 = "$t\@$v";
      $die->mkhltype([qw(-shared -c), $cmt{$t}, $gflg], $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->argv(qw(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 _PreCi {
  use strict;
  use warnings;
  my ($ci, @arg) = @_;
  my $lsco = ClearCase::Argv->lsco([qw(-cview -s -d)])->stderr(1);
  my $res = $lsco->args(@arg)->qx;
  if (!$res or $res =~ /^cleartool: Error/m) {
    warn Msg('E', 'Unable to find checked out version for '
	       . join(', ', @arg) . "\n");
    return 0;
  }
  my $opt = $ci->{opthashre};
  return 1 unless $opt->{diff} || $opt->{revert};
  my $elem = $arg[0]; #Only one because of -cqe
  my $diff = $ci->clone->prog('diff');
  $ct = $ci->clone;
  $ct->autochomp(1);
  my $ver = $ct->argv(qw(des -fmt %En@@%Vn), $elem)->qx;
  $ver =~ s%\\%/%g;
  my $bra = $1 if $ver =~ m%^(.*?)/(?:\d+|CHECKEDOUT)$%;
  my %gen = _Parsevtree($elem, 1, $ver);
  my $p = $gen{$ver}{'parents'};
  my ($brp) = grep { m%^$bra/\d+$% } @{$p};
  $diff->optsDIFF(q(-serial), $diff->optsDIFF);
  $diff->args($brp? $brp : $p->[0], $elem);
  # Without -diff we only care about return code
  $diff->stdout(0) unless $opt->{diff};
  # With -revert, suppress msgs from typemgrs that don't do diffs
  $diff->stderr(0) if $opt->{revert};
  if ($diff->system('DIFF')) {
    return 1;
  } else {
    if ($opt->{revert}) { # unco instead of checkin
      _Unco(ClearCase::Argv->unco(['-rm'], $elem));
      return 0;
    } else { # -diff
      warn Msg('E', q(By default, won't create version with )
		 . q(data identical to predecessor.));
      return 0;
    }
  }
}
sub _Preemptcmt { #return the comments apart: e.g. mklbtype needs discrimination
  use File::Temp qw(tempfile);
  my ($cmd, $fn, $tst) = @_; #parsed, 3 groups: cquery|cqeach nc c|cfile=s
  use warnings;
  use strict;
  my @opts = $cmd->opts;
  my ($ret, @mod, @copt) = 0;
  my ($cqf, $ncf, $cf) =
    ($cmd->flag('cquery'), $cmd->flag('nc'), $cmd->flag('c'));
  if (!$cqf and !$ncf and !$cf) {
    if (defined $ENV{_CLEARCASE_PROFILE}) { #ClearCase::Argv shift
      if (open PRF, "<$ENV{_CLEARCASE_PROFILE}") {
	while (<PRF>) {
	  if (/^\s*(.*?)\s+(-\w+)/) {
	    my ($op, $fg) = ($1, $2);
	    if (($op eq ($cmd->prog())[1]) or ($op eq '*')) {
	      if ($fg eq '-nc') {
		$ncf = 1;
	      } elsif ($fg eq '-cqe') {
		$cqf = 1;
		push @opts, '-cqe';
	      } elsif ($fg eq '-cq') {
		$cqf = 1;
		push @opts, '-cq';
	      }
	      last;
	    }
	  }
	}
	close PRF;
      }
    }
    if (!$cqf and !$ncf and !$cf) {
      my $re =
	qr/c[io]|check(in|out)|mk(dir|elem|(at|br|el|hl|lb|tr)type|pool|vob)/;
      if (($cmd->prog())[1] =~ /^($re)$/) {
	$cqf = 1;
	push @opts, '-cqe';
      } else {
	$ncf = 1;
      }
    }
  }
  if ($ncf or $cf) {
    if ($ncf) {
      $cmd->opts(grep !/^-nc(?:omment)?$/,@opts);
      $ret = $fn->($cmd, qw(-nc));
    } else {
      my $skip = 0;
      for (@opts) {
	if ($skip) {
	  $skip = 0;
	  push @copt, $_;
	} else {
	  if (/^-c/) {
	    $skip = 1;
	    push @copt, $_;
	  } else {
	    push @mod, $_;
	  }
	}
      }
      $cmd->opts(@mod);
      $ret = $fn->($cmd, @copt);
    }
  } elsif ($cqf) {
    my $cqe = grep /^-cqe/, @opts;
    @opts = grep !/^-cq/, @opts;
    my @arg = $cmd->args;
    my $go = 1;
    while ($go) {
      $cmd->opts(@opts); #reset
      if ($cqe) {
	my $arg = shift @arg;
	$go = scalar @arg;
	next if $tst and !$tst->($cmd, $arg);
	$cmd->args($arg);
	print qq(Comments for "$arg":\n);
      } else {
	$go = 0;
	last if $tst and !$tst->($cmd, @arg); #None checked out
	print "Comment for all listed objects:\n";
      }
      my $cmt = '';
      while (<STDIN>) {
	last if /^\.$/;
	$cmt .= $_;
      }
      chomp $cmt;
      if ($cmt =~ /\n/) {
	my ($fh, $cfile) = tempfile();
	print $fh $cmt;
	close $fh;
	$ret |= $fn->($cmd, '-cfile', $cfile);
      } else {
	$ret |= $fn->($cmd, '-c', $cmt);
      }
    }
  }
  exit $ret;
}
sub _Unco {
  use warnings;
  use strict;
  my ($unco, $rc) = (shift, 0);
  $ct = ClearCase::Argv->new({autochomp=>1});
  for my $arg ($unco->args) { # Already sorted if several
    my $b0 = $ct->argv(qw(ls -s -d), $arg)->qx;
    $rc |= $unco->args($arg)->system;
    if ($b0 =~ s%^(.*)[\\/]CHECKEDOUT$%$1%) {
      opendir BR, $b0 or next;
      my @f = grep !/^\.\.?$/, readdir BR;
      closedir BR;
      $ct->argv(qw(rmbranch -f), $b0)->system
	if (scalar @f == 2) and $f[0] eq '0' and $f[1] eq 'LATEST';
    }
  }
  return $rc;
}
sub _Yesno {
  my ($cmd, $fn, $yn, $test, $errmsg) = @_;
  use warnings;
  use strict;
  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 = <STDIN>; chomp $ans; $ans = lc($ans);
    $ans = $yn->{default} unless $ans;
    while ($ans !~ $yn->{valid}) {
      print $yn->{instruct};
      $ans = <STDIN>; 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;
}
sub _Checkin {
  use strict;
  use warnings;
  my ($ci, @cmt) = @_;
  $ci->opts($ci->opts, @cmt);
  if ($ci->flag('from') and !$ci->flag('keep')) {
    my %kr = (yes => '-keep', no => '-rm');
    my %yn = (
      format   => q(Save private copy of "%s"?  [yes] ),
      default  => q(yes),
      valid    => qr/yes|no/,
      instruct => "Please answer with one of the following: yes, no\n",
      opt      => \%kr,
    );
    my $lsco = ClearCase::Argv->lsco([qw(-cview -s)]);
    $lsco->stderr(1);
    my $ok = sub { return $lsco->args(shift)->qx? 1:0 };
    my $err = 'Unable to find checked out version for ';
    my $run = sub { my $ci = shift; $ci->system };
    _Yesno($ci, $run, \%yn, $ok, $err); #only one arg: may exit
  } else {
    return $ci->system;
  }
}
# Input: lbtype type, either floating 'family' type, or fixed
# 'incremental'.
# Output: ordered list of short type names, as chained.
sub _EqLbTypeList {
  use strict;
  use warnings;
  my $top = shift;
  return unless $top;
  $top = "lbtype:$top" unless $top =~ /^lbtype:/;
  my $ct = ClearCase::Argv->new({autochomp=>1});
  my ($eq) = grep s/^-> (.*)$/$1/,
    $ct->argv(qw(des -s -ahl), $eqhl, $top)->qx;
  $_ = $eq? $eq : $top;
  my @list;
  do {
    push @list, $1 if /^lbtype:(.*?)(@.*)?$/;
    ($_) = grep s/^-> (.*)$/$1/,
      $ct->argv(qw(des -s -ahl), $prhl, $_)->qx;
  } while ($_);
  return @list;
}

sub _FltType {
  use strict;
  use warnings;
  my $lbt = shift;
  return unless $lbt;
  $lbt = "lbtype:$lbt" unless $lbt =~ /^lbtype:/;
  my $ct = ClearCase::Argv->new({autochomp=>1});
  while (($_) = grep s/^<- (.*)$/$1/,
	 $ct->argv(qw(des -s -ahl), $prhl, $lbt)->qx) {
    $lbt = $_;
  }
  my ($eq) = grep s/^<- (.*)$/$1/, $ct->argv(qw(des -s -ahl), $eqhl, $lbt)->qx;
  return '' unless $eq;
  $eq =~ s/^lbtype:(.*)\@.*$/$1/;
  return $eq;
}

sub lsgenealogy {
  GetOptions(\%opt, qw(short all obsolete depth=i));
  Assert(@ARGV > 1);		# die with usage msg if untrue
  shift @ARGV;
  my @argv = ();
  for (@ARGV) {
    $_ = readlink if -l && defined readlink;
    push @argv, MSWIN ? glob($_) : $_;
  }
  $ct = ClearCase::Argv->new({autofail=>0,autochomp=>1,stderr=>0});
  $ct->ipc(1) unless $ct->ctcmd(1);
  while (my $e = shift @argv) {
    my ($ele, $ver, $type) =
      $ct->argv(qw(des -fmt), '%En\n%En@@%Vn\n%m', $e)->qx;
    if (!defined($type) or ($type !~ /version$/)) {
      warn Msg('W', "Not a version: $e");
      next;
    }
    $ele =~ s%\\%/%g;
    $ver =~ s%\\%/%g;
    my %gen = _Parsevtree($ele, $opt{obsolete}, $ver);
    _Setdepths($ver, 0, \%gen);
    my %seen = ();
    _Printparents($ver, \%gen, \%seen, 0);
  }
  exit 0;
}

sub checkout {
  map { $_ = readlink if -l && defined readlink } @ARGV[1..$#ARGV];
  # Duplicate the base Wrapper checkout functionality.
  my @agg = grep /^-(?:dir|rec|all|avo)/, @ARGV;
  die Msg('E', "mutually exclusive flags: @agg") if @agg > 1;
  if (@agg) {
    # Remove the aggregation flag, push the aggregated list of
    # not-checked-out file elements onto argv, and return.
    my %opt;
    GetOptions(\%opt, qw(directory recurse all avobs ok));
    my @added = AutoNotCheckedOut($agg[0], $opt{ok}, 'f', @ARGV);
    push(@ARGV, @added);
  }
  ClearCase::Argv->ipc(1) unless ClearCase::Argv->ctcmd(); #set by the user
  $ct = ClearCase::Argv->new({autochomp=>1});
  my $co = ClearCase::Argv->new(@ARGV);
  $co->parse(qw(reserved unreserved nmaster out=s ndata ptime nwarn
		version branch=s query nquery usehijack
		cquery|cqeach nc c|cfile=s));
  my ($unsup) = grep /^-/, $co->args;
  die Msg('E', qq(Unrecognized option "$unsup")) if $unsup;
  if (MSWIN) {
    my @args = $co->args;
    map { $_ = glob($_) } @args;
    $co->args(@args);
  }
  _Preemptcmt($co, \&_Mkbco);
}

sub mkbranch {
  map { $_ = readlink if -l && defined readlink } @ARGV[1..$#ARGV];
  my @agg = grep /^-(?:dir|rec|all|avo)/, @ARGV;
  die Msg('E', "mutually exclusive flags: @agg") if @agg > 1;
  if (@agg) {
    # Remove the aggregation flag, push the aggregated list of
    # not-checked-out file elements onto argv, and return.
    my %opt;
    GetOptions(\%opt, qw(directory recurse all avobs ok));
    my @added = AutoNotCheckedOut($agg[0], $opt{ok}, 'f', @ARGV);
    push(@ARGV, @added);
  }
  ClearCase::Argv->ipc(1) unless ClearCase::Argv->ctcmd();
  $ct = ClearCase::Argv->new({autochomp=>1});
  my $ver;
  GetOptions("version=s" => \$ver);
  my $mkbranch = ClearCase::Argv->new(@ARGV);
  $mkbranch->parse(qw(nwarn nco ptime cquery|cqeach nc c|cfile=s));
  my @args = $mkbranch->args;
  my $bt = shift @args;
  map { $_ = glob($_) } @args if MSWIN;
  $bt =~ s/^brtype:(.*)$/$1/;
  my %v;
  if ($bt =~ /\@/) {
    $v{''} = 1;
  } else {
    for my $a (@args) {
      $v{$ct->argv(qw(des -fmt), '@%n', "vob:$a")->stderr(0)->qx}++;
    }
  }
  for (keys %v) {
    die "\n" if $ct->argv(qw(des -s), "brtype:$bt$_")->stdout(0)->system;
  }
  $mkbranch->args(@args);
  $mkbranch->{bt} = $bt;
  $mkbranch->{ver} = $ver;
  _Preemptcmt($mkbranch, \&_Mkbco);
}

sub diff {
  for (@ARGV[1..$#ARGV]) {
    $_ = readlink if -l && defined readlink;
  }
  push(@ARGV, qw(-dir)) if @ARGV == 1;
  my $limit = 0;
  if (my @num = grep /^-\d+$/, @ARGV) {
    @ARGV = grep !/^-\d+$/, @ARGV;
    die Msg('E', "incompatible flags: @num") if @num > 1;
    $limit = -int($num[0]);
  }
  my $diff = ClearCase::Argv->new(@ARGV);
  $diff->autochomp(1);
  $diff->ipc(1) unless $diff->ctcmd(1);
  $diff->parse(qw(options=s serial_format|diff_format|window
		  graphical|tiny|hstack|vstack|predecessor));
  my @args = $diff->args;
  my @opts = $diff->opts;
  my $pred = grep /^-(pred)/, @opts;
  my $auto = grep /^-(?:dir|rec|all|avo)/, @args;
  my @elems = AutoCheckedOut(0, @args);
  return 0 unless $pred or $auto or (scalar @elems == 1);
  $diff->opts(grep !/-pred/, @opts) if $pred;
  $diff->args(@elems);
  $ct = $diff->clone();
  my $rc = 0;
  for my $e (@elems) {
    my ($ele, $ver, $type) =
      $ct->argv(qw(des -fmt), '%En\n%En@@%Vn\n%m', $e)->qx;
    if (!defined($type) or ($type !~ /version$/)) {
      warn Msg('W', "Not a version: $e");
      next;
    }
    $ele =~ s%\\%/%g;
    $ver =~ s%\\%/%g;
    my $bra = $1 if $ver =~ m%^(.*?)/(?:\d+|CHECKEDOUT)$%;
    my %gen = _Parsevtree($ele, 1, $ver);
    my $p = $gen{$ver}{'parents'};
    $p = $gen{$p->[0]}{'parents'} while $p and $limit--;
    if (!$p) {
      warn Msg('E', "No predecessor version to compare to: $e");
      $rc = 1;
      next;
    }
    my ($brp) = grep { m%^$bra/\d+$% } @{$p};
    $ver = $ele if $ver =~ m%/CHECKEDOUT$%;
    $rc |= $diff->args($brp? $brp : $p->[0], $ver)->system;
  }
  exit $rc;
}

sub uncheckout {
  my %opt;
  GetOptions(\%opt, qw(ok)) if grep /^-(dif|ok)/, @ARGV;
  for (@ARGV[1..$#ARGV]) {
    $_ = readlink if -l && defined readlink;
  }
  ClearCase::Argv->ipc(1) unless ClearCase::Argv->ctcmd(1);
  my $unco = ClearCase::Argv->new(@ARGV);
  $unco->parse(qw(keep|rm cact cwork));
  $unco->optset('IGNORE');
  $unco->parseIGNORE(qw(c|cfile=s cquery|cqeach nc));
  $unco->args(sort {$b cmp $a} AutoCheckedOut($opt{ok}, $unco->args));
  if ($unco->flag('keep')) {
    exit _Unco($unco);
  } else {
    my %kr = (yes => '-keep', no => '-rm');
    my %yn = (
      format   => q(Save private copy of "%s"?  [yes] ),
      default  => q(yes),
      valid    => qr/yes|no/,
      instruct => "Please answer with one of the following: yes, no\n",
      opt      => \%kr,
    );
    my $lsco = ClearCase::Argv->lsco([qw(-cview -s)]);
    $lsco->stderr(1);
    my $dm = ClearCase::Argv->des([qw(-fmt %m)]);
    $dm->stderr(1);
    my $ok = sub {
      my $e = shift;
      return -1 if $dm->args($e)->qx =~ /^directory/;
      return $lsco->args($e)->qx? 1:0;
    };
    my $err = 'Unable to find checked out version for ';
    _Yesno($unco, \&_Unco, \%yn, $ok, $err);
  }
}

sub _GenMkTypeSub {
  use strict;
  use warnings;
  my ($type, $Name, $name) = @_;
  return sub {
    my ($ntype, @cmt) = @_;
    my $rep = $ntype->{rep};
    $ct = new ClearCase::Argv({autochomp=>1});
    my @args = $ntype->args;
    my %opt = %{$ntype->{fopts}};
    my $silent = $ct->clone({stdout=>0});
    if ((grep /^-glo/, $ntype->opts) or ($ntype->flag('global') and !%opt)) {
      push @cmt, '-rep' if $rep;
      $ntype->opts(@cmt, $ntype->opts);
      return $ntype->system
    }
    my (%vob, $unkvob);
    /\@(.*)$/? $vob{$1}++ : $vob{'.'}++ for @args;
    my @vob = keys %vob;
    for (@vob) { #Diagnose all the errors, even if one is enough to fail
      $unkvob++ if $silent->argv(qw(des -s), "vob:$_")->system;
    }
    return 1 if $unkvob;
    if ($ClearCase::Wrapper::MGi::global and !$ntype->flag('global')) {
      my %avob;
      for my $v (@vob) {
	my ($hl) = grep s/^-> (?:vob:)(.*)$/$1/,
	  $ct->desc([qw(-s -ahl AdminVOB), "vob:$v"])->qx;
	$avob{$v} = $hl if $hl;
      }
      if (scalar keys %avob) {
	$ntype->opts('-global', $ntype->opts);
	for (@vob) {	   #Fix the vobs, to ensure the metadata types
	  $_ = $avob{$_} if $avob{$_};
	}
	for (@args) { #Fix the types, to create them in the admin vob(s)
	  $_ = $1 . $avob{$2} if /^(.*\@)(.*)$/ and $avob{$2};
	}
	warn Msg('W', "making global type(s) @args");
      }
    }
    if (%opt) {
      map { s/^${type}:(.*)$/$1/ } @args;
      my @a = @args;
      _Ensuretypes((grep /^-glo/, $ntype->opts), @vob);
      if ($rep) {
	@args = grep { $_ = $ct->des([qw(-fmt %Xn)], "$type:$_")->qx } @args;
	exit 1 unless @args;
	if ($opt{family}) {
	  @a = ();
	  my $gflg = (grep /^-glo/, $ntype->opts)? '-glo' : '-ord';
	  foreach my $t (@args) {
	    if ($ct->des([qw(-s -ahl), $eqhl], $t)->stderr(0)->qx) {
	      warn Msg('E', "$t is already a family type\n");
	      if ($t =~ s/^lbtype:(.*)$/$1/) {
		my $att = "Rm$t";
		$ct->mkattype([qw(-vtype real -c), q(Deleted in increment),
			       $gflg], "$att")->stderr(0)->system;
	      }
	    } else {
	      push @a, $t;
	    }
	  }
	  exit 1 unless @a;
	  my %pair = ();
	  foreach (@a) {
	    $pair{"$1$2"} = "${1}_1.00$2" if /^$type:(.*?)(@.*)$/;
	  }
	  _Findfreeinc(\%pair);
	  $ntype->args(values %pair);
	  $ntype->opts(@cmt, $ntype->opts);
	  $ntype->system;
	  map {
	    if (defined($pair{$_})) {
	      my $inc = "$type:$pair{$_}";
	      $silent->mkhlink([$eqhl], "$type:$_", $inc)->system;
	      if ($type eq 'lbtype') {
		my $att = "Rm$_";
		$ct->mkattype([qw(-vtype real -c), q(Deleted in increment),
			       $gflg], "$att")->stderr(0)->system;
	      }
	    }
	  } keys %pair;
	} elsif ($opt{archive}) {
	  my $rc = 0;
	  foreach my $t (@args) {
	    my ($pfx, $vob) = $t =~ /^$type:(.*?)(@.*)$/;
	    my ($prev) = grep s/^-> $type:(.*?)@.*/$1/,
	      $ct->des([qw(-s -ahl), $prhl], $t)->stderr(0)->qx;
	    my $arc;
	    if ($prev) {
	      if (my ($pfx, $nr) = $prev =~ /^(.*-)(\d+)$/) {
		$arc = $pfx . $nr++;
	      } else {
		$arc = $prev . '-001';
	      }
	    } else {
	      $arc = $pfx . '-001';
	    }
	    ($pfx, my $nr) = $arc =~ /^(.*-)(\d+)$/;
	    while ($ct->des(['-s'], "$type:${arc}$vob")->stderr(0)->qx) {
	      $arc = $pfx . $nr++;
	    }
	    if ($ct->rename($t, $arc)->system) {
	      $rc = 1;
	      next;
	    }
	    $ntype->args($t);
	    $ntype->opts('-nc', $ntype->opts);
	    $ntype->system;
	    my $at = "$type:${arc}$vob";
	    $silent->mkhlink([$prhl], $t, $at)->system;
	    if ($type eq 'lbtype') {
	      my $t0 = $t;
	      $t0 =~ s/^lbtype:(.*?)(@.*)$/lbtype:${1}_0$2/;
	      $ct->rename($t, $t0)->system;
	      $arc = "lbtype:$arc$vob";
	      my ($eq) = grep s/^-> (.*)/$1/,
		$ct->des([qw(-s -ahl), $eqhl], $arc)->stderr(0)->qx;
	      my @arg = ($t0, $arc);
	      push @arg, $eq if $eq;
	      $ct->lock(@arg)->system;
	    }
	    $ct->argv('chevent', @cmt, $at)->stdout(0)->system
	      unless $cmt[0] and $cmt[0] =~ /^-nc/;
	  }
	  exit $rc;
	} else {		# increment
	  die Msg('E', "Incompatible flags: replace and incremental");
	}
      } else {
	if ($opt{family}) {
	  @a = @args;
	  map { $_ = "$type:$_" } @a;
	  die Msg('E', "Some types already exist among @args")
	    unless $silent->argv(qw(des -s), @a)->stderr(0)->system;
	  my (%pair, @skip) = ();
	TYPE: foreach my $t (@args) {
	    if ($t =~ /^(.*?)(@.*)?$/) {
	      my ($pfx, $sfx) = ($1, $2?$2:'');
	      if ($type eq 'lbtype') {
		my $t0 = "lbtype:${pfx}_0$sfx";
		if ($ct->argv(qw(des -s), $t0)->stderr(0)->qx) {
		  $ct->argv('unlock', $t0)->system;
		  $ct->argv('rename', $t0, "lbtype:$t")->stderr(0)->system
		    and die Msg('E', qq(Failed to restore "$t0" into "$t".));
		  push @skip, $t;
		  if (my ($p) = grep s/^-> (.*)$/$1/,
		      $ct->des([qw(-s -ahl), $prhl], "lbtype:$t")->qx) {
		    ($pair{$t}) = grep s/^-> lbtype:(.*)$/$1/,
		      $ct->des([qw(-s -ahl), $eqhl], $p)->qx;
		  } else {
		    $pair{$t} = "${pfx}_1.00$sfx";
		  }
		} else {
		  $pair{$t} = "${pfx}_1.00$sfx";
		}
	      } else {
		$pair{$t} = "${pfx}_1.00$sfx";
	      }
	    }
	  }
	  my @opts = $ntype->opts();
	  if (%pair) {
	    _Findfreeinc(\%pair);
	    $ntype->args(values %pair);
	    $ntype->opts(@cmt, @opts);
	    $ntype->system;
	  }
	  if (@skip) {
	    my $sk = '(' . join('|', @skip) . ')';
	    @a = grep !/$sk/, @args;
	  } else {
	    @a = @args;
	  }
	  if (@a) {
	    $ntype->args(@a);
	    $ntype->opts('-nc', @opts);
	    $ntype->system;
	  }
	  my $gflg = (grep /^-glo/, $ntype->opts)? '-glo' : '-ord';
	  for (keys %pair) {
	    if (defined($pair{$_})) {
	      my $inc = "$type:$pair{$_}";
	      $silent->argv('mkhlink', $eqhl, "$type:$_", $inc)->system;
	      next if $type eq 'brtype';
	      my $att = "Rm$_";
	      $ct->argv(qw(mkattype -vtype real -c), q(Deleted in increment),
			$gflg, "$att")->stderr(0)->system;
	    }
	  }
	} elsif ($opt{increment}) { # increment
	  $ntype->opts(@cmt, $ntype->opts);
	  my $lct = ClearCase::Argv->new(); #Not autochomp
	  my ($fl, $loaded) = $ENV{FORCELOCK};
	INCT: for my $t (@args) {
	    my ($pt, $lck) = "$type:$t";
	    if (!$ct->argv(qw(des -s), $pt)->stderr(0)->qx) {
	      warn Msg('E', qq($Name type not found: "$t"));
	      next;
	    }
	    my ($pair) = grep s/^\s*(.*) -> $type:(.*)\@(.*)$/$1,$2,$3/,
	      $ct->argv(qw(des -l -ahl), $eqhl, $pt)->stderr(0)->qx;
	    my ($hlk, $prev, $vob) = split /,/, $pair if $pair;
	    if (!$prev) {
	      warn Msg('E', "Not a family type: $t");
	      next INCT;
	    }
	    my ($t1) = $t =~ /^(.*?)(@|$)/;
	    for my $l ($t1, $prev) {
	      if ($ct->argv(qw(lslock -s), "lbtype:$l\@$vob")->stderr(0)->qx) {
		$lck = 1;  #remember to lock the equivalent fixed type
		#This should happen as vob owner, to retain the timestamp
		my @out =
		  $lct->argv('unlock', "lbtype:$l\@$vob")->stderr(1)->qx;
		if (grep /^cleartool: Error/, @out) {
		  if ($fl and !$loaded) {
		    my $fn = $fl; $fn =~ s%::%/%g; $fn .= '.pm';
		    require $fn;
		    $fl->import;
		    $loaded = 1;
		  }
		  if (!$fl) {
		    print @out;
		    next INCT;
		  } elsif (funlocklt($l, $vob)) {
		    next INCT;
		  }
		} else {
		  print @out;
		}
	      }
	    }
	    if ($prev =~ /^(.*)_(\d+)(?:\.(\d+))?$/) {
	      my ($base, $maj, $min, $new) = ($1, $2, $3);
	      my $ext = ($t =~ /^.*(@.*)$/)? $1 : '';
	      my $p1 = $prev . $ext;
	      do {
		$new = "${base}_" .
		  (defined($min)? $maj . '.' . ++$min : ++$maj);
		$new .= $ext;
	      } while ($ct->argv(qw(des -s), "$type:$new")->stderr(0)->qx);
	      $ntype->args($new)->system and exit 1;
	      $silent->argv('rmhlink', $hlk)->system;
	      $silent->argv(qw(mkhlink -nc), $eqhl,
			    "$type:$t", "$type:$new")->system;
	      $silent->argv(qw(mkhlink -nc), $prhl,
			    "$type:$new", "$type:$p1")->system;
	      if ($lck) {
		my @out =
		  $lct->argv('lock', "lbtype:$prev\@$vob")->stderr(1)->qx;
		if ($fl and grep /^cleartool: Error/, @out) {
		  flocklt($prev, $vob); # loaded while unlocking
		} else {
		  print @out;
		}
	      }
	    } else {
	      warn Msg('W',qq(Previous increment non suitable in $t: "$prev"));
	    }
	  }
	}
      }
      exit 0;
    } else {			# non inc/arc/fam
      if ($rep) {
	$ntype->opts(@cmt, '-replace', $ntype->opts);
	map { $_ = "$type:$_" unless /^$type:/ } @args;
	my @a = $ct->argv(qw(des -s), @args)->stderr(0)->qx;
	if (@a) {
	  map { $_ = "$type:$_" } @a;
	  my @link = grep s/^\s*(.*) -> .*$/$1/,
	    $ct->argv(qw(des -l -ahl), "$eqhl,$prhl", @a)->qx;
	  $ct->argv('rmhlink', @link)->system;
	} else {
	  foreach (@args) {
	    s/^$type://;
	    warn Msg('E', qq($Name type not found: "$_".));
	  }
	  exit 1;
	}
      } else {
	$ntype->args(@args);
	$ntype->opts(@cmt, $ntype->opts);
	return $ntype->system;
      }
    }
  };
}
sub _GenExTypeSub {
  use strict;
  use warnings;
  my $type = shift;
  return sub {
    my ($mkt, $arg) = @_;
    $arg = "$type:$arg" unless $arg =~ /^$type:/;
    # Maybe need to check that non locked?
    return ClearCase::Argv->des('-s', $arg)->stdout(0)->system? 0 : 1;
  };
}
sub mklbtype {
  use strict;
  use warnings;
  my (%opt, $rep);
  GetOptions(\%opt, qw(family increment archive));
  GetOptions('replace' => \$rep);
  die Msg('E', 'Incompatible options: family increment archive')
    if keys %opt > 1;
  ClearCase::Argv->ipc(1);
  my $ntype = ClearCase::Argv->new(@ARGV);
  $ntype->parse(qw(global|ordinary vpelement|vpbranch|vpversion
		   pbranch|shared gt|ge|lt|le|enum|default|vtype=s
		   cquery|cqeach nc c|cfile=s));
  if (!$ntype->args) {
    warn Msg('E', 'Type name required.');
    @ARGV = qw(help mklbtype);
    ClearCase::Wrapper->help();
    return 1;
  }
  $ntype->{fopts} = \%opt;
  $ntype->{rep} = $opt{archive}? 1 : $rep;
  my $tst = $ntype->{rep}? _GenExTypeSub('lbtype') : 0;
  _Preemptcmt($ntype, _GenMkTypeSub(qw(lbtype Label label)), $tst);
}

sub mkbrtype {
  use strict;
  use warnings;
  my (%opt, $rep);
  GetOptions(\%opt, q(archive));
  GetOptions('replace' => \$rep);
  die Msg('E', 'Incompatible options: global types cannot be archived')
    if %opt and grep /^-glo/, @ARGV;
  ClearCase::Argv->ipc(1);
  my $ntype = ClearCase::Argv->new(@ARGV);
  $ntype->parse(qw(global|ordinary acquire pbranch
		   cquery|cqeach nc c|cfile=s));
  $ntype->{fopts} = \%opt;
  $ntype->{rep} = $opt{archive}? 1 : $rep;
  my $tst = $ntype->{rep}? _GenExTypeSub('brtype') : 0;
  _Preemptcmt($ntype, _GenMkTypeSub(qw(brtype Branch branch)), $tst);
}

sub lock {
  my (%opt, $nusers);
  GetOptions(\%opt, qw(allow=s deny=s iflocked));
  GetOptions('nusers=s' => \$nusers);
  ClearCase::Argv->ipc(1);
  my $lock = ClearCase::Argv->new(@ARGV);
  $lock->parse(qw(c|cfile=s cquery|cqeach nc pname=s obsolete replace));
  die Msg('E', "cannot specify -nusers along with -allow or -deny")
    if %opt and $nusers;
  die Msg('E', "cannot use -allow or -deny with multiple objects")
    if %opt and $lock->args > 1;
  my $lslock = ClearCase::Argv->lslock([qw(-fmt %c)], $lock->args);
  my($currlock) = $lslock->autofail(1)->qx;
  if ($currlock && $currlock =~ m%^Locked except for users:\s+(.*)%) {
    my %nusers = map {$_ => 1} split /\s+/, $1;
    if ($nusers) {
      %nusers = ();
      map { $nusers{$_} = 1 } split /,/, $nusers;
    } else {
      if ($opt{allow}) {
	map { $nusers{$_} = 1 } split /,/, $opt{allow};
      } elsif ($opt{deny}) {
	map { delete $nusers{$_} } split /,/, $opt{deny};
      } else {
	%nusers = ();
      }
    }
    $lock->opts($lock->opts, '-nusers', join(',', sort keys %nusers))
      if %nusers;
  } elsif (($nusers or $opt{allow}) and
	     (!$currlock or $opt{iflocked} or $lock->flag('replace'))) {
    $lock->opts($lock->opts, '-nusers', ($nusers or $opt{allow}));
  }
  if ($currlock and !$lock->flag('replace')) {
    if ($opt{allow} or $opt{deny}) {
      $lock->opts($lock->opts, '-replace')
    } else {
      die Msg('E', 'Object is already locked.');
    }
  }
  my @args = $lock->args;
  $ct = ClearCase::Argv->new({autochomp=>1});
  my (@lbt, @oth, %vob);
  my $locvob = $ct->argv(qw(des -s vob:.))->stderr(0)->qx;
  foreach my $t (@args) {
    if ($ct->argv(qw(des -fmt), '%m\n', $t)->stderr(0)->qx eq 'label type') {
      my ($t1,$v) = $t;
      if ($t =~ /lbtype:(.*)@(.*)$/) {
	$t = $1; $v = $2;
      } else {
	$t =~ s/^lbtype://;
	$v = $locvob;
      }
      $vob{$t} = $v;
      push @lbt, $t;
      my @et = grep s/^-> lbtype:(.*)@.*$/$1/,
	$ct->argv(qw(des -s -ahl), $eqhl, $t1)->qx;
      if (@et) {
	my ($e, $p) = ($et[0], '');
	$vob{$e} = $vob{$t};
	push @lbt, $e;
	my @pt = grep s/^-> lbtype:(.*)@.*$/$1/,
	  $ct->argv(qw(des -s -ahl), $prhl, "lbtype:$e\@$v")->qx;
	if (@pt) {
	  $p = $pt[0];
	  if (!$ct->argv(qw(lslock -s), "lbtype:$p\@$v")->stderr(0)->qx) {
	    push @lbt, $p;
	    $vob{$p} = $v;
	  }
	}
      }
    } else {
      push @oth, $t;
    }
  }
  my $rc = @oth? $lock->args(@oth)->system : 0;
  my ($fl, $loaded) = $ENV{FORCELOCK};
  for my $lt (@lbt) {
    my $v = $vob{$lt};
    my @out = $lock->args("lbtype:$lt\@$v")->stderr(1)->qx;
    if (grep /^cleartool: Error/, @out) {
      if ($fl and !$loaded) {
	my $fn = $fl; $fn =~ s%::%/%g; $fn .= '.pm';
	require $fn;
	$fl->import;
	$loaded = 1;
      }
      if (!$fl) {
	print @out;
	$rc = 1;
      } elsif (flocklt($lt, $v, $lock->flag('replace'),
		       ($nusers or $opt{allow}))) {
	$rc = 1;
      }
    } else {
      print @out;
    }
  }
  exit $rc;
}

sub unlock() {
  ClearCase::Argv->ipc(1);
  my $unlock = ClearCase::Argv->new(@ARGV);
  $unlock->parse(qw(c|cfile=s cquery|cqeach nc version=s pname=s));
  my @args = $unlock->args;
  $ct = ClearCase::Argv->new({autochomp=>1});
  my (@lbt, @oth, %vob);
  my $locvob = $ct->argv(qw(des -s vob:.))->stderr(0)->qx;
  foreach my $t (@args) {
    if ($ct->argv(qw(des -fmt), '%m\n', $t)->stderr(0)->qx eq 'label type') {
      my $t1 = $t;
      if ($t =~ /lbtype:(.*)@(.*)$/) {
	$t = $1; $vob{$t} = $2;
      } else {
	$t =~ s/^lbtype://;
	$vob{$t} = $locvob;
      }
      push @lbt, $t;
      my @et = grep s/^-> lbtype:(.*)@.*$/$1/,
	$ct->argv(qw(des -s -ahl), $eqhl, $t1)->qx;
      if (@et) {
	push @lbt, $et[0];
	$vob{$et[0]} = $vob{$t};
      }
    } else {
      push @oth, $t;
    }
  }
  my $rc = @oth? $unlock->args(@oth)->system : 0;
  my ($fl, $loaded) = $ENV{FORCELOCK};
  for my $lt (@lbt) {
    my $v = $vob{$lt};
    if ($ct->argv(qw(lslock -s), "lbtype:$lt\@$v")->qx) {
      my @out = $unlock->args("lbtype:$lt\@$v")->stderr(1)->qx;
      if (grep /^cleartool: Error/, @out) {
	if ($fl and !$loaded) {
	  my $fn = $fl; $fn =~ s%::%/%g; $fn .= '.pm';
	  require $fn;
	  $fl->import;
	  $loaded = 1;
	}
	if (!$fl) {
	  print @out;
	  $rc = 1;
	} elsif (funlocklt($lt, $v)) {
	  $rc = 1;
	}
      } else {
	print @out;
      }
    } else {
      warn Msg('E', 'Object is not locked.');
      warn Msg('E', "Unable to unlock label type \"$lt\".");
      $rc = 1;
    }
  }
  exit $rc;
}

sub mklabel {
  use warnings;
  use strict;
  my %opt;
  GetOptions(\%opt, qw(up force over=s all));
  ClearCase::Argv->ipc(1);
  my $mkl = ClearCase::Argv->new(@ARGV);
  $mkl->parse(qw(replace|recurse|follow|ci|cq|nc
		 version=s c|cfile|select|type|name|config=s));
  my @opt = $mkl->opts();
  die Msg('E', 'all is only supported in conjunction with over')
    if $opt{all} and !$opt{over};
  die Msg('E', 'Incompatible flags: up and config')
    if $opt{up} and grep /^-con/, @opt;
  die Msg('E', 'Incompatible flags: recurse and over')
    if $opt{over} and grep /^-r(ec|$)/, @opt;
  die Msg('E', 'Incompatible flags: up and over') if $opt{up} and $opt{over};
  my($lbtype, @elems) = $mkl->args;
  die Msg('E', 'Only one version argument with the over flag')
    if $opt{over} and scalar @elems > 1;
  die Msg('E', 'Label type required') unless $lbtype;
  $lbtype =~ s/^lbtype://;
  $ct = ClearCase::Argv->new({autochomp=>1});
  my (%vb, @lt);
  for my $e (@elems?@elems:qw(.)) {
    my $v = $ct->argv(qw(des -s), "vob:$e")->stderr(0)->qx;
    $vb{$v}++ if $v;
  }
  if ($lbtype =~ /@/) {
    push @lt, $lbtype;
  } else {
    push @lt, "$lbtype\@$_" for keys %vb;
  }
  my @lt1 = @lt;
  my @et = grep s/^-> lbtype:(.*)@.*$/$1/,
    map { $ct->argv(qw(des -s -ahl), $eqhl, "lbtype:$_")->qx } @lt1;
  return 0 unless $opt{up} or $opt{over} or @et;
  my $fail = $ct->clone({autofail=>1});
  $fail->argv(qw(des -s), @elems)->stdout(0)->system
    unless $opt{over} and !@elems; #eq fixed => 1 failure fails all
  die Msg('E', "Only one vob supported for family types") if @et > 1;
  map {
    die Msg('E', qq(Lock on label type "$_" prevents operation "make label"))
      if $ct->argv(qw(lslock -s),"lbtype:$_")->stderr(0)->qx
    } @lt;
  my ($ret, @rec, @mod) = 0;
  if (grep /^-r(ec|$)/, @opt) {
    if (@et) {
      #The -vob_only flag would hide the checkout info for files
      @rec = grep m%@@[/\\]%, $ct->argv(qw(ls -s -r), @elems)->qx;
    } else {
      $mkl->syfail(1) unless $opt{force};
      $ret = $mkl->system;
    }
  } elsif ($opt{over}) {
    my ($t, $ver, $lb) = ($opt{over}, $elems[0]);
    die Msg('E', 'The -over flag requires a local type argument')
      if !$t or $t =~ /\@/;
    my $base = $ver || '.';
    my $vob = $fail->argv(qw(des -s), "vob:$base")->qx;
    if ($t =~ /lbtype:(.*)$/) {
      $t = $1; $lb = 1;
      die unless $ct->argv(qw(des -s), "lbtype:$t\@$vob")->qx;
    } elsif ($t =~ /brtype:(.*)/) {
      $t = $1; $lb = 0;
      die unless $ct->argv(qw(des -s), "brtype:$t\@$vob")->qx;
    } else {
      if ($ct->argv(qw(des -s), "lbtype:$t\@$vob")->stderr(0)->qx) {
	$lb = 1;
      } elsif ($ct->argv(qw(des -s), "brtype:$t\@$vob")->stderr(0)->qx) {
	$lb = 0;
      } else {
	die Msg('E', 'The argument of the -over flag must be an existing type')
      }
    }
    my $query = $lb? "lbtype($t)" : "version(.../$t/LATEST)";
    $query .= " \&\&! lbtype($lbtype)";
    $base = '-a' if $opt{all};
    @mod = $ct->argv('find', $base, '-ver', $query, '-print')->stderr(0)->qx;
    if ($opt{all} and $ver) {
      use File::Spec::Functions qw(rel2abs);
      $ver = rel2abs($ver);
      @mod = grep /^${ver}(\W|$)/, @mod;
    }
  }
  $mkl->opts(grep !/^-r(ec|$)/, @opt); # recurse handled already
  if ($opt{up}) {
    my $dsc = ClearCase::Argv->new({-autochomp=>1});
    require File::Basename;
    require File::Spec;
    File::Spec->VERSION(0.82);
    my $vroot;
    if ($^O eq 'cygwin') {
      $vroot = '/cygdrive/a';	#just for the length
    } elsif ($^O =~ /MSWin/) {
      $vroot = 'a:';
    } else {
      $vroot = $ct->argv(qw(pwv -root))->qx;
    }
    my %ancestors;
    for my $pname (@elems) {
      my $vobtag = $dsc->desc(['-s'], "vob:$pname")->qx;
      my $stop = length("$vroot$vobtag");
      for (my $dad = File::Basename::dirname(File::Spec->rel2abs($pname));
	   length($dad) >= $stop;
	   $dad = File::Basename::dirname($dad)) {
	$ancestors{$dad}++;
      }
    }
    if (@et) {
      push @elems, sort {$b cmp $a} keys %ancestors;
    } else {
      @elems = () if grep /^-r(ec|$)/, @opt; #already labelled
      push @elems, sort {$b cmp $a} keys %ancestors;
      $ret |= $mkl->args($lbtype, @elems)->system;
      exit $ret;
    }
  }
  if (!$opt{over}) {
    push @elems, @rec;
    @mod = grep {
      my $v = $_;
      $_ = (grep /^$lbtype$/, split/ /,
	    $ct->argv(qw(des -fmt), '%Nl', $v)->qx)? '' : $v;
    } @elems;
  }
  exit $ret unless @mod;
  my $rmattr = ClearCase::Argv->rmattr([("Rm$lbtype")]);
  my @raopts = $rmattr->opts;
  push(@raopts, '-ver', $mkl->flag('version')) if $mkl->flag('version');
  $rmattr->opts(@raopts);
  for (@mod) {
    if (@et) {
      my $rc = $mkl->args($et[0], $_)->system;
      $ret |= $rc;
      next if $rc and !$opt{force};
      $rmattr->args($_)->stderr(0)->system unless $rc;
    }
    @opt = $mkl->opts;
    push @opt, '-rep' if @et and !grep /^-rep/, @opt; #implicit for floating
    $mkl->opts(@opt);
    $ret |= $mkl->args($lbtype, $_)->system;
  }
  exit $ret;
}