view release on metacpan or  search on metacpan

MGi.pm  view on Meta::CPAN

      }
    }
  }
  $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;
      }
      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.