ClearCase-Wrapper-MGi

 view release on metacpan or  search on metacpan

extra/FSCbrokerSsh  view on Meta::CPAN

use Net::SSH::Perl;

# This is meant to be suid enabled
# This is the version using ssh. There is an alternative version using sudo.

my $fsc ='/usr/local/bin/fixsrccont';
my $sshhost = 'my.unix.sshd.host';
my $view = 'my_view';
my $ct = '/opt/rational/clearcase/bin/cleartool';

sub ssh() {
  my ($account, $host) = @_;
  my $ssh = Net::SSH::Perl->new($host);
  $ssh->login($account);
  return $ssh;
}

sub dispatch {
  my ($owner, $arg) = @_;
  my $cmd = qq($fsc '$arg'); #dir, oid of v0, oid of branch, oid of previous
  my($out, $err, $ret) = ssh($owner, $sshhost)->cmd(

extra/ForceLock.pm  view on Meta::CPAN

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(funlocklt flocklt);

use Net::SSH::Perl;
use ClearCase::VobPathConv;

our $flk = '/usr/bin/locklbtype';
our $view = 'perl_view';
our $exec = '/opt/rational/clearcase/bin/cleartool setview -exec';
sub ssh() {
  my $host = 'my.unix.sshd.host';
  my $ssh = Net::SSH::Perl->new($host);
  my $account = getlogin || getpwuid($<)
    or die "Couldn't get the uid: $!\n";
  $ssh->login($account);
  return $ssh;
}
sub funlocklt($$) {
  my ($lt, $vob) = @_;
  $vob = winpath2ux($vob);
  my($out, $err, $ret) = ssh()->cmd(
    "$exec '$flk --unlock --vob $vob --lbtype $lt' $view");
  print STDERR join("\n", grep(/^cleartool:/, split /\n/, $err), '') if $err;
  print $out if $out;
  return $ret;
}
sub flocklt($$;$$) {
  my ($lt, $vob, $rep, $nusers) = @_;
  $vob = winpath2ux($vob);
  my $cmd = "$flk --vob $vob";
  $cmd .= " --replace" if $rep;
  $cmd .= " --nusers $nusers" if $nusers;
  my($out, $err, $ret) = ssh()->cmd("$exec '$cmd --lbtype $lt' $view");
  print STDERR join("\n", grep(/^cleartool:/, split /\n/, $err), '') if $err;
  print $out if $out;
  return $ret;
}

extra/ForceLockSudo.pm  view on Meta::CPAN

use warnings;
use strict;

our $VERSION = '0.03';
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(funlocklt flocklt);
our @forcelock = qw(sudo /opt/rational/clearcase/bin/cleartool);

sub funlocklt($$) {
  my ($lt, $vob) = @_;
  return system(@forcelock, 'unlock', "lbtype:$lt\@$vob");
}
sub flocklt($$;$$) {
  my ($lt, $vob, $rep, $nusers) = @_;
  my @fargs = (@forcelock, 'lock');
  push @fargs, '-replace' if $rep;
  push @fargs, '-nusers', $nusers if $nusers;
  return system(@fargs, "lbtype:$lt\@$vob");
}

1;

extra/ForceLockUnix.pm  view on Meta::CPAN

use warnings;
use strict;

our $VERSION = '0.02';
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(funlocklt flocklt);
our $forcelock = '/usr/bin/locklbtype';

sub funlocklt($$) {
  my ($lt, $vob) = @_;
  return system($forcelock, '--unlock', '--vob', $vob, '--lbtype', $lt);
}
sub flocklt($$;$$) {
  my ($lt, $vob, $rep, $nusers) = @_;
  my @fargs = ($forcelock, '--vob', $vob);
  push @fargs, '--replace' if $rep;
  push @fargs, '--nusers', $nusers if $nusers;
  return system(@fargs, '--lbtype', $lt);
}

1;

extra/VobPathConv.pm  view on Meta::CPAN

@EXPORT = qw(uxpath2local uxtag2local uxpath2localtag winpath2ux localtag2tgt);

ClearCase::Argv->ipc(1);
our $ct = ClearCase::Argv->new({autochomp=>1, stderr=>0});
our ($rgyhost, $locreg) = grep s/^\s+Registry (?:host|region): (.*)$/$1/,
  $ct->argv(qw(hostinfo -l))->stderr(2)->qx;
die "Couldn't access a rgy host, stopped" unless $rgyhost;
our ($unixreg) = grep s/^\s+Registry region: (.*)$/$1/,
  $ct->argv(qw(hostinfo -l), $rgyhost)->qx;

sub uxpath2local($) {
  my $path = shift;
  return $path if $locreg eq $unixreg;
  my @d = split '/', $path;
  my $i = $#d;
  while (!$ct->argv(qw(lsvob -s -reg), $unixreg, join('/', @d[0..$i]))->qx
	   and $i) { $i-- }
  return $i? join(PTHSEP, uxtag2local(join('/', @d[0..$i])), @d[++$i..$#d]):'';
}
sub uxtag2local($) {
  my $tag = shift;
  return $tag if $locreg eq $unixreg;
  my ($uuid) = grep s/^\s+Vob tag replica uuid: (.*)$/$1/,
    $ct->argv(qw(lsvob -l -reg), $unixreg, $tag)->qx;
  return $uuid? $ct->argv(qw(lsvob -s -uuid), $uuid)->qx : '';
}
sub uxpath2localtag($) {
  my $path = shift;
  my @d = split '/', $path;
  my $i = $#d;
  while (!$ct->argv(qw(lsvob -s -reg), $unixreg, join('/', @d[0..$i]))->qx
	   and $i) { $i-- }
  return $i? uxtag2local(join('/', @d[0..$i])): '';
}
sub winpath2ux($;$) {
  my ($path, $host) = @_;
  my ($tgtreg) = $host? grep s/^\s+Registry region: (.*)$/$1/,
    $ct->argv(qw(hostinfo -l), $host)->qx : ($unixreg);
  $path =~ s/[a-zA-Z]:\\+(.*)$/$1/;
  my @d = grep {length $_} split m%/|\\%, $path;
  shift @d if $ct->argv(qw(lsview -s), $d[0])->stderr(0)->qx;
  return '' unless @d;
  my ($uuid) = grep s/^\s+Vob tag replica uuid: (.*)$/$1/,
    $ct->argv(qw(lsvob -l), '\\' . shift @d)->qx;
  return '' unless $uuid;
  my $uxtag = $ct->argv(qw(lsvob -s -reg), $tgtreg, '-uuid', $uuid)->qx;
  return $uxtag? join('/', $uxtag, @d): '';
}
sub localtag2tgt($;$) {
  my ($tag, $host) = @_;
  my ($tgtreg) = $host? (grep s/^\s+Registry region: (.*)$/$1/,
    $ct->argv(qw(hostinfo -l), $host)->qx) : ($unixreg);
  return (-d $tag? $tag : '') if $locreg eq $tgtreg;
  my ($uuid) = grep s/^\s+Vob tag replica uuid: (.*)$/$1/,
    $ct->argv(qw(lsvob -l -reg), $locreg, $tag)->qx;
  return $uuid? $ct->argv(qw(lsvob -s -uuid), $uuid, '-reg', $tgtreg)->qx : '';
}
1;

extra/locklbtypessh  view on Meta::CPAN

      . "  --vob <vob> --lbtype <lbtypes> | --help\n\n"
      . "    By default, lock; use --unlock explicitely.\n"
      . "    Only one vob is accepted, and it is mandatory.\n"
      . "    Multiple label types are possible, either with separate options"
      . "\n     or as one comma separated list.\n"
      . "    All the types must exist in the vob.\n"
      . "\nDocumentation under: perldoc $bn\n";
    exit 1;
  }
}
sub untaint($) {
  my $tainted = shift;
  my @untaintedbits;
  foreach (split //, $tainted) {
    if (m%([-\@\w.])%) {
      push @untaintedbits, $1;
    }
  }
  return join '', @untaintedbits;
}
sub untaintpath($) {
  my $tainted = shift;
  my @dirs = split '/', $tainted;
  map { $_ = untaint($_) } @dirs;
  return join '/', @dirs;
}
sub untaintstring($) {
  my $tainted = shift;
  my @words = split /\s+/, $tainted;
  map { $_ = untaint($_) } @words;
  return join ' ', @words;
}
my $res = GetOptions("help" => \$help, "unlock" => \$unlock, "vob=s" => \$vob,
		     "replace" => \$rep, "nusers=s" => \@nusers,
		     "lbtype=s" => \@lbtype);
usage if $help or !($res and $vob and @lbtype) or ($unlock and @nusers);
@lbtype = split(/,/, join(',', @lbtype));

extra/locklbtypesudo  view on Meta::CPAN

      . "  --vob <vob> --lbtype <lbtypes> | --help\n\n"
      . "    By default, lock; use --unlock explicitely.\n"
      . "    Only one vob is accepted, and it is mandatory.\n"
      . "    Multiple label types are possible, either with separate options"
      . "\n     or as one comma separated list.\n"
      . "    All the types must exist in the vob.\n"
      . "\nDocumentation under: perldoc $bn\n";
    exit 1;
  }
}
sub untaint($) {
  my $tainted = shift;
  my @untaintedbits;
  foreach (split //, $tainted) {
    if (m%([-\@\w.])%) {
      push @untaintedbits, $1;
    }
  }
  return join '', @untaintedbits;
}
sub untaintpath($) {
  my $tainted = shift;
  my @dirs = split '/', $tainted;
  map { $_ = untaint($_) } @dirs;
  return join '/', @dirs;
}
sub untaintstring($) {
  my $tainted = shift;
  my @words = split /\s+/, $tainted;
  map { $_ = untaint($_) } @words;
  return join ' ', @words;
}
my $res = GetOptions("help" => \$help, "unlock" => \$unlock, "vob=s" => \$vob,
		     "replace" => \$rep, "nusers=s" => \@nusers,
		     "lbtype=s" => \@lbtype);
usage if $help or !($res and $vob and @lbtype) or ($unlock and @nusers);
@lbtype = split(/,/, join(',', @lbtype));