view release on metacpan or  search on metacpan

MGi.pm  view on Meta::CPAN

      if ($glb) {
	$ret = $CT->mkhlink(['GlobalDefinition'], $deq, $eqt)->system;
      } else {
	$ret = $CT->mkhlink([$EQHL], $dst, $deq)->system;
      }
    }
  }
  if ($dst !~ /:/) {
    $dst = "$1$dst" if $src =~ /^(.*?:)/;
  }
  $ret += $CT->mkhlink(['GlobalDefinition'], $dst, $src)->system if $glb;
  return $ret unless $src =~ /^lbtype:/; #no fallback!
  my $rmat = $src;
  $rmat =~ s/lbtype:/attype:Rm/;
  if (!$CT->des(['-s'], $rmat)->stdout(0)->stderr(0)->system) {
    $dst =~ s/lbtype:/attype:Rm/;
    $ret += $cpt->args($rmat, $dst)->system;
    $ret += $CT->mkhlink(['GlobalDefinition'], $dst, $rmat)->system
      if $CT->des([qw(-fmt %[type_scope]p)], $rmat)->stderr(0)->qx eq 'global';
  }
  return $ret;
}
sub cptype {
  use strict;
  use warnings;
  my $cpt = ClearCase::Argv->new(@ARGV);
  $cpt->parse(qw(c|cfile cq|cqe nc replace));
  if (scalar $cpt->args != 2) {
    warn Msg('E', 'Type name required.');
    @ARGV = qw(help cptype);
    ClearCase::Wrapper->help();
    return 1;
  }
  return 1 if ClearCase::Argv->des(['-s'], ($cpt->args)[0])->stdout(0)->system;
  _Preemptcmt($cpt, \&_CpType);
}

=item * SETCS

From the version in DSB.pm 1.14--retaining its additions:

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.

Add support for incremental label type families, via an
I<##:IncrementalLabels:> attribute in the config spec: generate a
config spec fragment equivalent to the type specified, and include it.
An optional clause of C<-nocheckout> will be propagated to the
generated rules.

=cut

sub setcs {
  use strict;
  use warnings;
  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;
    close(EXP);
    $ct->opts('setcs', $settmp)->system;
    unlink $settmp;
    exit $?;
  } elsif ($opt{sync} || $opt{needed}) {
    chomp(my @srcs = qx($^X -S $0 catcs -sources -tag $tag));
    exit 2 if $?;
    (my $obj = $srcs[0]) =~ s/config_spec/.compiled_spec/;
    die Msg('E', "$obj: no such file") if ! -f $obj;
    die Msg('E', "no permission to update $tag's config spec") if ! -w $obj;
    my $otime = (stat $obj)[9];
    my $needed = grep { (stat $_)[9] > $otime } @srcs;
    if ($opt{sync}) {
      if ($needed) {
	ClearCase::Argv->setcs(qw(-current -tag), $tag)->exec;
      } else {
	exit 0;
      }
    } else {
      exit $needed;
    }
  } elsif ($opt{clone}) {
    my $ct = ClearCase::Argv->new;
    my $ctx = $ct->find_cleartool;
    my $cstmp = ".$ARGV[0].$$.cs.$tag";
    Argv->autofail(1);
    Argv->new("$ctx catcs -tag $opt{clone} > $cstmp")->system;
    $ct->setcs('-tag', $tag, $cstmp)->system;
    unlink($cstmp);
    exit 0;
  }
  my $setcs = ClearCase::Argv->new(@ARGV);
  $setcs->parse(qw(force default|current|stream overwrite|rename
		   ctime|ptime tag=s));
  exit $setcs->system if $setcs->flag('force') or $setcs->flag('default')
    or $setcs->flag('overwrite') or $setcs->flag('ctime');
  my ($cs) = $setcs->args;
  if (!$cs) {
    warn Msg('E', 'Configuration spec must be specified.');
    @ARGV = qw(help setcs);
    ClearCase::Wrapper->help();
    return 1;
  }
  my (@cs1, @cs2, $incfam, $noco);
  open my $fh, '<', $cs or die Msg('E', qq(Unable to access "$cs": $!));
  while (<$fh>) {
    if (/^\#\#:IncrementalLabels: *([^\s]+)(\s+-nocheckout)?/) {
      ($incfam, $noco) = ($1, $2?$2:'');
      last;
    }
    push @cs1, $_;
  }
  @cs2 = <$fh> if $incfam;
  close $fh;
  exit $setcs->system unless $incfam;
  my ($lbtype, $vob) = $incfam =~ /^(?:lbtype:)?(.*?)\@(.*)$/;
  die Msg('E', qq(Failed to parse the vob from "$incfam")) unless $vob;
  my $rmat = 'Rm' . ($lbtype =~ /^(.*)_/ ? $1 : $lbtype);
  my @eqlst = _EqLbTypeList($lbtype);
  my $nr = $1 if $eqlst[0] =~ /^.*_(\d+\.\d+)$/;
  die Msg('E', qq($lbtype" is not the top of a label type family))
    unless $nr;
  my $ct = ClearCase::Argv->new({autochomp=>1});
  $tag = $ct->pwv('-s')->qx unless $tag = $setcs->flag('tag');
  die Msg('E', 'Cannot get view info for current view: not a ClearCase object.')
    unless $tag;
  my ($vws) = reverse split '\s+', $ct->lsview($tag)->qx;
  open $fh, '>', "$vws/$lbtype"
    or die Msg('E',
	       qq(Failed to write config spec fragment "$vws/$lbtype": $!\n));
  print $fh qq(element * "{lbtype($_)&&!attr_sub($rmat,<=,$nr)}$noco"\n)
    for @eqlst;
  close $fh;
  $cs .= $$;
  open $fh, '>', $cs or die Msg('E', qq(Could not write "$cs": $!));
  print $fh @cs1;
  print $fh "include $vws/$lbtype\n";
  print $fh @cs2;
  close $fh;
  my $rc = $setcs->args($cs)->system;
  unlink $cs;
  exit $rc; # avoid fallback!
}

=item * DESCRIBE

From DSB.pm

Enhancement. Adds the B<-parents> flag, which takes an integer argument
I<N> and runs the I<describe> command on the version I<N> predecessors
deep instead of the currently-selected version.
into temp files and diffs them. If only one view is specified, compares
against the current working view's config spec.

The parents take the genealogy of contributions into account.

Every version may thus have several parents. In fact, at a given
generation level, the same contributors might occur several times: the
command will show them only once.

Two enhancements to the formats supported by the C<-fmt> flag:

=over 1

=item - C<%PVn> and C<%PSn> take the genealogy into consideration

=item - C<%[...]l> accepts a regexp to filter the labels to be displayed

=back

=cut

sub describe {
  use strict;
  use warnings;
  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=i family=i));
  my $generations = abs($desc->flagWRAPPER('parents') || 0);
  my @args = $desc->args;
  if (grep /^-par/, @args) {
    @args = grep !/^-par/, @args;
    $generations = 1;
  }
  my $rc = 0;
  if ($generations) {

MGi.pm  view on Meta::CPAN

	shift @eqlst;
	last unless @eqlst;
      }
      die Msg('E', qq("$ts" too old: no equivalent baseline)) unless @eqlst;
      $nr = $1 if $eqlst[0] =~ /^.*_(\d+\.\d+)$/;
      my @bits = map{ $_ = 0 unless $_ } strptime($ts);
      $ts = strftime(q(%Y-%m-%dT%H:%M:%S%z), @bits); #Standardize
    }
  }
  if ($mkv->flagWRAPPER('quiet')) {
    $mkv->stdout(0);
    $mkv->stderr(0);
  }
  $mkv->system and exit 1;
  $CT->chview(['-readonly'], $tag)->system if grep /^readonly$/, @prop;
  if (@eqlst) {
    my $l = ($lb =~ /^(.*?)@/? $1 : $lb);
    my $rmat = "Rm$l";
    my $f = "$hpa/$l";
    if ($ts) {
      $f .= ".$ts"
    } else {
      $ts = $CT->des([qw(-fmt %d)], $lbt)->qx;
      $rt = str2time($ts);
      $l =~ s/^(.*)_[\d.]+$/$1/;
    }
    my $trim = sub {
      if ($_ and m%^element\s+(\S+)\s+(?:\.\.\.)?[/\\](\S+)[/\\]LATEST\b.*$%) {
	my $vb = ($1 eq '*'? '' : $1);
	my @bt = split m%[/\\]%, $2;
	if ($vb) {
	  $vb =~ s%^(.*?)[/\\]\.\.\.%$1%;
	  $vb = $CT->des(['-s'], "vob:$vb")->stderr(0)->qx;
	}
	my $ext = $vb? "\@$vb" : '';
	$vb = 'this vob' unless $vb;
	for my $t (@bt) {
	  my $ts = $CT->des([qw(-fmt %d)], "brtype:$t$ext")->stderr(0)->qx;
	  warn Msg('W', qq(Branch type "$t" not found in $vb.\n))
	    unless $ts;
	  return 0 if !$ts or str2time($ts) > $rt;
	}
      }
      return 1;
    };
    my (@cs1, @cs2, $incfam, $noco);
    push @cs1, "time $ts\n";
    open my $fh, '<', $cs or die Msg('E', qq(Unable to access "$cs": $!));
    while (<$fh>) {
      if (/^element .*\s\Q$l\E(\s+-nocheckout)?/) {
	$noco = defined($1)? $1 : '';
	$incfam = 1;
	last;
      }
      push @cs1, $_ if $trim->($_);
    }
    @cs2 = grep $trim->(), <$fh> if $incfam;
    close $fh;
    if ($incfam) {
      open $fh, '>', $f
	or die Msg('E', qq(Failed to write config spec fragment "$f": $!));
      print $fh qq(element * "{lbtype($_)&&!attr_sub($rmat,<=,$nr)}$noco"\n)
	for @eqlst;
      close $fh;
    } else {
      warn Msg('W', qq(No rule based on "$l" was found in "$cs".\n));
    }
    ($fh, $cs) = tempfile(DIR => File::Spec->tmpdir);
    print $fh @cs1;
    if ($incfam) {
      if ($^O eq 'cygwin') {
	$f =~ s%^/cygdrive/(\w)%$1:%;
	$f =~ s%/%\\%g;
      }
      print $fh "include $f\n";
      print $fh @cs2;
    }
    close $fh;
  }
  $CT->setcs(['-tag', $tag], $cs)->exec;
}

=item * ROLLOUT

New command. Deliver by applying labels of the base line family
(applying the fixed increment and moving the floating).

Without the B<-force> option, will perform a prior I<find> to verify
that no I<home merge> (I<rebase>) is needed.

As part of the rollout, the type identifying the development (label
type or branch type) will be I<archived> away if it is used in the
current config spec. This is to ensure that the config spec will
select the new baseline after the rollout. Note that branch types
associated with a family label (used previously with a I<mklabel
-over>) will be archived as well.

Note that the rollout concerns a type at the vob level (or across
several vobs). It is however dependent on the view used, which is
assumed to be a development view selecting the versions being
rolled-out.

The baseline type must be a family type.

The intention is to eventually support global types.
This is disabled for now.
The problem lies in applying labels in multiple vobs, which may be
too slow to be practical.

If the type being delivered (or eventually any branch type it carries
changes from) is global, the rollout will affect all the vobs
concerned. This is a consequence of the fact that the types will get
archived. The baseline type scope will have to match.

=cut

sub rollout {
  use strict;
  use warnings;
  use Cwd;
  my %opt;