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
=item 1. New B<-expand> flag
Follows all include statements recursively in order to print a complete
config spec. When used with the B<-cmnt> flag, comments are stripped
from this listing.
=item 2. New B<-sources> flag
Prints all files involved in the config spec (the I<config_spec> file
itself plus any files it includes).
=item 3. New B<-attribute> flag
This introduces the concept of user-defined I<view attributes>. A view
attribute is a keyword-value pair embedded in the config spec using the
conventional notation
##:Keyword: value ...
}
=item * MOUNT
This is a Windows-only enhancement: on UNIX, I<mount> behaves correctly
and we do not mess with its behavior. On Windows, for some bonehead
reason I<cleartool mount -all> gives an error for already-mounted VOBs;
these are now ignored as on UNIX. At the same time, VOB tags containing
I</> are normalized to I<\> so they'll match the registry, and an
extension is made to allow multiple VOB tags to be passed to one
I<mount> command.
=cut
sub mount {
return 0 if !MSWIN || @ARGV < 2;
my %opt;
GetOptions(\%opt, qw(all));
my $mount = ClearCase::Argv->new(@ARGV);
$mount->autofail(1);
$mount->parse(qw(persistent options=s));
die Msg('E', qq(Extra arguments: "@{[$mount->args]}"))
if $mount->args && $opt{all};
my @tags = $mount->args;
my $lsvob = ClearCase::Argv->lsvob(@tags);
# The set of all known public VOBs.
my @public = grep /\spublic\b/, $lsvob->qx;
# The subset which are not mounted.
my @todo = map {(split /\s+/)[1]} grep /^\s/, @public;
# If no vobs are mounted, let the native mount -all proceed.
if ($opt{all} && @public == @todo) {
push(@ARGV, '-all');
return 0;
}
# Otherwise mount what's needed one by one.
for (@todo) {
$mount->args($_)->system;
}
exit 0;
}
=item * PROTECTVIEW
Modifies user or group permissions for one or more views.
Analogous to the native ClearCase command I<protectvob> (see).
Most flags accepted by B<protectview> behave similarly to those
of I<protectvob>.
The B<-replace> flag is special; it uses the administrative I<fix_prot>
tool to completely replace any pre-existing identity information. This
gives the view's permissions a "clean start"; in particular, any grants
of access to other groups will be removed.
This operation will not work on a running view. Views must be
manually stopped with C<endview -server> before reprotection may proceed.
B<Warning>: this is an experimental interface which has not been tested
in all scenarios. It cannot destroy any data, so there's nothing it
could break which could't be fixed with an administrator's help, but it
should still be used with care. In particular, it's possible to
specify values to B<-chmod> which will confuse the view greatly.
=cut
sub protectview {
die Msg('E', "not yet supported on Windows") if MSWIN;
my %opt;
GetOptions(\%opt, qw(force replace tag=s add_group=s delete_group=s
chown=s chgrp=s chmod=s));
my $cmd = shift @ARGV;
if ($opt{tag}) {
Assert(@ARGV == 0); # -tag and vws area are mutually exclusive
my($vws) = (split ' ', ClearCase::Argv->lsview($opt{tag})->qx)[-1];
push(@ARGV, $vws);
}
Assert(@ARGV > 0); # die with usage msg if no vws area specified
Assert(scalar %opt, 'no options specified');
die Msg('E', "$cmd -chown requires administrative privileges")
if $opt{chown} && $> != 0;
my $rc = 0;
for my $vws (@ARGV) {
my $idedir = "$vws/.identity";
if (! -f "$vws/config_spec" || ! -d $idedir) {
warn Msg('W', "not a view storage area: $vws");
$rc = 1;
next;
}
if (! $opt{force}) {
my $prompt = qq(Protect view "$vws"?);
require ClearCase::ClearPrompt;
next if ClearCase::ClearPrompt::clearprompt(
qw(yes_no -def n -type ok -pro), $prompt);
}
if (-e "$vws/.pid") {
if ($opt{force}) {
my $tag = $opt{tag};
$tag ||= ClearCase::Argv->lsview([qw(-s -storage)], $vws)->qx;
chomp $tag;
ClearCase::Argv->endview([qw(-server)], $tag)->system;
}
if (-e "$vws/.pid") {
warn Msg('W', "cannot protect running view $vws");
$rc = 1;
next;
}
}
if ($opt{chown} || $opt{chgrp} || $opt{chmod}) {
my $uid = $opt{chown} || (stat "$idedir/uid")[4];
$uid = (getpwnam($uid))[2] unless $uid =~ /^\d+$/;
my $gid = $opt{chgrp} || (stat "$idedir/gid")[5];
$gid = (getgrnam($gid))[2] unless $gid =~ /^\d+$/;
if ($opt{replace}) {
my $fp = Argv->new('/usr/atria/etc/utils/fix_prot');
$fp->opts(qw(-root -recurse));
$fp->opts($fp->opts, '-force') if $opt{force};
$fp->opts($fp->opts, '-chown', $uid);
$fp->opts($fp->opts, '-chgrp', $gid);
$fp->opts($fp->opts, '-chmod', $opt{chmod}) if $opt{chmod};
$fp->args($vws);
if ($fp->system) {
$rc = 1;
next;
}
} else {
if ($opt{chown} || $opt{chgrp}) {
unlink("$idedir/group.$gid") if $opt{chgrp};
if (Argv->chown([qw(-R -h)], "$uid:$gid", $vws)->system) {
$rc = 1;
next;
}
}
if ($opt{chmod}) {
if (Argv->chmod(['-R'], $opt{chmod}, $vws)->system) {
$rc = 1;
next;
}
for my $grp (glob("$idedir/group.*")) {
chmod(0102410, $grp) || warn Msg('W', "$grp: $!");
}
}
chmod(0104400, "$idedir/uid") ||
warn Msg('W', "$idedir/uid: $!");
chmod(0102410, "$idedir/gid") ||
warn Msg('W', "$idedir/gid: $!");
}
}
if ($opt{delete_group}) {
for (split ',', $opt{delete_group}) {
my $gid = /^\d+$/ ? $_ : (getgrnam($_))[2];
if (! $gid) {
warn Msg('W', "no such group: $_");
$rc = 1;
next;
}
my $grp = "$idedir/group.$gid";
unlink($grp);
}
}
if ($opt{add_group}) {
for (split ',', $opt{add_group}) {
my $gid = /^\d+$/ ? $_ : (getgrnam($_))[2];
if (! $gid) {
warn Msg('W', "no such group: $_");
$rc = 1;
next;
}
my $grp = "$idedir/group.$gid";
unlink($grp);
if (! open(GID, ">$grp")) {
warn Msg('W', "$vws: unable to add group $_");
$rc = 1;
next;
}
close(GID);
if (! chown(-1, $gid, $grp) || ! chmod(0102410, $grp)) {
warn Msg('W', "$vws: unable to add group $_: $!");
$rc = 1;
next;
}
}
}
}
exit($rc);
}
=item * RECO/RECHECKOUT
Redoes a checkout without the database operations by simply copying the
contents of the existing checkout's predecessor over the view-private
checkout file. The previous contents are moved aside to "<element>.reco".
The B<-keep> and B<-rm> options are honored by analogy with I<uncheckout>.
=cut
sub recheckout {
my %opt;
GetOptions(\%opt, qw(keep rm));
shift @ARGV;
require File::Copy;
for (@ARGV) {
$_ = readlink if -l && defined readlink;
if (! -w $_) {
warn Msg('W', "$_: not checked out");
next;
}
my $pred = Pred($_, 1);
my $keep = "$_.reco";
unlink $keep;
if (rename($_, $keep)) {
if (File::Copy::copy($pred, $_)) {
my $mode = (stat $keep)[2];
chmod $mode, $_;
} else {
die Msg('E', (-r $_ ? $keep : $_) . ": $!");
}
} else {
die Msg('E', "cannot rename $_ to $keep: $!");
}
unlink $keep if $opt{rm};
}
exit 0;
}
=item * RMELEM
It appears that when elements are removed with I<rmelem> they often
remain visible for quite a while due to some kind of view cache,
though attempts to actually open them result in an I/O error. Running
I<cleartool setcs -current> clears this up. Thus I<rmelem> is
overridden here to add an automatic view refresh when done.
=cut
sub rmelem {
my $rc = ClearCase::Argv->new(@ARGV)->system;
ClearCase::Argv->setcs(['-current'])->system unless $rc;
exit($rc >> 8);
}
=item * SETCS
Adds a B<-clone> flag which lets you specify another view from which to copy
the config spec.
Adds a B<-sync> flag. This is similar to B<-current> except that it
analyzes the CS dependencies and only flushes the view cache if the
I<compiled_spec> file is out of date with respect to the I<config_spec>
source file or any file it includes. In other words: B<setcs -sync> is
to B<setcs -current> as B<make foo.o> is to B<cc -c foo.c>.
Adds a B<-needed> flag. This is similar to B<-sync> above but it
doesn't recompile the config spec. Instead, it simply indicates with
its return code whether a recompile is in order.
Adds a B<-expand> flag, which "flattens out" the config spec by
inlining the contents of any include files.
=cut
sub setcs {
my %opt;
GetOptions(\%opt, qw(clone=s expand needed sync));
die Msg('E', "-expand and -sync are mutually exclusive")
if $opt{expand} && $opt{sync};
die Msg('E', "-expand and -needed are mutually exclusive")
if $opt{expand} && $opt{needed};
my $tag = ViewTag(@ARGV) if grep /^(expand|sync|needed|clone)$/, keys %opt;
if ($opt{expand}) {
my $ct = Argv->new([$^X, '-S', $0]);
my $settmp = ".$::prog.setcs.$$";
open(EXP, ">$settmp") || die Msg('E', "$settmp: $!");
print EXP $ct->opts(qw(catcs -expand -tag), $tag)->qx;
The list of files to convert may be derived via
B<-dir/-rec/-all/-avobs>, provided in a file containing a list of files
with B<-flist>, or specified as a literal list of view-private files.
When using B<-dir/-rec/-all/-avobs> to derive the file list only the
output of C<lsprivate -other> is considered unless B<-do> is used;
B<-do> causes existing DO's to be re-converted. Use B<-do> with care as
it may convert a useful CR to a meaningless one.
The B<"-flist -"> flag can be used to read the file list from stdin,
which may be useful in a script.
=cut
sub winkout {
warn Msg('E', "this may work on &%@# Windows but I haven't tried") if MSWIN;
my %opt;
GetOptions(\%opt, qw(directory recurse all avobs flist=s
do meta=s print promote));
my $ct = ClearCase::Argv->new({-autochomp=>1, -syfail=>1});
my $dbg = Argv->dbglevel;
my $cmd = shift @ARGV;
my @list;
if (my @scope = grep /^(dir|rec|all|avo|f)/, keys %opt) {
die Msg('E', "mutually exclusive flags: @scope") if @scope > 1;
if ($opt{flist}) {
open(LIST, $opt{flist}) || die Msg('E', "$opt{flist}: $!");
@list = <LIST>;
close(LIST);
} else {
my @type = $opt{'do'} ? qw(-other -do) : qw(-other);
@list = Argv->new([$^X, '-S', $0, 'lsp'],
['-s', @type, "-$scope[0]"])->qx;
}
} else {
@list = @ARGV;
}
chomp @list;
my %set = map {$_ => 1} grep {-f}
grep {!m%\.(?:mvfs|nfs)\d+|cmake\.state%} @list;
exit 0 if ! %set;
if ($opt{'print'}) {
for (keys %set) {
print $_, "\n";
}
print $opt{meta}, "\n" if $opt{meta};
exit 0;
}
# Shared DO's should be g+w!
(my $egid = $)) =~ s%\s.*%%;
for (keys %set) {
my($mode, $uid, $gid) = (stat($_))[2,4,5];
if (!defined($mode)) {
warn Msg('W', "no such file: $_");
delete $set{$_};
next;
}
next if $uid != $> || ($mode & 0222) || ($mode & 0220 && $gid == $egid);
chmod(($mode & 07777) | 0220, $_);
}
my @dolist = sort keys %set;
# Add the -meta file to the list of DO's if specified.
if ($opt{meta}) {
if ($dbg) {
my $num = @dolist;
print STDERR "+ associating $num files with $opt{meta} ...\n";
}
open(META, ">$opt{meta}") || die Msg('E', "$opt{meta}: $!");
for (@dolist) { print META $_, "\n" }
close(META);
push(@dolist, $opt{meta});
}
# Convert regular view-privates into DO's by opening them
# under clearaudit control.
{
my $clearaudit = MSWIN ? 'clearaudit' : '/usr/atria/bin/clearaudit';
local $ENV{CLEARAUDIT_SHELL} = $^X;
my $ecmd = 'chomp; open(DO, ">>$_") || warn "Error: $_: $!\n"';
my $cmd = qq($clearaudit -n -e '$ecmd');
$cmd = "set -x; $cmd" if $dbg && !MSWIN;
open(AUDIT, "| $cmd") || die Msg('E', "$cmd: $!");
for (@dolist) {
print AUDIT $_, "\n";
print STDERR $_, "\n" if $dbg;
}
close(AUDIT) || die Msg('E', $! ?
"Error closing clearaudit pipe: $!" :
"Exit status @{[$?>>8]} from clearaudit");
}
if ($opt{promote}) {
my $scrubber = MSWIN ? 'view_scrubber' : '/usr/atria/etc/view_scrubber';
my $cmd = "$scrubber -p";
$cmd = "set -x; $cmd" if $dbg && !MSWIN;
open(SCRUBBER, "| $cmd") || die Msg('E', "$scrubber: $!");
for (@dolist) { print SCRUBBER $_, "\n" }
close(SCRUBBER) || die Msg('E', $! ?
"Error closing $scrubber pipe: $!" :
"Exit status $? from $scrubber");
}
exit 0;
}
=item * WORKON
New command, similar to I<setview> but provides hooks to cd to a
preferred I<initial working directory> within the view and to set
up any required environment variables. The I<initial working directory>
is defined as the output of B<ct catcs -start> (see).
If a file called I<.viewenv.pl> exists in the I<initial working
directory>, it's read before starting the user's shell. This file uses
Perl syntax and must end with a "1;" like any C<require-d> file. Any
unrecognized arguments given to I<workon> following the view name will
be passed on to C<.viewenv.pl> in C<@ARGV>. Environment variables
required for builds within the setview may be set here.
=cut
sub workon {
( run in 0.574 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )