view release on metacpan or  search on metacpan

MGi.pm  view on Meta::CPAN

  exit $rc; # avoid fallback!
}

=item * MKVIEW

Enhancement. Clone, equivalent fixed config spec.
Works only for dynamic views, as I don't know how to get the snapshot
view directory

=cut

sub mkview {
  use strict;
  use warnings;
  use File::Basename;
  use File::Spec;
  use File::Temp qw(tempfile);
  use Sys::Hostname;
  use Date::Format;
  use Date::Parse;
  my $mkv = ClearCase::Argv->new(@ARGV);
  $mkv->optset(qw(CC WRAPPER));
  $mkv->parseCC(qw(snapshot tag=s tcomment=s tmode=s region=s stream=s
		   shareable_dos|nshareable_dos cachesize=s
		   stgloc=s host=s hpath=s gpath=s
		   colocated_server vws=s));
  $mkv->parseWRAPPER(qw(clone=s equiv=s quiet));
  return 0 unless $mkv->flagWRAPPER('clone'); # fallback!
  my $tag = $mkv->flagCC('tag');
  if (!$tag) {
    warn Msg('E', 'View tag must be specified.');
    @ARGV = qw(help mkview);
    ClearCase::Wrapper->help();
    return 1;
  }
  $CT = ClearCase::Argv->new({autochomp=>0});
  my $lsv = $CT->lsview([qw(-l -prop -full)], $mkv->flagWRAPPER('clone'))->qx;
  return 1 unless $lsv;
  my %tm = (unix=>'transparent', msdos=>'insert_cr', strip_cr=>'strip_cr');
  my ($tmo, @prop) = ($tm{$1}, split /\s+/, $2)
    if $lsv =~ /Text mode: (.*?)\n.*Properties: (.*?)\n/s;
  die Msg('E', 'Snapshot views not supported for cloning!')
    if grep /^snapshot$/, @prop or $mkv->flagCC('snapshot');
  my @nsup = grep !/(dynamic|shareable_dos|readwrite|readonly)$/, @prop;
  die Msg('E', "Non supported for cloning: @nsup") if @nsup;
  $tmo = $mkv->flagCC('tmode') if $mkv->flagCC('tmode');
  my $shdo = $mkv->flagCC('shareable_dos');
  ($shdo) = grep /shareable_dos$/, @prop unless $shdo;
  my @k = grep !/(stgloc|host|hpath|gpath|tmode|shareable_dos)/,
    keys %{$mkv->{AV_LKG}{'CC'}};
  my @opts = (map(("-$_", $mkv->flagCC($_)), @k), '-tmo', $tmo, "-$shdo");
  my ($host, $ogpa, $hpa, $own) = ($2, $1, $3, $4)
    if $lsv =~ m{ \QGlobal path: \E(.*?)\n.*
		  \QServer host: \E(.*?)\n.*
		  \Qaccess path: \E(.*?)\n.*
		  \QView owner: \E(?:.*?/)(.*?)\n
	      }xs;
  if ($mkv->flagCC('stgloc')) {
    push @opts, '-stg', $mkv->flagCC('stgloc');
  } else {
    my $pwnam = (getpwuid($<))[0];
    if ($mkv->flagCC('hpath')) {
      $hpa = $mkv->flagCC('hpath');
    } else {
      my $pdir = dirname($hpa);
      if (basename($pdir) eq $own) {
	$hpa = File::Spec->catdir(dirname($pdir), $pwnam, "$tag.vws");
      } else {
	$hpa = File::Spec->catdir($pdir, "$tag.vws");
      }
    }
    my $gpa = $mkv->flagCC('gpath');
    if (!$gpa) {
      my $pdir = dirname($ogpa);
      if (basename($pdir) eq $own) {
	$gpa = File::Spec->catdir(dirname($pdir), $pwnam, "$tag.vws");
      } else {
	$gpa = File::Spec->catdir($pdir, "$tag.vws");
      }
    }
    $host = $mkv->flagCC('host') if $mkv->flagCC('host');
    push @opts, '-host', $host, '-hpa', $hpa, '-gpa', $gpa;
    if (!$mkv->args) {
      if ($host eq hostname or $gpa =~ m%^//%) { #UNC gives 'Access is denied'
	$mkv->args($hpa);
      } else {
	$mkv->args($gpa);	#Should work from anywhere
      }
    }
  }
  $mkv->opts(@opts);
  my $cs = File::Spec->catfile($ogpa, 'config_spec');
  my (@eqlst, $lb, $ts, $lbt, $nr, $rt); #reference time
  if (my $eq = $mkv->flagWRAPPER('equiv')) {
    ($lb, $ts) = split /,/, $eq;
    $CT->autochomp(1);
    $lbt = "lbtype:$lb";
    if ($lb =~ /^lbtype:(.*)$/) {
      $lbt = $lb;
      $lb = $1;
    }
    die Msg('E', qq(Label type not found: "$lb"))
      unless $CT->des(['-s'], $lbt)->qx;
    @eqlst = _EqLbTypeList($lb);
    $nr = $1 if $eqlst[0] =~ /^.*_(\d+\.\d+)$/;
    die Msg('E', qq("$lb" is not the top of a label type family)) unless $nr;
    if ($ts) {
      my $ots = $ts;
      $rt = str2time($ts);
      if (!$rt) {
	$ts =~ tr/-./  /;
	$rt = str2time($ts);
      }
      die Msg('E', qq(Failed to parse "$ots" as a timestamp)) unless $rt;
      die Msg('E', qq("$lb" is not a floating label type))
	unless grep /^->/, $CT->des([qw(-s -ahl), $EQHL], $lbt)->qx;
      my $v = $lb =~ /(@.*)$/? $1 : '';
      while (str2time($CT->des(qw(-fmt %d), "lbtype:$eqlst[0]$v")->qx) > $rt) {
	shift @eqlst;
	last unless @eqlst;
      }