ClearCase-Wrapper-DSB
view release on metacpan or search on metacpan
package ClearCase::Wrapper::DSB;
$VERSION = '1.14';
use AutoLoader 'AUTOLOAD';
use strict;
#############################################################################
# Usage Message Extensions
#############################################################################
{
local $^W = 0;
no strict 'vars';
# Usage message additions for actual cleartool commands that we extend.
$catcs = "\n* [-cmnt|-expand|-sources|-start]";
$describe = "\n* [--par/ents <n>]";
$lock = "\n* [-allow|-deny login-name[,...]] [-iflocked]";
$lsregion = "\n* [-current]";
$mklabel = "\n* [-up]";
$setcs = "\n* [-clone view-tag] [-expand] [-sync|-needed]";
$setview = "\n* [-me] [-drive drive:] [-persistent]";
$update = "\n* [-quiet]";
$winkin = "\n* [-vp] [-tag view-tag]";
# Usage messages for pseudo cleartool commands that we implement here.
# Note: we used to localize $0 but that turns out to trigger a bug
# in perl 5.6.1.
my $z = (($ARGV[0] eq 'help') ? $ARGV[1] : $ARGV[0]) || '';
$comment = "$z [-new] [-element] object-selector ...";
$diffcs = "$z view-tag-1 [view-tag-2]";
$eclipse = "$z element ...";
$edattr = "$z [-view [-tag view-tag]] | [-element] object-selector ...";
$grep = "$z [grep-flags] pattern element";
$protectview = "$z [-force] [-replace]"
. "\n[-chown login-name] [-chgrp group-name] [-chmod permissions]"
. "\n[-add_group group-name[,...]]"
. "\n[-delete_group group-name[,...]]"
. "\n{-tag view-tag | view-storage-dir-pname ...}";
$recheckout = "$z [-keep|-rm] pname ...";
$winkout = "$z [-dir|-rec|-all] [-f file] [-pro/mote] [-do]"
. "\n[-meta file [-print] file ...";
$workon = "$z [-me] [-login] [-exec command-invocation] view-tag";
}
#############################################################################
# Command Aliases
#############################################################################
*des = *describe;
*desc = *describe;
*edcmnt = *comment;
*egrep = *grep;
*mkbrtype = *mklbtype; # not synonyms but the code's the same
*reco = *recheckout;
*work = *workon;
1;
__END__
=head1 NAME
ClearCase::Wrapper::DSB - David Boyce's contributed cleartool wrapper functions
=head1 SYNOPSIS
This is an C<overlay module> for B<ClearCase::Wrapper> containing David
Boyce's non-standard extensions. See C<perldoc ClearCase::Wrapper> for
more details.
=head1 CLEARTOOL ENHANCEMENTS
=over 4
=item * CATCS
=over 4
sub describe {
my $desc = ClearCase::Argv->new(@ARGV);
$desc->optset(qw(CC WRAPPER));
$desc->parseCC(qw(g|graphical local l|long s|short
fmt=s alabel=s aattr=s ahlink=s ihlink=s
cview version=s ancestor
predecessor pname type=s cact));
$desc->parseWRAPPER(qw(parents|par9999=s));
my $generations = abs($desc->flagWRAPPER('parents') || 0);
if ($generations) {
my $pred = ClearCase::Argv->desc([qw(-fmt %En@@%PVn)]);
$pred->autofail(1);
my @nargs;
my @args = $desc->args;
for my $arg (@args) {
my $narg = $arg;
for (my $i = $generations; $i; $i--) {
$narg = $pred->args($narg)->qx;
}
push(@nargs, $narg);
}
$desc->args(@nargs);
}
$desc->exec('CC');
}
=item * DIFFCS
New command. B<Diffcs> dumps the config specs of two specified views
into temp files and diffs them. If only one view is specified, compares
against the current working view's config spec.
=cut
sub diffcs {
my %opt;
GetOptions(\%opt, qw(tag=s@));
my @tags = @{$opt{tag}} if $opt{tag};
push(@tags, @ARGV[1..$#ARGV]);
if (@tags == 1) {
my $cwv = ViewTag();
push(@tags, $cwv) if $cwv;
}
die Msg('E', "two view-tag arguments required") if @tags != 2;
my $ct = ClearCase::Argv->find_cleartool;
my @cstmps = map {"$_.cs"} @tags;
for my $i (0..1) {
Argv->new("$ct catcs -tag $tags[$i] >$cstmps[$i]")->autofail(1)->system;
}
Argv->new('diff', @cstmps)->dbglevel(1)->system;
unlink(@cstmps);
exit 0;
}
=item * ECLIPSE
New command. B<Eclipse>s an element by copying a view-private version
over it. This is the dynamic-view equivalent of "hijacking" a file in a
snapshot view. Typically of use if you need temporary write access to a
file when the VOB or current branch is locked, or it's checked out
reserved. B<Eclipsing elements can lead to dangerous confusion - use
with care!>
=cut
sub eclipse {
require File::Copy;
Assert(@ARGV > 1); # die with usage msg if untrue
shift @ARGV; # dump the cmd name leaving only the elems to eclipse
# Create a cleartool object.
my $ct = ClearCase::Argv->new;
# Retrieve the original config spec.
my @orig = $ct->catcs->qx;
exit 2 if $?;
my $retstat = 0;
for my $elem (@ARGV) {
if (! -f $elem || -w _) {
warn Msg('W', "don't know how to eclipse '$elem'");
$retstat++;
next;
}
# Make a config spec template that hides the to-be-eclipsed elem.
my $cstmp = ".$::prog.eclipse.$$";
open(CSTMP, ">$cstmp") || die Msg('E', "$cstmp: $!");
print CSTMP "element $elem -none\n";
print CSTMP @orig;
close(CSTMP) || die Msg('E', "$cstmp: $!");
# Copy the element aside before it gets hidden.
my $eltmp = "$elem.eclipse.$$";
if (! File::Copy::copy($elem, $eltmp)) {
warn Msg('W', "$elem: $!");
$retstat++;
next;
}
# Now set the modified config spec to hide the element.
if ($ct->setcs($cstmp)->system) {
unlink $eltmp;
$retstat++;
next;
}
# Copy the copy back to its original place. It will become
# writeable as a side effect.
if (! File::Copy::copy($eltmp, $elem)) {
warn Msg('W', "$elem: $!");
$retstat++;
}
unlink $eltmp;
# Now set the config spec back to what it was and we're done.
open(CSTMP, ">$cstmp") || die Msg('E', "$cstmp: $!");
print CSTMP @orig;
close(CSTMP) || die Msg('E', "$cstmp: $!");
unlink $edtmp;
# Now, delete any attrs that were deleted from the temp file.
# First we do a simple rmattr; then see if it was the last of
# its type and if so remove the type too.
for (sort keys %indata) {
if ($ct->rmattr($_, $obj)->system) {
$retstat++;
} else {
# Don't remove the type if its vob serves as an admin vob!
my @deps = grep /^<-/,
$ct->desc([qw(-s -ahl AdminVOB)], 'vob:.')->qx;
next if $? || @deps;
$ct->rmtype(['-rmall'], "attype:$_")->system;
}
}
}
exit $retstat;
}
=item * GREP
New command. Greps through past revisions of a file for a pattern, so
you can see which revision introduced a particular function or a
particular bug. By analogy with I<lsvtree>, I<grep> searches only
"interesting" versions unless B<-all> is specified. I<Note that
this will expand cleartext for all grepped versions>.
Flags B<-nnn> are accepted where I<nnn> represents the number of versions
to go back. Thus C<grep -1 foo> would search only the predecessor.
=cut
sub grep {
my %opt;
GetOptions(\%opt, 'all');
my $elem = pop(@ARGV);
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 $lsvt = ClearCase::Argv->new('lsvt', ['-s'], $elem);
$lsvt->opts('-all', $lsvt->opts) if $opt{all} || $limit > 1;
chomp(my @vers = sort {($b =~ m%/(\d+)%)[0] <=> ($a =~ m%/(\d+)%)[0]}
grep {m%/\d+$%} $lsvt->qx);
exit 2 if $?;
splice(@vers, $limit) if $limit;
splice(@ARGV, 0, 1, 'egrep');
Argv->new(@ARGV, @vers)->dbglevel(1)->exec;
}
=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.
=cut
sub lock {
my %opt;
GetOptions(\%opt, qw(allow=s deny=s iflocked));
return 0 unless %opt;
my $lock = ClearCase::Argv->new(@ARGV);
$lock->parse(qw(c|cfile=s c|cquery|cqeach nusers=s
pname=s obsolete replace));
die Msg('E', "cannot specify -nusers along with -allow or -deny")
if $lock->flag('nusers');
die Msg('E', "cannot use -allow or -deny with multiple objects")
if $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 ($opt{allow}) {
for (split /,/, $opt{allow}) { $nusers{$_} = 1 }
}
if ($opt{deny}) {
for (split /,/, $opt{deny}) { delete $nusers{$_} }
}
$lock->opts($lock->opts, '-nusers', join(',', sort keys %nusers))
if %nusers;
} elsif (!$currlock && $opt{iflocked}) {
exit 0;
} elsif ($opt{allow}) {
$lock->opts($lock->opts, '-nusers', $opt{allow});
}
$lock->opts($lock->opts, '-replace') unless $lock->flag('replace');
$lock->exec;
}
=item * LSREGION
A surprising lapse of the real cleartool CLI is that there's no
way to determine the current region. This extension adds a
B<-current> flag to lsregion.
=cut
sub lsregion {
my %opt;
# -cu999 is only to enforce -cur/rent
GetOptions(\%opt, qw(current cu999));
return 0 unless $opt{current};
if (MSWIN) {
use vars '%RegHash';
require Win32::TieRegistry;
Win32::TieRegistry->import('TiedHash', '%RegHash');
my $region = $RegHash{LMachine}->{SOFTWARE}->
{Atria}->{ClearCase}->{CurrentVersion}->{Region};
print $region, "\n";
} else {
my $regfile = '/var/adm/atria/rgy/rgy_region.conf';
open(REGFILE, $regfile) || die Msg('E', "$regfile: $!");
my $region = <REGFILE>;
close(REGFILE);
print $region;
}
exit 0;
}
=item * MKBRTYPE,MKLBTYPE
Modification: if user tries to make a type in the current VOB without
explicitly specifying -ordinary or -global, and if said VOB is
associated with an admin VOB, then by default create the type as a
global type in the admin VOB instead. B<I<In effect, this makes -global
the default iff a suitable admin VOB exists>>.
=cut
sub mklbtype {
return if grep /^-ord|^-glo|vob:/i, @ARGV;
if (my($ahl) = grep /^->/,
ClearCase::Argv->desc([qw(-s -ahl AdminVOB vob:.)])->qx) {
if (my $avob = (split /\s+/, $ahl)[1]) {
# Save aside all possible flags for mkxxtype,
# then add the vob selector to each type selector
# and add the new -global to opts before exec-ing.
my $ntype = ClearCase::Argv->new(@ARGV);
$ntype->parse(qw(replace|global|ordinary
vpelement|vpbranch|vpversion
pbranch|shared
( run in 2.225 seconds using v1.01-cache-2.11-cpan-39bf76dae61 )