ClearCase-Wrapper-MGi
view release on metacpan or search on metacpan
$path =~ y%\\%/% if MSWIN;
if ($path =~ m%^/%) {
if (MSWIN or CYGWIN) {
my $tag = $CT->des(['-s'], "vob:$n")->qx;
my $pfx = $1 if $n =~ m%^(.*?\Q$tag\E)%;
$path = catfile($pfx, $path);
}
} else {
my $p = dirname($n);
while ($path =~ /^\./) {
$path =~ s%^\./(.*)$%$1%;
$p = dirname($p) while $path =~ s%^\.\./(.*)$%$1%;
if ($path eq '.') {
$path = ''; last
}
if ($path eq '..') {
$path = ''; $p = dirname($p); last;
}
last if $path =~ m%^\.[^/]%;
}
$path = $path? catfile($p, $path) : $p;
}
if (!$stop) {
my $tag = $CT->des(['-s'], "vob:$path")->qx;
$stop = length($1) if $path =~ m%^(.*?\Q$tag\E)%;
}
_Recpath($anc, 1, $path, $stop);
$stop = 0;
}
} elsif ($type !~ /version$/) {
return; # Non reachable or dangling
}
my $pn = rel2abs($n); # if 'a/' with 'a' a symlink, yields 'a', but vob remote
if (!$stop) {
my $tag = $CT->des(['-s'], "vob:$n")->qx;
$stop = length($1) if $pn =~ m%^(.*?\Q$tag\E)%;
}
$pn = $CT->des([(qw(-fmt %En))], $pn)->qx if $pn =~ /@/; #version ext. name
my $dad = dirname($pn);
return if length($dad) < $stop;
$anc->{$dad}++;
_Recpath($anc, 1, $dad, $stop);
}
sub _RecLock {
my $obj = shift;
my (@lock) = $CT->lslock([qw(-fmt %d\n%u\n%Nc)], $obj)->qx;
my @args = ();
if (@lock) {
my $date = shift @lock;
my $user = shift @lock;
my @cmt;
for (@lock) {
if (m%^Locked except for users:\s+(.*)%) {
push @args, '-nusers', grep{s/ /,/g} $1;
} elsif (/^Locked for all users( \(obsolete\))?\.$/) {
push @args, '-obs' if $1;
} else {
push @cmt, $_;
}
}
unshift @cmt, "Relocked to mkhlink. Locked on $date by $user";
push @args, '-c', join('\n',@cmt), $obj;
}
return @args;
}
=head1 NAME
ClearCase::Wrapper::MGi - Support for an alternative to UCM.
=head1 SYNOPSIS
This is an C<overlay module> for B<ClearCase::Wrapper> containing Marc
Girod's non-standard extensions. See C<perldoc ClearCase::Wrapper> (by
David Boyce) for more details.
The alternative to UCM consists in a novel branching model, and a concept
of incremental types.
=head1 CLEARTOOL EXTENSIONS
=over 2
=item * LSGENEALOGY
New command. B<LsGenealogy> is an alternative way to display the
version tree of an element. It will treat merge arrows on a par level
with parenthood on a branch, and will navigate backwards from the
version currently selected, to find what contributors took part in its
state.
This is thought as being particularly adapted to displaying the
bush-like structure characteristic of version trees produced under the
advocated branching strategy.
Flags:
=over 1
=item B<-all>
Show 'uninteresting' versions, otherwise skipped:
=over 1
=item - bearing no label
=item - not at a chain boundary.
=back
Note that a different algorithm is used with and without the C<-all> option.
The latter uses C<lsvtree> and may thus be slow on elements with a large
version tree. The former is thus more scalable.
=item B<-obsolete>
Add obsoleted branches to the search.
=item B<-short>
Skip displaying labels and 'labelled' versions and do not report
changes) type. This helps to mark the history of application of the
I<floating> type, which is also a I<full> one, for reproducibility
purposes.
=item B<PrevInc>
Previous incremental fixed type.
=back
Attributes are created of a per label family type, and are used to
mark the deletion of labels applied at a previous increment. The
attribute type for family lbtype I<XXX> is I<RmXXX>, and the value is
the numeric (treated as I<real>) value of the increment.
Flags:
=over 1
=item B<-fam/ily>
Create two label types, linked with an B<EqInc> hyperlink.
The first, given as argument, will be considered as an alias for successive
increments of the second. It is the I<family> type.
The name of the initial incremental type is this of the I<family> type, with
a suffix of I<_1.00>.
Also create a I<RmLBTYPE> attribute type to record removals of labels.
For lbtypes, if the floating type was previously archived (e.g. to
deactivate config spec rules), then the command I<revives> the type
hidden as part of archiving (and not applied anywhere). The new
equivalent fixed type is the one following the last equivalent type,
which is however B<not> set as its I<previous> increment.
=item B<-inc/rement>
Create a new increment of an existing label type family, given as argument.
This new type will take the place of the previous increment, as the
destination of the B<EqInc> hyperlink on the I<family> type.
It will have a B<PrevInc> hyperlink pointing to the previous increment in
the family.
For lbtypes, if the floating type was previously archived, then the
behavior reverts to the B<-fam/ily> one. This means that an archived
label type may be I<incremented>. This however amounts to a new
creation and is only provided as a convenience (no need to remember
the state of the family--whether it was rolled out and archived or
not).
=item B<-arc/hive>
Rename the current type to an I<archive> value (name as prefix, and a
numeral suffix. Initial value: I<-001>), create a new type, and make the
archived one its predecessor, with a B<PrevInc> hyperlink.
Comments go to the type being archived.
The implementation is largely shared with I<mkbrtype>.
For label types, the newly created type is hidden away (with a suffix
of I<_0>) and locked. It is being restored the next time C<mklbtype -fam>
is given for the same name.
=item B<-glo/bal>
Support for global family types is preliminary.
=item B<-con/fig>
Make or increment lbtypes in all vobs used by a config record.
=item B<-exc/lude>
When using a config record, exclude comma separated vobs for label
type creation.
=item B<-full/copy>
Create a new type, while is applied to all versions which bore labels
of a floating type, at the time of a given increment.
The type is created and applied only in one vob, even if the original
type was global.
This option is only compatible, among the extensions, with the
B<-family> flag (optional).
It is also incompatible with B<-replace> (the implementation was not
considered worth the while).
=back
=cut
sub _GenMkTypeSub {
use strict;
use warnings;
use Cwd;
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});
my (%vob, $unkvob, %fcpy);
/\@(.*)$/? $vob{$1}++ : $vob{'.'}++ for @args;
my @vob = keys %vob;
if (my $inc = $opt{fullcopy}) { #if fail, fail early
$inc =~ s/^lbtype://;
my $lbinc = "lbtype:$inc";
die Msg('E', "'$inc' must be an incremental fixed label type")
unless grep /^<-/, $CT->des([qw(-s -ahl), "$EQHL,$PRHL"], $lbinc)->qx;
die Msg('E', 'Only one lbtype for full copy') if @args > 1;
my ($base, $nr, $vob) = $inc =~ /^(.*)_(.*?)(?:@(.*))?$/;
if ($vob) {
die Msg('E', "Conflicting vob specifications: '$vob[0]' and '$vob'")
if $vob[0] ne '.' and $vob[0] ne $vob;
$fcpy{vob} = $vob;
$vob[0] = $vob;
my @link;
if ($ntype->flag('global')) { # replace also the equivalent types
my @eq = grep s/^-> (.*)$/$1/,
$CT->des([qw(-s -ahl)], $EQHL, @a)->qx;
push @args, @eq;
$ntype->args(@args);
} else { # remove the hyperlinks, i.e. make the types 'non-family'
@link = grep s/^\s*(.*) -> .*$/$1/,
$CT->des([qw(-l -ahl)], "$EQHL,$PRHL", @a)->qx;
}
$rc = $ntype->system; # may fail because of restrictions: first
$rc = $CT->rmhlink(@link)->system if @link and !$rc;
} else {
foreach (@args) {
s/^$type://;
warn Msg('E', qq($Name type not found: "$_".));
}
exit 1;
}
} else {
$ntype->args(@args);
$ntype->opts(@cmt, $ntype->opts);
$rc = $ntype->system;
}
return $rc if $rc; #only in error, so no fallback
}
if (%fcpy) { #full copy: type already created; now apply it
my @eqlst = _EqLbTypeList($fcpy{lbinc});
my $lbt = $args[0];
$lbt =~ s/@.*$//;
my $qry = '&&!attr_sub(Rm' . "$fcpy{base},<=,$fcpy{nr})";
my @lbargs = ($lbt);
push @lbargs, '-replace' if $rep;
my $vob = ($fcpy{vob} or $CT->des(['-s'], 'vob:.')->qx);
my @findopts;
push @findopts, $vob if $fcpy{vob};
push @findopts, qw(-a -ele), '!lbtype_sub(' . $lbt . ')', '-ver';
my $lbtv = "lbtype:$lbt";
$lbtv .= "\@$vob" if $fcpy{vob};
for my $inc (@eqlst) {
my @ver = $CT->find(@findopts, "lbtype($inc)$qry", '-print')->qx;
next unless @ver;
$rc |= _Wrap('mklabel', @lbargs, @ver);
}
_Ensuretypes([$FCHL], $vob);
my @lckargs = _RecLock $fcpy{lbinc};
_Wrap('unlock', $fcpy{lbinc}) if @lckargs;
$rc |= $CT->mkhlink([$FCHL], $fcpy{lbinc}, $lbtv)->system;
_Wrap('lock', @lckargs) if @lckargs;
}
exit $rc;
};
}
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 config=s c99=s exclude=s fullcopy=s));
GetOptions('replace' => \$rep);
die Msg('E', 'Incompatible options: family increment archive')
if (keys %opt > 1 and !($opt{config} or $opt{fullcopy}))
or (keys %opt > 2 and !$opt{exclude})
or keys %opt > 3;
die Msg('E', 'Incompatible options: fullcopy and '
. join', ', grep !/^(?:fullcopy|family)$/, keys %opt)
if $opt{fullcopy} and keys %opt > 1 and !$opt{family};
die Msg('E', 'Incompatible options: fullcopy and replace')
if $opt{fullcopy} and $rep;
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);
}
=item * MKBRTYPE
Extension: archive a brtype away, in order to avoid having to modify
config specs using it (rationale: config specs are not versioned, so
they'd rather be stable). Also, starting new branches from the I<main>
one (whatever its real type) makes it easier to roll back changes if
need-be, branch off an earlier version, and bring back again the
changes rolled back at some later stage, after the problems have been
fixed.
The implementation is largely shared with I<mklbtype>.
See its documentation for the B<PrevInc> hyperlink type.
=over 1
=item B<-arc/hive>
Rename the current type to an I<archive> value (name as prefix, and a
numeral suffix. Initial value: I<-001>), create a new type, and make the
archived one its predecessor, with a B<PrevInc> hyperlink.
Comments go to the type being archived.
=item B<-glo/bal>
Global types (in an Admin vob or not) are currently not supported for
archiving.
=back
=cut
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);
}
=item * LOCK
New B<-allow> and B<-deny> flags. These work like I<-nuser> but operate
incrementally on an existing I<-nuser> list rather than completely
replacing it. When B<-allow> or B<-deny> are used, I<-replace> is
implied.
When B<-iflocked> is used, no lock will be created where one didn't
previously exist; the I<-nusers> list will only be modified for
existing locks.
In case of a family type, lock also the equivalent incremental type.
There may be an issue if the two types are not owned by the same account.
You may overcome it by providing a module specification via the environment
variable B<FORCELOCK>. This module must export both a B<flocklt> and a
B<funlocklt> (force lock and unlock label type) functions.
The functions take an B<lbtype> and a B<vob tag> as input (B<flocklt>
optionally takes a B<replace> flag and an B<nusers> exception list).
The two functions take the responsibility of printing the standard output
(but not necessarily the errors), and return an error code: 0 for success,
other for error.
See the documentation for examples of implementation.
=cut
sub lock {
use warnings;
use strict;
my (%opt, $nusers);
GetOptions(\%opt, qw(allow=s deny=s iflocked));
GetOptions('nusers=s' => \$nusers);
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->des(['-s'], 'vob:.')->stderr(0)->qx;
foreach (@args) {
if (/^lbtype:/) {
my $t = $CT->des([qw(-fmt %Xn\n)], $_)->qx;
if ($t and $CT->des([qw(-fmt %m)], $t)->stderr(0)->qx eq 'label type') {
my ($t1, $v) = $t;
$v = $2 if $t =~ s/lbtype:(.*)@(.*)$/$1/;
$vob{$t} = $v;
push @lbt, $t;
my @et = grep s/^-> lbtype:(.*)@.*$/$1/,
$CT->des([qw(-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->des([qw(-s -ahl), $PRHL], "lbtype:$e\@$v")->qx;
if (@pt) {
$p = $pt[0];
if (!$CT->lslock(['-s'], "lbtype:$p\@$v")->stderr(0)->qx) {
push @lbt, $p;
$vob{$p} = $v;
}
}
}
}
} else {
push @oth, $_;
}
}
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;
}
There is also the case of global types: then one ensures that the
family type is usable locally, by copying in the equivalent
incremental type.
=cut
sub unlock {
use warnings;
use strict;
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, %tvob, %eqt);
my $locvob = $CT->des(['-s'], 'vob:.')->stderr(0)->qx;
foreach (@args) {
if (/^lbtype:/) {
my $t = $CT->des([qw(-fmt %Xn\n)], $_)->qx;
if ($CT->des([qw(-fmt %m)], $t)->stderr(0)->qx eq 'label type') {
my $t1 = $t;
$tvob{$_} = /lbtype:.*?(@.*)$/? $1 : '';
$vob{$t} = $2 if $t =~ s/lbtype:(.*?)@(.*)$/$1/;
push @lbt, $t;
my @et = grep s/^-> lbtype:(.*)@.*$/$1/,
$CT->des([qw(-s -ahl), $EQHL], $t1)->qx;
if (@et) {
my $eq = $et[0];
$eqt{$_} = $eq;
push @lbt, $eq;
$vob{$eq} = $vob{$t};
}
}
} else {
push @oth, $_;
}
}
my $rc = @oth? $unlock->args(@oth)->system : 0;
my ($fl, $loaded) = $ENV{FORCELOCK};
for my $lt (@lbt) {
my $v = $vob{$lt};
if ($CT->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;
}
}
for (@args) {
my $eq = $eqt{$_};
next unless $eq;
my $tv = $tvob{$_};
my $lb = "lbtype:$eq$tv"; #target vob
if (!$CT->des(['-s'], $lb)->stderr(0)->qx) {
my $v = $vob{$eq};
my $ets = ($lb =~ /^([^@]*)/)[0] . "\@$v";
_Wrap('cptype', $ets, $lb);
}
}
exit $rc;
}
=item * MKLABEL
In case of a family type, apply also the equivalent incremental type.
The meaning of B<-replace> is affected: it concerns the equivalent fixed
type, and is implicit for the floating type (the one given as argument).
Preserve the support for the B<-up> flag from B<ClearCase::Wrapper::DSB>
and lift the restriction to using it only with B<-recurse>.
Added a B<-force> option which makes mostly sense in the case of applying
incremental labels. Without it, applying the floating label type will be
skipped if there has been errors while (incrementally) applying the
equivalent fixed one. Forcing the application may make sense if the errors
come from multiple application e.g. due to links, or in order to retry the
application after a first failure.
It may also be used to apply labels upwards even if recursive application
produced errors.
B<-config>: adapted for incremental types. This requires that the
label types have been created previously with I<mklbtype -config>.
It will not use admin vobs!
The script will skip, and report, vobs in which the types have not
been copied/linked to.
With incremental types, the I<-replace> flag is implicit in
conjunction with I<-config>.
Extension: B<-over> takes either a label or a branch type. In either case,
the labels will be applied over the result of a find command run on the
unique version argument, and looking for versions matching respectively
B<lbtype(xxx)> or <version(.../xxx/LATEST)> queries, and B<!lbtype(lb)> (with
I<xxx> the B<-over>, and I<lb> the main label type parameter.
Internally B<-over> performs a B<find>. This one depends by default on the
current config spec, with the result that it is not guaranteed to reach all
the versions specified, at least in the first pass. One may thus use an B<-all>
option which will be passed to the B<find>.
The B<-over> option doesn't require an element argument (default: current
directory). With the B<-all> option, it uses one if given, as a filter.
When using a branch type to apply labels, it links the types with a B<StBr>
hyperlink. This is in preparation for an eventual rollout of the label type:
this one will then archive the branch type (away) in addition to the label
push @lt, $lbtype;
} else {
push @lt, "$lbtype\@$_" for keys %vb;
}
$et{$_}++ for grep s/^-> lbtype:(.*)@.*$/$1/,
map { $CT->argv(qw(des -s -ahl), $EQHL, "lbtype:$_")->qx } @lt;
my @et = keys %et;
die Msg('E', qq("$lbtype" must have the same equivalent type in all vobs.))
if scalar @et > 1;
my $et = (scalar @et == 1)? $et[0] : '';
my $fn = sub {
my ($rml, @cmt) = @_;
my @opts = $rml->opts;
my @opcm = @opts;
push @opcm, @cmt;
my $rc = 0;
my %query; #Cache the queries per vob
for (@elems) {
my $v = $vpe{$_};
my $e = $CT->des([qw(-s)], $_)->qx; #in case passed by the label: f@@/L
$rml->opts(@opcm);
$rml->args($lbtype, $e);
my $r1 = $rml->system;
if ($et) {
my $att = "Rm$lbtype";
my $val = $et;
$val =~ s/^.*_//;
if (!$r1) { #floating successfully removed
my ($f) = ($e =~ /(.*)@@.*$/);
if (!defined $query{$v}) {
my @eqlst = grep s/(.*)/lbtype($1)/, _EqLbTypeList("$lbtype\@$v");
$query{$v} =
(@eqlst? (@eqlst==1? $eqlst[0] : '(' . join('||', @eqlst) . ')')
. "&&!attype($att)" : 0);
}
if ($query{$v}) {
my @v = $CT->find($f, qw(-d -ver), $query{$v}, '-print')->qx;
$CT->mkattr([$att, $val], @v)->stdout(0)->system if @v;
}
}
$rml->opts(@opts);
$rml->args($et, $e);
$r1 |= $rml->stderr(0)->system;
}
$rc |= $r1;
}
return $rc;
};
_Preemptcmt($rmlabel, $fn);
}
=item * RMTYPE
For family label types, 3 cases:
=over
=item -fam: remove all types in the family, as well as the I<RmLBTYPE>
attribute type. This is a rare and destructive situation, unless the
equivalent type is I<LBTYPE_1.00> (the family was just created).
The types actually affected ought of course to be unlocked.
=item -inc: remove the current increment, and move back the family
type onto the previous one. Note: I<RmLBTYPE> attributes ... may be
left behind (for now...)
=item default (no flag): remove the family (floating) type and the
current increment, storing the information about the previous one into
the "hidden" I<LBTYPE_0> type, from which it may be recovered with a
later C<mklbtype -fam LBTYPE>.
=back
Note that removing directly an incremental fixed type is left
unchanged for low level purposes, and thus may corrupt the whole
hierarchy: you need to restore links and take care of possible
I<RmLBTYPE> attributes.
=cut
sub rmtype {
use strict;
use warnings;
my %opt;
GetOptions(\%opt, qw(f999 family increment)); # f999 to disambiguate -force
die Msg('E', qq("-family" and "-increment" are mutualy exclusive.))
if $opt{family} and $opt{increment};
my $rmtype = ClearCase::Argv->new(@ARGV);
$rmtype->parse(qw(cquery|cqeach nc c|cfile=s ignore rmall force));
my @type = $rmtype->args;
my (@lbt, @oth);
for (@type) {
if (/^lbtype:/) {
push @lbt, $_;
} else {
push @oth, $_;
}
}
if (!@lbt) {
warn Msg('W', '"-family" applies only to label types') if $opt{family};
warn Msg('W', '"-increment" applies only to label types')
if $opt{increment};
exit $rmtype->system;
}
my $rs;
$rs = $rmtype->args(@oth)->system if @oth;
$CT = ClearCase::Argv->new({autochomp=>1});
if (!$rmtype->flag('rmall')) {
my @glb;
for (@lbt) {
push @glb, $_
if $CT->argv(qw(des -fmt %[type_scope]p), $_)->qx eq 'global';
}
if (@glb) {
warn Msg('E', "Global type: must specify removal of all instances.");
warn Msg('E', qq(Unable to remove label type "$_"))
for grep { s/^lbtype:(.*)(\@.*)?$/$1/ } @glb;
exit 1;
}
}
my (@args, @eq, @lck) = @lbt;
unless $opt{to};
my $bl = $opt{to}; $bl =~ s/^lbtype://;
my $lbl = "lbtype:$bl";
my @cmt = $opt{comment}? ('-c', $opt{comment}) : '-nc';
$CT = ClearCase::Argv->new({autochomp=>1});
my $sil = $CT->clone({stdout=>0, stderr=>0});
my $fail = $CT->clone({autochomp=>1, autofail=>1});
$arg =~ s/^.*://; #remove possible prefix
my $lvob = $CT->des(['-s'], 'vob:.')->stderr(0)->qx; # Maybe not in a vob
my $vob = $arg =~ /\@(.*)$/? $1 : $lvob;
if ($bl =~ /\@(.*)$/) {
die Msg('E', "$bl must be in the same vob as $arg") unless $1 eq $vob;
} else {
$lbl .= "\@$vob";
}
my $bt = $sil->des(['-s'], "lbtype:$arg")->system; #branch or label type
die Msg('E', "$arg not found")
if $bt and $sil->des(['-s'], "brtype:$arg")->system;
my $targ = $bt? "brtype:$arg" : "lbtype:$arg";
my @vobs;
if ($fail->des([qw(-fmt %[type_scope]p)], $targ)->qx eq 'global') {
die Msg('E', 'Global types are not supported in this version');
my @hl = grep/^\s+GlobalDefinition/,
$CT->des([qw(-l -ahl GlobalDefinition)], $targ)->qx;
if (@hl) {
my $hl0 = $1 if $hl[0] =~ /^\s+(\S+)/;
my $mvob = $1 if $CT->des("hlink:$hl0")->qx =~ /->\s+\S+@(\S+)$/;
if ($mvob ne $vob) {
$arg =~ s/@\Q$vob\E$/\@$mvob/;
$targ =~ s/@\Q$vob\E$/\@$mvob/;
$bl =~ s/@\Q$vob\E$/\@$mvob/;
$lbl =~ s/@\Q$vob\E$/\@$mvob/;
$vob = $mvob;
}
for (@hl) { push @vobs, $1 if /<-\s+\S+@(\S+)$/; }
}
}
if (!$opt{force}) {
# Note: cleartool runs in Windows mode when we are on Cygwin
my @nolog = (MSWIN or CYGWIN)? qw(-log NUL) : qw(-log /dev/null);
my $hmrg;
for my $v ($vob, @vobs) {
if ($CT->findmerge($v, '-fve', $bl, @nolog, '-print')->stderr(0)->qx) {
$hmrg = 1;
last;
}
}
die Msg('E', 'Home merge (rebase) needed') if $hmrg;
}
if ($sil->des(['-s'], $lbl)->system) {
my @opt = @cmt;
push @opt, '-glo' if @vobs;
_Wrap(qw(mklbtype -fam), @opt, $lbl) and die "\n";
for (@vobs) {
my $dst = $lbl;
$dst =~ s/@\Q$vob\E$/\@$_/;
_Wrap('cptype', $lbl, $dst); #Fails if the type existed in one vob
}
} else {
if ($CT->des([qw(-s -ahl), $EQHL], $lbl)->qx) {
die Msg('E', 'The baseline is not locked: conflicting rollout pending?')
if $ClearCase::Wrapper::MGi::lockbl and !$CT->lslock(['-s'], $lbl)->qx;
_Wrap(qw(mklbtype -inc), @cmt, $lbl) and die "\n";
} else {
die Msg('E', 'The baseline type must be a family type');
}
}
my $la = $arg; $la =~ s/\@.*$//; # Local name: vob in $lbl
my $lb = $bl; $lb =~ s/\@.*$//;
my $cwd = getcwd;
my $rc = 0;
for my $v ($vob, @vobs) {
$CT->cd($v)->system;
$rc += _Wrap(qw(mklabel -over), $la, $lb, $v);
}
_Wrap('lock', $lbl) if $ClearCase::Wrapper::MGi::lockbl;
exit $rc if $rc; #nothing to fallback to, so avoid
$CT->cd($cwd)->system;
if ($bt) {
$rc = _Wrap(qw(mkbrtype -nc -arc), $arg);
} else {
my @bt = grep s/^-> //, $CT->des([qw(-s -ahl), $STHL], "lbtype:$arg")->qx;
if (@bt) {
my $tag = ViewTag();
die Msg('E', "view tag cannot be determined") unless $tag;;
my($vws) = reverse split '\s+', $CT->lsview($tag)->qx;
my @cs = ();
no warnings qw(once);
*::push2cs = sub {chomp; s/\#.*//; push @cs, $_};
Burrow('CATCS_00', "$vws/config_spec", '::push2cs');
my @abt = ();
for my $bt (@bt) {
my $t = $1 if $bt =~ /^brtype:(.*?)(\@.*)?$/;
push @abt, $bt if grep /\b\Q$t\E\b/, @cs;
}
_Wrap(qw(mkbrtype -nc -arc), @abt) if @abt;
}
$rc = _Wrap(qw(mklbtype -nc -arc), $arg);
}
exit $rc;
}
=item * ROLLBACK
New command. Roll back to a previous increment.
This is in effect a new rollout, and will result in a new increment of
the baseline family label type.
The change set required as argument is a fixed incremental label type.
=cut
sub rollback {
use strict;
use warnings;
use Sys::Hostname;
use File::Path qw(remove_tree);
use Cwd;
my %opt;
GetOptions(\%opt, qw(force to=s comment=s));
Note: the result is significantly (~5x) slower, when the standard
command works.
=cut
sub lstype {
use strict;
use warnings;
my $lst = ClearCase::Argv->new(@ARGV);
$lst->parse(qw(local long|short|nostatus fmt=s obsolete kind=s invob=s
unsorted));
return 0 if $lst->flag('local') or $lst->flag('long') and $lst->flag('fmt')
or !$lst->flag('kind') or $lst->flag('kind') ne 'lbtype'
or (grep/^-[ls]|nos/, $lst->opts) > 1;
$CT = new ClearCase::Argv({autochomp=>1});
my $v = $lst->flag('invob') || '.';
return 0 if $CT->des([qw(-s -ahl AdminVOB)], "vob:$v")->qx;
my (@lopts, @dopts) = ();
push @lopts, qw(-local -kind lbtype -nostatus),
grep{defined} ($lst->flag('obsolete') and '-obs'),
($lst->flag('invob') and ('-invob', $lst->flag('invob'))),
($lst->flag('unsorted') and '-uns');
my $sil = $CT->clone({stderr=>0});
my $err = $CT->clone({stdout=>0, stderr=>1});
my $lock = !grep /-nos/, $lst->opts;
my $fmt = $lst->flag('fmt');
push @dopts, grep{defined} grep(/^-[sl]/, $lst->opts), $fmt && ('-fmt', $fmt);
push @dopts, '-s' unless $lock; #i.e. if -nostatus
$lst->opts(@lopts);
my $ext = $lst->flag('invob')? '@' . $lst->flag('invob') : '';
my $cb = sub {
my $t = shift; $t =~ y/\r//d; chomp $t;
my $lbt = "lbtype:${t}$ext";
if (my $e = $err->des(['-s'], $lbt)->qx) {
if (my @l = grep{s/^\s+(G.*?)\s.*$/hlink:$1/}
$CT->des([qw(-l -local -ahl GlobalDefinition)], $lbt)->qx) {
my %oid;
for ($CT->dump($l[0])->qx) {
$oid{$1} = $2 if /^\s+to (\w+)=(.*)$/;
}
if ($oid{vob} and $oid{obj}) {
my $vob = $sil->lsvob([qw(-s -fam), $oid{vob}])->qx;
if ($vob) {
my $obj = $sil->des(['-s'], "oid:$oid{obj}\@$vob")->qx;
if (!$obj) {
warn Msg('W', "Could not find the global definition of "
. "'$t' in '$vob'. Synchronization issue?");
return 1;
}
} else {
warn Msg('W', "Could not find the vob containing the "
. "global definition for '$t': $oid{vob}");
return 1;
}
}
}
print STDERR "$e\n";
} else {
my @opts = ($lock and $CT->lslock(['-s'], $lbt)->qx)?
('-fmt', '%n (%[locked]p)\n') : @dopts;
$CT->des([@opts], $lbt)->system;
}
return 1; #continue
};
$lst->pipecb($cb);
$lst->pipe; # no fallback!
exit 0;
}
=item * ANNOTATE
This implementation serves two purposes:
=over 2
=item - fix some errors resulting from our breaking a tool assumption
=item - provide a greppable standard output
=back
The default behaviour assumes that related changes all took place
within the same I<line of descent> (i.e. physical branch hierarchy).
This assumption is defeated in the case of the I<BranchOff> strategy,
with which ancestors are typically merged from branches outside this
line of descent.
The C<-all> flag allows to examine changes beyond the line of descent,
but results in spurious C<UNRELATED> annotations (C<Merge> arrows are
ignored at large, although they clearly I<relate> changes...)
In the context of the I<source container layout fixing>, the
assumption results in spurious errors, when the version referenced is
outside the line of descent, even if otherwise perfectly valid.
The wrapper forces the injection of the C<-all> flag for files, and
resorts to lshistory for directories.
As C<Merge> arrows are ignored, the reference version for a new branch
spawned off the root of the tree is systematically empty (unless
fixing the layout of source containers).
This is the reference towards which changes are reported. It results
that the same lines are reported as added multiple times.
Better fixing of the problems described above is only provided in the
context of the additional options below.
The default behaviour of C<annotate> is file oriented. The file
produced is of a verbose format, which would contain long lines. These
ones are thus truncated.
This defeats most of the usefulness of the tool.
One offers two alternative new flags to produce line oriented output:
=over 2
=item -line: line oriented output suitable for grepping, with no truncation
The default is changed from the original I<synctree> because the
I<reuse> option tends to bring in hidden directories which may have
wrong protections. Such errors are thus not infrequent, and the
cleanup makes them cumbersome to fix.
=back
=cut
sub synctree {
use strict;
use warnings;
use ClearCase::SyncTree 0.60; #warning: sort interpreted as function
use Benchmark;
use Cwd;
my %opt;
GetOptions(\%opt, qw(from=s summary label=s comment=s force rollback));
die Msg("-force and -rollback are mutually exclusive")
if $opt{force} and $opt{rollback};
Assert(@ARGV > 1); # die with usage msg if untrue
shift @ARGV;
my @argv = ();
for (@ARGV) {
$_ = readlink if -l && defined readlink;
push @argv, MSWIN ? glob($_) : $_;
}
ClearCase::Argv->inpathnorm(0);
if ($opt{summary}) {
$Benchstart = new Benchmark;
ClearCase::Argv->summary; # start keeping stats
END {
if ($Benchstart) {
# print out the stats we kept
print STDERR ClearCase::Argv->summary;
# show timing data
my $timing = timestr(timediff(new Benchmark, $Benchstart));
print "Elapsed time: $timing\n";
}
}
}
my $sync = ClearCase::SyncTree->new;
if (@argv == 1 and (-d $argv[0] or ! -e $argv[0])) {
$opt{dbase} = $sync->dstbase($argv[0]);
@argv = ();
} else {
$opt{dbase} = $sync->dstbase(dirname($argv[0]));
}
die Msg('E', "no such directory $opt{from}") unless -d $opt{from};
$opt{sbase} = Cwd::realpath($opt{from});
$opt{sbase} =~ s%\\%/%g if MSWIN;
ClearCase::Argv->quiet(1) if $opt{quiet};
if ($opt{label}) {
my $ct = $sync->clone_ct({autofail=>0, stderr=>0});
my $dvob = $ct->des(['-s'], "vob:$opt{dbase}")->qx;
my $lbtype = "lbtype:$opt{label}\@$dvob";
$sync->lblver($opt{label}) if $opt{vreuse} && $ct->des(['-s'], $lbtype)->qx;
my ($inclb) = grep s/-> (lbtype:.*)$/$1/,
$ct->des([qw(-s -ahl EqInc)], $lbtype)->qx;
if ($inclb) {
die "$prog: Error: incremental label types must be unlocked\n"
if $ct->lslock(['-s'], $lbtype, $inclb)->qx;
$inclb =~ s/^lbtype:(.*)@.*$/$1/;
$sync->inclb($inclb);
}
}
{
my @src;
if (@argv) {
my @abort;
for my $arg (@argv) {
if (-r $arg) {
my $real = Cwd::realpath($arg);
$real = $sync->normalize($real);
if ($real =~ s/^\Q$opt{dbase}\E/$opt{sbase}/ and -r $real) {
push @src, $real;
next;
}
}
push @abort, $arg;
}
die Msg('E', "argument" . (@abort > 1? 's' : '') . " not found:\n "
. join("\n ", @abort)) if @abort;
} else {
push @src, $opt{sbase};
}
local $SIG{__WARN__} = sub { die Msg('E', @_) };
my %cfg;
$cfg{wanted} = \&_Wanted;
find(\%cfg, $_) for @src;
}
$sync->reuse(1);
$sync->vreuse(1) if $opt{label};
$sync->dstcheck;
my $rc = 0;
$sync->err_handler(sub {exit 2}) unless $opt{cleanup} or $opt{force};
$sync->err_handler(\$rc) if $opt{force};
$opt{comment} = 'imported with "ct synctree"' unless $opt{comment};
$sync->comment($opt{comment});
$sync->srcbase($opt{sbase});
$sync->srcmap(%Xfer);
$sync->remove(1) unless @argv;
$sync->rellinks(1);
$sync->analyze;
$sync->rmdirlinks;
$sync->add;
$sync->modify;
$sync->subtract unless @argv;
$sync->label($opt{label}) if $opt{label};
exit $rc unless $sync->get_addhash || $sync->get_modhash
|| $sync->get_sublist || $sync->_lsco;
$sync->err_handler(\$rc);
if ($ENV{FSCBROKER}) {
require ClearCase::FixSrcCont; #optional fix of source container
my $ct = $sync->clone_ct({autofail=>0});
for ($ct->lsco([qw(-cview -me -a -fmt), '%PVn %[hlink:Merge]p\n'],
$opt{dbase})->qx) {
next unless m%^\S+/0 "Merge\@.*?" <- "(.*?)"%;
ClearCase::FixSrcCont::add2fix($1);
}
ClearCase::FixSrcCont::runfix();
( run in 2.037 seconds using v1.01-cache-2.11-cpan-5a3173703d6 )