ClearCase-Wrapper-MGi
view release on metacpan or search on metacpan
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
=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.
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);
_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>
(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+(.*)%) {
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') {
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) {
=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>.
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;
} 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
$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) {
extra/Configuration.pod view on Meta::CPAN
This setting drives I<mklbtype> and I<mkbrtype> to create I<global>
types (including the metadata types) in vobs having an admin vob.
This used to be the default with I<ClearCase::Wrapper::DSB>.
Next possible setting:
$ClearCase::Wrapper::MGi::lockbl = 1;
If this is set, the baseline type is locked in the end of a rollout.
Conversely, a next rollout is aborted if the baselin is found unlocked on
entry, in order to prevent possible collisions of independent rollouts.
This would be the default if locking/unlocking by group members was
supported natively by ClearCase, instead of depending on user configuration.
Note that one might e.g. add there code such as:
umask(002);
This ensures that under cleartool (from the wrapper), group members
are granted write access e.g. to directory elements being created.
extra/Examples.pod view on Meta::CPAN
=head3 Lock the label types
$ ct lock lbtype:TTT
Locked label type "TTT".
Locked label type "TTT_1.00".
This is not mandatory of course, but it is a good idea, and it is supported.
The fixed type should not be moved anymore, so why not locking it?
The floating label will get unlocked as needed, but locking it
communicates its state to others, and leaves a timestamp (the latest
one does not get scrubbed).
=head3 Increment the label type
$ ct mklbtype -c 'Increment demo' -inc TTT
Unlocked label type "TTT".
Unlocked label type "TTT_1.00".
Created label type "TTT_1.01".
Locked label type "TTT_1.00".
A new incremental fixed label is created.
It gets linked to the previous one, which is thus unlocked,
and locked back.
=head3 Make a change, and label incrementally
$ ct co -nc a/foo
Checked out "a/foo" from version "/main/tt/1".
$ ct ci -nc -ide a/foo
Checked in "a/foo" version "/main/tt/2".
$ ct mklabel -over tt TTT .
Created label "TTT_1.01" on "a/foo" version "/main/tt/2".
Moved label "TTT" on "a/foo" from version "/main/tt/1" to "/main/tt/2".
extra/updtlink view on Meta::CPAN
usage("Unknown account: $user") unless getpwnam($user);
my $vbown = $ct->argv(qw(des -fmt), '%[owner]p', "vob:$vob")->qx;
$vbown =~ s%^.*/(.*)%$1%;
my $account = (getpwuid($<))[0];
usage("Not vob owner ($vbown): $account") unless $account eq $vbown;
map { $_ = "lbtype:$_\@$vob" } @lbtype;
usage if $ct->argv(qw(des -s), @lbtype)->stdout(0)->system;
my ($pair) = grep s/^\s*(.*) -> (lbtype:.*)$/$1,$2/,
$ct->argv(qw(des -l -ahl), EQHL, $lbtype[0])->stderr(0)->qx;
my ($hlk, $prev) = split(/,/, $pair) if $pair;
$ct->argv('unlock', $lbtype[0])->stderr(0)->system; #Ignore failure: not locked
$ct->argv('mkhlink', EQHL, @lbtype)->system and die;
if ($prev) {
no warnings 'qw';
my $now = strftime '%d-%b-%Y.%H:%M:%S', localtime;
my ($ts, $lu) = split(/,/,
$ct->argv(qw(lslock -fmt %Nd,%u), $prev)->stderr(0)->qx);
my @dt = $ts =~ /^(\d{4})(\d{2})(\d{2})\.(\d{2})(\d{2})(\d{2})$/;
$ts = join('-', $dt[2], $mon[$dt[1] - 1], $dt[0]) . '.' .
join(':', @dt[3..5]);
$ct->argv('unlock', $prev)->system;
( run in 1.062 second using v1.01-cache-2.11-cpan-49f99fa48dc )