| Current Path : /var/www/web-klick.de/dsh/10_customer2017/1204__intel/ |
Linux ift1.ift-informatik.de 5.4.0-216-generic #236-Ubuntu SMP Fri Apr 11 19:53:21 UTC 2025 x86_64 |
| Current File : /var/www/web-klick.de/dsh/10_customer2017/1204__intel/CCAPI.pm |
package CCAPI;
our $VERSION = "1.8";
use strict;
use Job;
use Params::Validate qw(:all);
use ClearCase::CtCmd qw(cleartool);
use ClearCase::MtCmd qw(multitool);
use File::Temp qw(tempfile);
use File::Spec;
our $MVFS_PATH = ($^O =~ /win/i ? "M:\\" : '/view/');
sub new
{
my $class = shift;
my $this = {};
bless $this, $class;
$this->initialize(@_);
return $this;
}
sub initialize
{
my $this = shift;
my %args = validate(@_, {
VOBS => { type => ARRAYREF, optional => 1 },
VERBOSITY => { type => SCALAR, default => 0 },
BATCH => { type => SCALAR, default => 200 },
LOG_INFO => { type => CODEREF, optional => 1 },
LOG_WARN => { type => CODEREF, optional => 1 }
});
$this->{BATCH} = $args{BATCH};
$this->{VERBOSITY} = $args{VERBOSITY};
if($args{LOG_INFO}) {
$this->{LOG_INFO} = $args{LOG_INFO};
} else {
$this->{LOG_INFO} = sub { print @_ };
}
if($args{LOG_WARN}) {
$this->{LOG_WARN} = $args{LOG_WARN};
} else {
$this->{LOG_WARN} = sub { warn @_ };
}
my @vobs;
if($args{VOBS}) {
@vobs = @{$args{VOBS}}; # copy
# expand VOB tags
foreach(@vobs) {
if($^O =~ /win/i) {
s{^//}{\\};
} else {
s{^//}{/vobs/};
}
}
}
elsif($ENV{CLEARCASE_AVOBS}) {
if($^O =~ /win/i) { # on windows semicolons
@vobs = split(/;+/, $ENV{CLEARCASE_AVOBS});
} else {
@vobs = split(/:+/, $ENV{CLEARCASE_AVOBS});
}
}
else {
# is probably a snapshot view
my $cs = $this->get_config_spec();
if($cs) {
foreach(split(/[\r\n]+/, $cs)) {
# just the (short) VOB tag
if(m{^\s*load\s+((?:/vobs/|\\)[^/\\]+)}i) {
push(@vobs, $1);
}
}
}
}
my %seen;
$this->{VOBS} = [ grep(!$seen{$_}++, @vobs) ];
return $this;
}
sub log_info
{
my ($this, $verbose, @args) = @_;
$this->{LOG_INFO}->(@args) if $verbose <= $this->{VERBOSITY};
}
sub log_warn
{
my ($this, $verbose, @args) = @_;
$this->{LOG_WARN}->(@args) if $verbose <= $this->{VERBOSITY};
}
sub config
{
my $this = shift;
my %args = @_;
foreach(keys %args) {
my $val = $args{$_};
if(defined $val) {
$this->{$_} = $val;
} else {
delete $this->{$_};
}
}
1;
}
sub add_vobs
{
my ($this,@add) = @_;
my %all_vobs;
foreach(@{$this->{VOBS}}, @add) {
# strip trailing directory separators
# remove duplicate dirseps
s{[\\/]\.?(?=/|\\|$)}{}g;
$all_vobs{$_}++;
}
$this->{VOBS} = [ sort keys %all_vobs ];
$ENV{CLEARCASE_AVOBS} = join($^O =~ /win/i ? ';' : ':', @{$this->{VOBS}});
return @{$this->{VOBS}};
}
sub get_vobs
{
my $this = shift;
return @{$this->{VOBS}};
}
sub check_vobs
{
my $this = shift;
unless($this->{VOBS} && @{$this->{VOBS}}) {
return;
}
my @vobs = @{$this->{VOBS}};
my @ok_vobs;
foreach my $vob (@vobs) {
my ($stat,$out,$err) = cleartool('lsvob',$vob);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list VOB '$vob':\n$out$err\n");
} else {
push(@ok_vobs, $vob);
# mount the VOB on Windows in dynamic views
if($^O =~ /win/i && !$this->{_is_snapshot_view} && $out !~ /^\*/) {
($stat,$out,$err) = cleartool('mount',$vob);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot mount VOB '$vob':\n$out$err\n");
}
} # windows...
} # lsvob OK
} # loop VOBs
unless(@ok_vobs) {
return;
}
# on windows semicolons, on UNIX colons
$ENV{CLEARCASE_AVOBS} = join($^O =~ /win/i ? ';' : ':', @vobs);
return 1;
}
sub check_vob_owner
{
my $this = shift;
my %args = validate(@_, {
USER => { type => SCALAR, default => (getpwuid($<))[0] }
});
my @ok_vobs;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$owner,$err) = cleartool(qw(desc -fmt %[owner]p\n), "vob:$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot describe VOB '$vob':\n$owner$err");
next;
}
chomp $owner;
$owner =~ s#^.*/##; # strip the domain
unless($owner eq $args{USER}) {
$this->log_warn(0, "[ERROR] VOB '$vob' is owned by user '$owner'. Current user '$args{USER}' is not admin. Skipping this VOB.\n");
} else {
push(@ok_vobs, $vob);
}
} # loop VOBs
unless(@ok_vobs) {
$this->log_warn(0, "[ERROR] No VOBs to process.\n");
return 0;
}
@{$this->{VOBS}} = @ok_vobs;
$ENV{CLEARCASE_AVOBS} = join(':', @ok_vobs); # TODO no : on Windows
1;
}
sub get_current_view
{
my $this = shift;
my ($view,@views) = $this->get_views();
return $view;
}
sub get_views
{
my $this = shift;
my %args = validate(@_, {
VIEW => { type => SCALAR|UNDEF, optional => 1 },
ELEMENT => { type => SCALAR|UNDEF, optional => 1 },
USER => { type => SCALAR, default => ($^O =~ /win/i ? scalar(getlogin()) :
scalar(getpwuid($<))) }
});
# selection of the view
my $view;
my @views;
if($args{VIEW}) {
$view = $args{VIEW};
@views = ($view);
}
elsif($args{ELEMENT}) {
my $dir = -d $args{ELEMENT} ? $args{ELEMENT} : dirname($args{ELEMENT});
unless(chdir $dir) {
$this->log_warn(0, "[ERROR] Cannot change to '$dir': $!\n");
}
goto GetView;
}
else {
GetView:
my ($stat,$out,$err) = cleartool('pwv','-s');
if($stat == 0 && $out !~ /\*\* NONE \*\*/) {
chomp $out;
$view = $out;
@views = ($out);
}
}
# read M: on Windows
if(!$view && $^O =~ /win/i) {
if(opendir(MVFS_ROOT, $MVFS_PATH)) {
foreach(readdir(MVFS_ROOT)) {
next if /^\./; # . .. .specdev
push(@views, $_);
}
closedir(MVFS_ROOT);
} else {
$this->log_warn(0, "[ERROR] Cannot read directory '$MVFS_PATH': $!\n");
}
}
unless(@views) {
# all registered views by user; TODO: view owner check
my ($stat,$out,$err) = cleartool('lsview', '-s');
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list views:\n$out$err");
}
chomp $out;
@views = grep(/^\Q$args{USER}\E\./, split(/[\r\n]+/, $out));
}
# default view
$view = $views[0] unless $view;
if($view) {
$this->{_view} = $view;
$this->{_is_snapshot_view} = $this->is_snapshot_view(VIEW => $view);
}
return($view,@views);
}
sub is_snapshot_view
{
my $this = shift;
my %args = validate(@_, {
VIEW => { type => SCALAR, default => $this->{_view} }
});
return unless $args{VIEW};
my ($stat,$out,$err) = cleartool(qw(lsview -l), $args{VIEW});
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list properties of view '$args{VIEW}':\n$out$err\n");
return;
}
elsif($out =~ /^View attributes:.*snapshot/m) {
return 1;
}
return;
}
sub add_vobs_from_view
{
my $this = shift;
if($this->{_is_snapshot_view}) {
my $cs = $this->get_config_spec(VIEW => $this->{_view});
my %load_vobs;
foreach(split(/[\r\n]+/, $cs)) {
if(m{^\s*load\s+((?:\\|/vobs/)[^/\\]+)}i) {
$load_vobs{$1}++;
}
}
my %seen;
my @vobs = grep(!$seen{$_}++, @{$this->{VOBS}}, keys %load_vobs);
$this->{VOBS} = \@vobs;
}
elsif(!@{$this->{VOBS}}) {
# dynamic view - determine mounted VOBs, but only if none defined
my ($stat,$out,$err) = cleartool(qw(pwv -root));
if($stat) {
$this->log_warn(0, "[ERROR] Cannot determine root directory of current view.\n");
return;
}
chomp $out;
my $root = $out;
unless(opendir(ROOT, $root)) {
$this->log_warn(0, "[ERROR] Cannot read view root directory: $!\n");
return;
}
my @vobs;
foreach(readdir(ROOT)) {
next if /^\./ || !-d "$root/$_"; # skip . .. .specdev and non-dirs
push(@vobs, "\\$_");
}
closedir(ROOT);
my %seen;
$this->{VOBS} = [ grep(!$seen{$_}++, @{$this->{VOBS}}, @vobs) ];
}
1;
}
sub get_config_spec
{
my $this = shift;
my %args = validate(@_, {
VIEW => { type => SCALAR, optional => 1 }
});
my @cmd = qw(catcs);
if($args{VIEW}) {
push(@cmd, '-tag', $args{VIEW});
}
my ($stat,$out,$err) = cleartool('catcs');
if($stat) {
$this->log_warn(0, "[ERROR] Failed to read config spec:\n$out$err\n");
return;
}
return $out;
}
# API change: CONTENT must contain load rules for snapshot views
sub set_config_spec
{
my $this = shift;
my %args = validate(@_, {
VIEW => { type => SCALAR, optional => 1 },
CONTENT => { type => SCALAR }
});
my $content = $args{CONTENT};
my @view_opt = $args{VIEW} ? (-tag => $args{VIEW}) : ();
# add snapshot view load rules
if(!$args{VIEW} && $this->{_is_snapshot_view}) {
$this->log_info(0, "[INFO] Will update snapshot view, this may take some time - patience please...\n");
push(@view_opt, '-force');
}
# save content to a file to pass it to setcs
my ($tempfh, $tempfile) = tempfile("config-spec-XXXXXXXX", TMPDIR => 1);
unless($tempfh) {
$this->log_warn(0, "[ERROR] Cannot create temporary file: $!\n");
return;
}
print $tempfh $content;
unless(close($tempfh)) {
$this->log_warn(0, "[ERROR] Cannot write config spec file $tempfile: $!\n");
return;
}
# now set the config spec of the view
my ($stat,$out,$err) = cleartool('setcs', @view_opt, $tempfile);
if($stat) {
my $view_text = $args{VIEW} ? "view '$args{VIEW}'" : "current view";
$this->log_warn(0, "[ERROR] Cannot set config spec in $view_text:\n$out$err\n");
}
# $this->log_info(0, "[INFO] Config spec set to:\n$newcs\n$out$err\n");
return $stat==0;
}
sub create_temporary_view
{
my $this = shift;
my %args = validate(@_, {
VIEWTAG => { type => SCALAR }
});
my ($stgloc,$server,$path);
foreach my $vob (@{$this->{VOBS}}) {
my $replica = $this->get_local_replica(VOB => $vob);
my ($stat,$out,$err) = cleartool('desc',
-fmt => ($^O =~ /win/i ? '%[VIEW_SETUP_WINDOWS]SNa' : '%[VIEW_SETUP_UNIX]SNa'),
"replica:$replica\@$vob");
if($stat) {
$this->log_warn(0, "[WARNING] Cannot describe replica '$replica' in VOB '$vob':\n$out$err\n");
next;
}
chomp $out;
if($out =~ m{^"\@([^:\@]+)"$}) {
$stgloc = $1;
last;
}
elsif($out =~ m{^"?([^:]+):([^"]+)"?$}) {
$server = $1;
$path = $2;
last;
}
elsif(length $out) {
$this->log_warn(1, "[WARNING] Cannot parse view setup '$out'.\n");
next;
}
}
my @opt;
if($stgloc) {
@opt = (-stgloc => $stgloc);
}
elsif($server && $path) {
$path .= ($^O =~ /win/i ? '\\' : '/') . "$args{VIEWTAG}.vws";
@opt = (-host => $server, -hpath => $path, -gpath => $path, $path);
}
else {
$this->log_warn(0, "[ERROR] Don't know how to create views here ($^O).\n");
return;
}
my ($stat,$out,$err) = cleartool('mkview', -tag => $args{VIEWTAG}, @opt);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot create view '$args{VIEWTAG}':\n$out$err\n");
return;
}
1;
}
sub remove_view
{
my $this = shift;
my %args = validate(@_, {
VIEWTAG => { type => SCALAR }
});
my ($stat,$out,$err) = cleartool(qw(rmview -force), -tag => $args{VIEWTAG});
if($stat) {
$this->log_warn(0, "[ERROR] Cannot remove view '$args{VIEWTAG}':\n$out$err\n");
return;
}
1;
}
sub check_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool("lstype -s brtype:$args{BRANCH}\@$vob");
if($stat) {
return;
}
if($out =~ /^\s*$/s) {
return;
}
}
return 1;
}
sub check_label
{
my $this = shift;
my %args = validate(@_, {
LABEL => { type => SCALAR }
});
my $ok = 1;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('lstype', "lbtype:$args{LABEL}\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list label type '$args{LABEL}' in VOB '$vob':\n$out$err\n");
$ok = 0;
}
}
return $ok;
}
sub get_child_branches
{
my ($this,@params) = @_;
my %args = validate_with( # fork on Windows does not like validate on @_ directly
params => \@params,
spec => {
BRANCH => { type => SCALAR },
STATE => { type => SCALAR, optional => 1 },
USER => { type => SCALAR, optional => 1 }
});
$this->log_info(0, "[INFO] Searching for child branches of '$args{BRANCH}' ...\n");
# parallel processing of VOBs - but not on Windows with Tk
my %branches;
my @cmd = ('lstype', -kind => 'brtype',
-fmt => "%n|%[INTEGRATION_BRANCH]SNa|%[TASK_STATE]SNa|%[owner]p\\n", '-invob');
if($^O =~ /win/i && $INC{'Tk.pm'}) {
# we take only the first VOB here
my ($vob) = @{$this->{VOBS}};
my ($stat,$out,$err) = cleartool(@cmd, $vob);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list branches in VOB '$vob':\n$out$err\n");
return;
}
$this->_process_branch_output($args{STATE}, $args{BRANCH}, $args{USER}, \%branches, $out);
} else {
foreach my $vob (@{$this->{VOBS}}) {
Job->new(
vob => $vob,
command => ['cleartool', @cmd, $vob],
combine_err => 1
)->start;
} # end loop VOBs
while(my $job = Job->getCompletedJob) {
my $vob = $job->{vob};
if($job->{status}) {
# report the problem, but do not set fail status
$this->log_warn(0, "[ERROR] Cannot list branches in VOB '$vob':\n". $job->getOutput."\n");
} else {
$this->log_info(1, "[INFO] ... got branches from VOB $vob\n");
my $out = $job->getOutput;
$this->_process_branch_output($args{STATE}, $args{BRANCH}, $args{USER}, \%branches, $out);
}
} # loop jobs done
}
delete $branches{main}; # paranoia
my @br = sort keys %branches;
$this->log_info(0, "[INFO] Found ".scalar(@br)." child branch(es).\n");
return @br;
}
sub _process_branch_output
{
my ($this, $bstate, $bname, $buser, $bref, $out) = @_;
chomp $out;
foreach(split(/[\r\n]+/, $out)) {
if(/^(\S+)\|"?([^"|]*)"?\|"?([^"|]*)"?\|(\S+)/) {
my ($name,$integ,$state,$owner) = ($1,$2,$3,$4);
next if($buser && $buser ne $owner);
if(($integ eq '' && $bname eq 'main') || $integ eq $bname) {
if(!$bstate || $state =~ /\Q$bstate\E/i) {
$bref->{$name}++;
}
}
}
}
1;
}
sub commit
{
my $this = shift;
my %args = validate(@_, {
COMMENT => { type => SCALAR, optional => 1 }
});
my @c_opt = $args{COMMENT} ? (-c => $args{COMMENT}) : qw(-nc_);
my ($stat,$out,$err) = cleartool(qw(lsco -cview -avob -short));
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list checkouts to current view:\n$out$err");
return;
}
chomp $out;
# make sure we check in leaves first!
my @elements = reverse sort split(/[\r\n]+/, $out);
unless(@elements) {
$this->log_warn(0, "[INFO] No checkouts to current view. Nothing to do.\n");
return 1;
}
$this->log_info(0, "[INFO] Checking in ",scalar(@elements)," element(s)...\n");
my $status = 1;
my @identical;
while(my @list = splice(@elements, 0, $this->{BATCH})) {
($stat,$out,$err) = cleartool('checkin','-ptime',@c_opt,@list);
while($err =~ s{\b(?:cleartool|ClearCase::CtCmd):\s+Error:\s+By default, won't create version with data identical to predecessor.[\s\r\n]+(?:cleartool|ClearCase::CtCmd):\s+Error:\s+Unable to check in "([^"]+)"\.[\s\r\n]*}{}) {
push(@identical, $1);
}
if($err =~ /\S+/) { # we have some more error
$this->log_warn(0, "[ERROR] Could not check in:\n$out$err");
$status = 0;
}
}
if(@identical) {
$this->log_info(0, "[INFO] Processing checkouts with identical content...\n");
foreach my $co (@identical) {
($stat,$out,$err) = cleartool('desc', -fmt => '%a%l%[hlink]p\n', $co);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot describe status of checkout '$co':\n$out$err\n");
$this->log_warn(0, "[WARNING] Please check and take care of '$co' manually\n");
$status = 0;
next;
}
chomp $out;
if($out =~ /\S+/) {
# we have some metadata - attributes, hyperlinks or labels: check in
($stat,$out,$err) = cleartool(qw(ci -identical -ptime), $co);
if($stat) {
$this->log_warn(0, "[ERROR] Could not check in (identical) '$co':\n$out$err\n");
$status = 0;
} else {
$this->log_info(1, "[INFO] Checked in (identical) element '$co'.\n");
}
} else {
# no metadata: cancel the checkout
($stat,$out,$err) = cleartool(qw(unco -rm), $co);
if($stat) {
$this->log_warn(0, "[ERROR] Could not cancel (identical) checkout '$co':\n$out$err\n");
$status = 0;
} else {
$this->log_info(1, "[INFO] Canceled (identical) checkout '$co'.\n");
}
}
}
} # identical
if($status) {
$this->log_info(0, "[INFO] Check-in successfully completed.\n");
} else {
$this->log_warn(0, "[ERROR] Check-in done, but errors occurred; please complete manually.\n");
}
return $status;
}
sub check_branch_name
{
my $this = shift;
my %args = validate(@_, {
NAME => { type => SCALAR }
});
if($args{NAME} =~ /^(deliver|rebase)$/i) {
$this->log_warn(0, "[ERROR] Branch name '$args{NAME}' was probably meant to be option '-".lc($args{NAME})."'\n");
return;
}
unless($args{NAME} =~ m{^[a-z][\w-]+$}i) {
$this->log_warn(0, "[ERROR] Illegal characters in branch name '$args{NAME}'. Must start with a letter and contain no special characters except dashes and underscores.\n");
return;
}
return 1;
}
sub create_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
INTEGRATION_BRANCH => { type => SCALAR },
COMMENT => { type => SCALAR|UNDEF, optional => 1 },
});
my ($branch, $ibranch) = @args{qw(BRANCH INTEGRATION_BRANCH)};
my $created = 0;
my $error = 0;
my $comment = $args{COMMENT};
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('desc','-s',"brtype:$branch\@$vob");
if($stat == 0) {
# branch exists
next;
}
elsif($err !~ /Branch type not found:/) {
$this->log_warn(0, "[ERROR] Cannot check branch type existence for '$branch' in VOB '$vob':\n$out$err");
}
$this->log_info(0, "[INFO] Need to create branch '$branch' in VOB '$vob'.\n");
unless(defined $comment) {
print "\nPlease enter a one-line comment describing the new branch '$branch':\n> ";
$comment = <STDIN>;
chomp $comment;
die "[ERROR] Aborted.\n" unless($comment);
}
($stat,$out,$err) = cleartool('mkbrtype','-c',$comment,"$branch\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot create branch '$branch' in VOB $vob:\n$out$err\n");
$error++;
next;
}
$created++;
# direct creation, no need to go through RFM or the like
($stat,$out,$err) = cleartool('mkattr', 'INTEGRATION_BRANCH', qq("$ibranch"),
"brtype:$branch\@$vob");
if($stat) {
$this->log_warn(0, "[WARNING] Cannot make INTEGRATION_BRANCH=$ibranch attribute on branch '$branch' in VOB $vob:\n$out$err\n");
}
($stat,$out,$err) = cleartool('mkattr', 'TASK_STATE', qq("open"), "brtype:$branch\@$vob");
if($stat) {
$this->log_warn(0, "[WARNING] Cannot make TASK_STATE=open attribute on branch '$branch' in VOB $vob.\n$out$err\n");
}
}
return($error ? -$error : $created);
}
sub generate_simple_config_spec
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
LABEL => { type => SCALAR },
OLD_CONFIG_SPEC => { type => SCALAR, optional => 1 }
});
my ($label,$branch,$old_cs) = @args{qw(LABEL BRANCH OLD_CONFIG_SPEC)};
my %load_vobs;
my $snapshot = 0;
# aggregate the VOBs in snapshot views
if($old_cs) {
foreach(split(/[\r\n]+/, $old_cs)) {
if(/^\s*load\s+(\S+)/i) {
$load_vobs{$1}++;
$snapshot++;
}
}
# add the ones determined from command line etc.
foreach(@{$this->{VOBS}}) {
$load_vobs{$_}++;
}
}
# check and get include file
my $include = '';
if($ENV{WORKAREA}) {
# TODO parameter
my $inc_file = "$ENV{WORKAREA}/etc/config_spec.txt";
$include = $this->get_config_spec_include(PATH => $inc_file,
SELECTORS => [ ".../$branch/LATEST", $label, "/main/LATEST" ],
SNAPSHOT => $snapshot);
} # WORKAREA
my $cs;
if($old_cs) {
# try to update the config spec by inserting the branch and label
my $count = 0;
$cs = $old_cs;
$cs =~ s{^(\s*element\s+\*\s+\.\.\./)[^/]+(/LATEST\s+#+\s*ccbranch:branch\s*)$}{$1$branch$2}m and $count++;
$cs =~ s{^(\s*mkbranch\s+)[^/]+(\s+#+\s*ccbranch:branch\s*)$}{$1$branch$2}m and $count++;
$cs =~ s{^(\s*element\s+\*\s+)\S+(\s+#+\s*ccbranch:label\s*)$}{$1$label$2}m and $count++;
unless($count == 3) {
$this->log_warn(0, <<"EOT");
[WARNING] Failed to update the config spec with rebase information.
Will generate config spec from scratch. Find the old content in config_spec.old
EOT
if(open(OUT, ">config_spec.old")) {
print OUT $old_cs;
close(OUT) ||
$this->log_warn(0, "[ERROR] Could not save old config spec in 'config_spec.old': $!\n");
} else {
$this->log_warn(0, "[ERROR] Could not open 'config_spec.old' for write: $!\n");
}
$old_cs = '';
} else {
$this->log_info(0, "[INFO] Updated config spec only with new branch/label settings.\n");
}
}
unless($old_cs) {
# write config spec from scratch
$cs = <<"EOT";
# this config spec is for developing on branch '$branch',
# which is rooted at label '$label'
#
element * CHECKEDOUT
$include
element * .../$branch/LATEST # ccbranch:branch
mkbranch $branch # ccbranch:branch
element * $label # ccbranch:label
element * /main/LATEST
end mkbranch
EOT
if($snapshot) {
# add the load rules
$cs .= "\n".join("\n", map { "load $_" } sort keys %load_vobs)."\n";
}
} # !rebase
return $cs;
}
sub get_branch_root_label
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
my $branch = $args{BRANCH};
my %labels;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool("desc -fmt '%[BRANCH_ROOT_LABEL]NSa\\n' brtype:$branch\@$vob");
if($stat) {
$this->log_warn(1, "[WARNING] Cannot get BRANCH_ROOT_LABEL attribute for branch $branch in VOB $vob:\n$out$err");
next;
}
chomp $out;
if($out =~ /"([^"]+)"/) {
$labels{$1}++;
}
}
my @ls = reverse sort keys %labels;
unless(@ls) {
$this->log_warn(0, "[ERROR] No root label defined on branch '$branch' in any VOB.\n");
return;
}
elsif(@ls > 1) {
$this->log_warn(0, "[ERROR] Inconsistent definition of root label of branch '$branch':\n@ls\n");
$this->log_info(0, "[INFO] Will use '$ls[0]'.\n");
}
return $ls[0];
}
sub get_baseline_labels
{
my $this = shift;
my %args = validate(@_, {
BASELINE => { type => SCALAR }
});
my @queue = ($args{BASELINE});
my @labels;
while(@queue) {
my $label = shift(@queue);
next if grep($_ eq $label, @labels);
push(@labels, $label);
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('desc',
-fmt => '%[hlink:INCREMENTAL_LABEL]p\n',
"lbtype:$label\@$vob");
if($stat) {
$this->log_warn(0, "[WARNING] Cannot describe label $label in VOB $vob:\n$out$err\n");
next;
}
chomp $out;
if($out =~ /->\s+"lbtype:([^"\@]+)\@/) {
my $dep = $1;
push(@queue, $dep) unless grep($_ eq $dep, @queue, @labels);
}
} # end loop VOBs
}
return @labels;
}
sub get_config_spec_include
{
my $this = shift;
my %args = validate(@_, {
PATH => { type => SCALAR },
SELECTORS => { type => ARRAYREF },
SNAPSHOT => { type => SCALAR, optional => 1 }
});
my $include;
my $inc_file = $args{PATH};
unless(defined $args{SNAPSHOT}) {
$args{SNAPSHOT} = not -d "$inc_file\@\@"; # only dyn. view has @@
}
if($args{SNAPSHOT}) {
my ($stat,$out,$err) = cleartool('pwv', '-root');
if($stat) {
$this->log_info(0, "[ERROR] Cannot determine current view root.\n");
} else {
chomp $out;
$inc_file = "$out$inc_file";
}
}
foreach my $selector (@{$args{SELECTORS}}) {
$this->log_info(1, "[INFO] Running: find $inc_file -version 'version($selector)' -print\n");
my ($stat,$out,$err) = cleartool('find', $inc_file, '-version', "version($selector)", '-print');
if($stat == 0 && $out =~ /\S+/) {
chomp $out;
my $inc_version = $out;
$this->log_info(0, "[INFO] Using config spec include $inc_file from '$inc_version', selected by '$selector'.\n");
my $tempfile;
if($args{SNAPSHOT}) {
$tempfile = File::Temp::tempnam(File::Spec->tmpdir(), 'config-spec');
($stat,$out,$err) = cleartool('get', '-to', $tempfile, $inc_version);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot retrieve config spec include file version '$inc_version':\n$out$err");
return;
}
$inc_file = $tempfile;
} else {
$inc_file = $inc_version;
}
unless(open(IN, "<$inc_file")) {
$this->log_warn(0, "[ERROR] Cannot read config spec include file '$inc_file': $!\n");
return;
}
local $/ = undef;
my $content = <IN>;
close(IN);
$content =~ s/^\s+|\s+$//gs; # strip all line endings
if($^O =~ /win/i) {
# translate VOB tags
$content =~ s{/vobs/}{\\}g;
$content =~ s{/+}{\\}g;
}
$include = "# included from $inc_version - selector $selector\n$content\n# end include\n";
if($args{SNAPSHOT} && $tempfile) {
unlink $tempfile;
}
last; # exit from selector loop
} else {
$this->log_warn(1, "[ERROR] Cannot find include file '$inc_file' version '$selector':\n$out$err\n");
}
} # end loop config spec include file selectors
return $include;
}
sub get_branch_state
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
});
my $branch = $args{BRANCH};
my %state;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('desc', '-fmt', '%[TASK_STATE]SNa\n', "brtype:$branch\@$vob");
if($stat) { # an error - should not occur
unless("$out$err" =~ /\bBranch type not found:/) {
$this->log_warn(1, "[ERROR] Cannot determine TASK_STATE of '$branch' in VOB '$vob':\n$out$err");
}
next;
}
if($out =~ /^"(\S+)"/) {
$state{$1}++;
}
}
my @st = sort keys %state;
unless(@st) {
$this->log_warn(0, "[ERROR] No task state defined for branch '$branch' in any VOB.\n");
return;
}
elsif(@st > 1) {
$this->log_warn(0, "[ERROR] Inconsistent definition of task state for branch '$branch':\n@st\n");
$this->log_info(0, "[INFO] Will use '$st[0]'.\n");
}
return $st[0];
}
sub get_integration_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
});
my $branch = $args{BRANCH};
my %integ;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('desc', '-fmt', '%[INTEGRATION_BRANCH]SNa\n', "brtype:$branch\@$vob");
if($stat) { # an error - should not occur
unless("$out$err" =~ /\bBranch type not found:/) {
$this->log_warn(0, "[ERROR] Cannot describe branch '$branch' in VOB '$vob':\n$out$err");
}
next;
}
if($out =~ /^"(\S+)"/) {
$integ{$1}++;
}
}
my @ib = sort keys %integ;
unless(@ib) {
$this->log_warn(0, "[ERROR] No integration branch defined for branch '$branch' in any VOB.\n");
return;
}
elsif(@ib > 1) {
$this->log_warn(0, "[ERROR] Inconsistent definition of integration branch for branch '$branch':\n@ib\n");
$this->log_info(0, "[INFO] Will use '$ib[0]'.\n");
}
return $ib[0];
}
sub get_integration_labels
{
my ($this,@params) = @_;
my %args = validate_with(
params => \@params,
spec => {
BRANCH => { type => SCALAR },
});
my $branch = $args{BRANCH};
$this->log_info(0, "[INFO] Searching for labels...\n");
foreach my $vob (@{$this->{VOBS}}) {
Job->new(
vob => $vob,
command => [ qw(cleartool lstype), -kind => 'lbtype',
-fmt => '%n|%[INTEGRATION_BRANCH]SNa|%Nd\n', -invob => $vob ],
combine_err => 1
)->start;
}
my %labels;
while(my $job = Job->getCompletedJob) {
my $vob = $job->{vob};
my $out = $job->getOutput;
if($job->{status}) {
# report the problem, but do not set fail status
$this->log_warn(0, "[ERROR] Cannot list labels in VOB '$vob':\n$out");
next;
}
chomp $out;
foreach(split(/[\r\n]+/, $out)) {
if(/^([^|]+)\|"?([^|"]*)"?\|([^|]*)/) {
my ($label,$ibranch,$date) = ($1,$2,$3);
next if $label =~ /^(BACKSTOP|CHECKEDOUT|LATEST)$/;
if(($ibranch eq '' && $branch eq 'main') || $ibranch eq $branch) {
# store the earliest creation time
if(!$labels{$label} || $labels{$label}>$date) {
$labels{$label} = $date;
}
}
}
}
}
return sort { $labels{$a} <=> $labels{$b} } keys %labels;
}
# this is usually created on checkouts
sub create_incremental_baseline
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
ELEMENTS => { type => ARRAYREF },
COMMENT => { type => SCALAR, default => 'new baseline' },
ADDITIONAL_VOBS => { type => ARRAYREF, optional => 1 },
LABEL => { type => SCALAR|UNDEF, optional => 1 },
REPLACE => { type => SCALAR, default => 0 },
});
my $branch = $args{BRANCH};
my $previous = $this->get_recommended_baseline(BRANCH => $branch);
my $label = $args{LABEL} ? $args{LABEL} :
$this->increment_baseline_counter(BRANCH => $branch);
unless($label) {
$this->log_warn(0, "[ERROR] No baseline counter on branch '$branch', won't create a baseline.\n");
return;
}
return unless
$this->create_label_type(LABEL => $label, INTEG_BRANCH => $branch, COMMENT => $args{COMMENT},
PREDECESSOR => $previous, $args{ADDITIONAL_VOBS} ? (ADDITIONAL_VOBS => $args{ADDITIONAL_VOBS}) : ());
my $status = 1;
my @todo = @{$args{ELEMENTS}};
while(my @list = splice(@todo, 0, 100)) {
my @opts = qw(-nc);
if($args{REPLACE}) {
push(@opts, '-replace');
}
my ($stat,$out,$err) = cleartool('mklabel', @opts, $label, @list);
if($stat) {
$this->log_warn(0, "[ERROR] Could not apply label '$label' to elements:\n$out$err\n");
$status = 0;
}
}
if($status) {
$this->log_info(0, "[INFO] Successfully applied baseline label '$label' to ".
scalar(@{$args{ELEMENTS}})." element(s).\n");
return $label;
} else {
$this->log_warn(0, "[ERROR] There were problems labelling with baseline label '$label'.\n");
return;
}
}
# this method requires the view to be set to the appropriate config spec for labelling
sub create_full_baseline
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
LABEL => { type => SCALAR, optional => 1 },
COMMENT => { type => SCALAR, default => 'new full baseline' },
ADDITIONAL_VOBS => { type => ARRAYREF, optional => 1 }
});
my $branch = $args{BRANCH};
my $label = $args{LABEL};
unless($label) {
# create one according to counter
$label = $this->increment_baseline_counter(BRANCH => $branch);
unless($label) {
$this->log_warn(0, "[ERROR] No baseline counter on branch '$branch', won't create a baseline.\n");
return;
}
}
return unless
$this->create_label_type(LABEL => $label, INTEG_BRANCH => $branch, COMMENT => $args{COMMENT},
$args{ADDITIONAL_VOBS} ? (ADDITIONAL_VOBS => $args{ADDITIONAL_VOBS}) : ());
foreach my $vob (@{$this->{VOBS}}) {
$this->log_info(0, "[INFO] Starting labelling VOB '$vob'...\n");
# use external cleartool command, forking with an active CtCmd seems not good
Job->new(
vob => $vob,
command => [ qw(cleartool mklabel -rec -nc -silent), $label, "$vob/." ],
combine_err => 1
)->start;
} # end loop VOBs
my $label_ok = 1;
$this->log_info(0, "[INFO] Waiting for labelling to finish...\n");
while(my $job = Job->getCompletedJob) {
my $vob = $job->{vob};
if($job->{status}) {
# report the problem, but do not set fail status
$this->log_warn(0, "[ERROR] Problems while attaching label '$label' in VOB '$vob':\n". $job->getOutput."\n");
$label_ok = 0;
} else {
$this->log_info(0, "[INFO] Attached label '$label' to VOB '$vob'.\n");
}
} # loop labelling jobs done
# log message
if($label_ok) {
$this->log_info(0, "[INFO] Sucessfully applied baseline '$label' on integration branch '$branch' in all VOBs.\n\n");
} else {
$this->log_warn(0, "[ERROR] There were problems attaching the label '$label', please check with integrator.\n");
return;
}
return $label;
}
sub create_label_type
{
my $this = shift;
my %args = validate(@_, {
LABEL => { type => SCALAR },
INTEG_BRANCH => { type => SCALAR },
COMMENT => { type => SCALAR|UNDEF, optional => 1 },
PREDECESSOR => { type => SCALAR|UNDEF, optional => 1 },
ADDITIONAL_VOBS => { type => ARRAYREF, default => [] }
});
my $label = $args{LABEL};
my $ibranch = $args{INTEG_BRANCH};
my @comment_opt = $args{COMMENT} ? (-c => $args{COMMENT}) : qw(-nc);
my %seen;
my @vobs = grep(!$seen{$_}++, @{$this->{VOBS}}, @{$args{ADDITIONAL_VOBS}});
my $errs = 0;
foreach my $vob (@vobs) {
# create the label type
my ($stat,$out,$err) = cleartool(qw(mklbtype), @comment_opt, "$label\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot create label type '$label' in VOB '$vob':\n$out$err");
$errs++;
next; # no use to label this VOB
} else {
$this->log_info(0, "[INFO] Created label type '$label' in VOB '$vob'.\n");
}
# attach the attribute to mark to which integration branch the baseline belongs
($stat,$out,$err) = cleartool(qw(mkattr),
@comment_opt,
'INTEGRATION_BRANCH' => qq{"$ibranch"},
"lbtype:$label\@$vob");
if($stat) {
# this should never happen - but you never know...
$this->log_warn(0, "[ERROR] Cannot attach INTEGRATION_BRANCH attribute on label '$label' in VOB '$vob':\n$out$err\n");
}
# create hyperlink to point to predecessor
if($args{PREDECESSOR}) {
($stat,$out,$err) = cleartool(qw(mkhlink -nc), "INCREMENTAL_LABEL\@$vob",
"lbtype:$label\@$vob" => "lbtype:$args{PREDECESSOR}\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot create INCREMENTAL_LABEL hyperlink on label '$label' in VOB '$vob':\n$out$err\n");
}
}
} # loop VOBs
if($errs) {
$this->log_warn(0, "[ERROR] Could not consistently create label '$label' in all VOBs.\n");
return;
}
1;
}
sub get_view_checkouts
{
my $this = shift;
my ($stat,$out,$err) = cleartool(qw(lsco -cview -avob -short));
if($stat) {
$this->log_warn(0, "[ERROR] Problems occurred while listing checkouts to current view:\n$err\n");
}
$out ||= '';
chomp $out;
return split(/[\r\n]+/, $out);
}
sub get_recommended_baseline
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
my $branch = $args{BRANCH};
my %baselines;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('desc', -fmt => '%[RECOMMENDED_LABEL]NSa\n',
"brtype:$branch\@$vob");
if($stat && $err !~ /\bBranch type not found:/) {
$this->log_warn(0, "[WARNING] Cannot describe branch '$branch' in VOB '$vob':\n$out$err\n");
}
elsif($out =~ /"([^"]+)"/) {
my $bl = $1;
($stat,$out,$err) = cleartool('desc', -fmt => '%Nd\n', "lbtype:$bl\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot describe label '$bl' in VOB '$vob':\n$out$err\n");
next;
}
push(@{$baselines{$bl}{'vobs'}}, $vob);
chomp $out;
# find the oldest
if(!defined($baselines{$bl}{'date'}) || $baselines{$bl}{'date'} > $out) {
$baselines{$bl}{'date'} = $out;
}
}
}
# sort by the label age
my @bls = sort { $baselines{$a}{'date'} <=> $baselines{$b}{'date'} } keys %baselines;
return unless @bls;
if(@bls > 1) {
$this->log_warn(0, "[WARNING] Ambiguous definitions of RECOMMENDED_LABEL for branch '$branch':\n" . join('',
map { " $_ ($baselines{$_}{'date'}): ".join(' ',sort @{$baselines{$_}{'vobs'}})."\n" } @bls).
" To be on the safe side, will use the oldest one: $bls[0]\n");
}
return $bls[0];
}
sub set_recommended_baseline
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
LABEL => { type => SCALAR }
});
my $ok = 0;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool(qw(mkattr -replace), 'RECOMMENDED_LABEL', qq("$args{LABEL}"),
"brtype:$args{BRANCH}\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Could not recommend baseline '$args{LABEL}' on branch '$args{BRANCH}' in VOB '$vob':\n$out$err");
} else {
$ok++;
}
} # loop VOBs
if($ok) {
$this->log_info(0, "[INFO] Recommended baseline '$args{LABEL}' on branch '$args{BRANCH}'.\n");
}
$ok;
}
sub create_hyperlink
{
my $this = shift;
my %args = validate(@_, {
TYPE => { type => SCALAR },
FROM => { type => SCALAR },
TO => { type => SCALAR },
});
my $ok = 0;
my $errs = 0;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool(qw(mkhlink -nc), "$args{TYPE}\@$vob",
"$args{FROM}\@$vob" => "$args{TO}\@$vob");
if($stat) {
$errs++;
$this->log_warn(0, <<"EOT");
[ERROR] Could not draw hyperlink from '$args{FROM}' to '$args{TO}' in VOB '$vob':
$out$err
EOT
} else {
$ok++;
}
} # loop VOBs
if($ok) {
$this->log_info(0, "[INFO] Hyperlink created from '$args{FROM}' to '$args{TO}' in $ok VOB(s).\n");
}
return($errs ? 0 : 1);
}
sub lock_type
{
my $this = shift;
my %args = validate(@_, {
TYPE => { type => SCALAR },
OPTIONS => { type => ARRAYREF, optional => 1 },
COMMENT => { type => SCALAR, default => 'locked by CCAPI' }
});
my $ok = 0;
my $errs = 0;
my @opts = (-c => $args{COMMENT});
if($args{OPTIONS}) {
push(@opts, @{$args{OPTIONS}});
}
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool(qw(lock), @opts, "$args{TYPE}\@$vob");
if($stat) {
$errs++;
$this->log_warn(0, "[ERROR] Cannot lock '$args{TYPE}' in VOB '$vob':\n$out$err\n");
} else {
$ok++;
}
}
if($ok) {
$this->log_info(0, "[INFO] Locked '$args{TYPE}' in $ok VOB(s).\n");
}
return($errs ? 0 : 1);
}
sub increment_baseline_counter
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
});
my $branch = $args{BRANCH};
my %bls;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('desc',
-fmt => '%[BASELINE_COUNTER]SNa\n',
"brtype:$branch\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot read attribute BASELINE_COUNTER from branch $branch in VOB $vob:\n$out$err\n");
next;
}
chomp $out;
if($out =~ /"([^"]+)"/) {
$bls{$1}++;
}
} # loop VOBs
# use the "highest" one
my $bl = (sort keys %bls)[-1];
my $previous = $bl;
if($bl) {
# increment
$bl =~ s{^(.*\D)(\d+)}{$1.($2+1)}e;
$bl++ if $bl eq $previous;
} else {
# no counter - no increment
return;
}
# set the new counter value
# do not unlock the integration branch while doing this
unless($this->set_attribute_on_branch(BRANCH => $branch, NOUNLOCK => 1,
ATTRIBUTE => 'BASELINE_COUNTER', VALUE => $bl)) {
$this->log_warn(0, "[ERROR] Could not set new baseline counter, will use '$bl' anyway.\n");
}
return $bl;
}
sub unlock_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
my $ok = 0;
my $branch = $args{BRANCH};
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('lstype', -fmt => '%[locked]p\n',
"brtype:$branch\@$vob");
if($stat) {
# branch type not found - we don't care
next;
}
chomp $out;
if($out =~ /unlocked/i) {
# not locked - ok
$ok++;
next;
}
($stat,$out,$err) = cleartool('unlock', "brtype:$branch\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot unlock branch type '$branch' in VOB '$vob':\n$out$err");
next;
}
$ok++;
}
if($ok) {
$this->log_info(0, "[INFO] Branch type '$branch' unlocked in $ok VOB(s).\n");
}
return 1;
}
sub get_checkouts_on_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
local $ENV{CLEARCASE_AVOBS} = join($^O =~ /win/i ? ';':':', @{$this->{VOBS}});
my ($stat,$out,$err) = cleartool(qw(lsco -avob -arepl -short -brtype), $args{BRANCH});
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list checkouts on branch '$args{BRANCH}'.\n$out$err\n");
return;
}
chomp $out;
return split(/[\r\n]+/, $out);
}
sub get_branch_comment
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
my $branch = $args{BRANCH};
my %comments;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('desc', -fmt => '%c\n', "brtype:$branch\@$vob");
if($stat && $err !~ /\bBranch type not found:/) {
$this->log_warn(0, "[WARNING] Cannot get comment for branch $branch in VOB $vob:\n$out$err");
next;
}
$out =~ s/[\s\r\n]*$//s; # strip all trailing whitespace and newlines
$comments{$out}++ if length $out;
}
return join(", ", keys %comments);
}
# we support one-line comments for the time being
sub set_branch_comment
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
COMMENT => { type => SCALAR }
});
my $branch = $args{BRANCH};
my $errors = 0;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool('chevent', '-replace', -c => $args{COMMENT}, "brtype:$branch\@$vob");
if($stat) {
$this->log_warn(0, "[WARNING] Cannot attach comment to branch $branch in VOB $vob:\n$out$err");
$errors++;
next;
}
}
if($errors) {
return;
}
$this->log_info(0, "[INFO] Attached comment '$args{COMMENT}' to branch '$branch' in all VOBs.\n");
1;
}
sub get_branch_acs
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
my $branch = $args{BRANCH};
my %acses;
my $have_branch = 0;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool("desc -fmt '%[ACS]NSa\\n' brtype:$branch\@$vob");
if($stat) {
if($err !~ /\bBranch type not found:/) {
$this->log_warn(0, "[WARNING] Cannot get ACS attribute for branch $branch in VOB $vob:\n$out$err");
}
next;
}
$have_branch++;
chomp $out;
if($out =~ /"([^"]+)"/) {
$acses{$1}++;
}
}
my @ac = sort keys %acses;
unless(@ac) {
$this->log_warn(0, "[ERROR] No abstract config spec defined on branch '$branch' in any VOB.\n")
if $have_branch;
return;
}
elsif(@ac > 1) {
$this->log_warn(0, "[ERROR] Inconsistent definition of abstract config spec across VOBs on branch '$branch':\n@ac\n");
$this->log_info(0, "[INFO] Will use '$ac[0]'.\n");
}
return $ac[0];
}
sub set_branch_acs
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
ACS => { type => SCALAR }
});
$this->set_attribute_on_branch(
BRANCH => $args{BRANCH},
ATTRIBUTE => 'ACS',
VALUE => $args{ACS}
);
}
sub set_attribute_on_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
ATTRIBUTE => { type => SCALAR },
VALUE => { type => SCALAR },
NOUNLOCK => { type => SCALAR, default => 0 }
});
my @rfm;
my @mkattr_cmds;
foreach my $vob (@{$this->{VOBS}}) {
my $brt = "brtype:$args{BRANCH}\@$vob";
# get information of from branch
my ($stat,$out,$err) = cleartool("lstype",
-fmt => "%[locked]p|%[master]p|%[$args{ATTRIBUTE}]NSa\\n", $brt);
if($stat) {
if($err =~ /Branch type not found:/) {
$this->log_warn(2, "[ERROR] Cannot list properties of branch '$args{BRANCH}' in VOB '$vob':\n$out$err");
} else {
$this->log_warn(0, "[ERROR] Cannot list properties of branch '$args{BRANCH}' in VOB '$vob':\n$out$err");
}
next;
}
chomp $out;
unless($out =~ /^([^|]*)\|([^|]*)\|([^|]*)/) {
$this->log_warn(0, "[ERROR] Cannot match output:\n$out\n");
next;
}
my ($lock,$master,$plabel) = ($1,$2,$3);
# check whether to replace or set
my @mkattr_cmd;
if($out =~ /"([^"]*)"/) {
if($1 ne $args{VALUE}) {
$this->log_info(0, "[INFO] Attribute $args{ATTRIBUTE} on branch '$args{BRANCH}' was previously '$1' in VOB '$vob'.\n");
@mkattr_cmd = (qw(mkattr -replace), $args{ATTRIBUTE} => qq("$args{VALUE}"), $brt);
} else {
next; # nothing to do here
}
} else {
# attribute not yet present
@mkattr_cmd = ('mkattr', $args{ATTRIBUTE} => qq("$args{VALUE}"), $brt);
}
# try to unlock - succeeds only if VOB owner
if(!$args{NOUNLOCK} && $lock !~ /unlocked/) {
($stat,$out,$err) = cleartool('unlock', $brt);
# we don't show errors... will appear later anyway
}
# check mastership
my $local = $this->get_local_replica(VOB => $vob);
$master =~ s/\@.*$//;
if($master ne $local) {
push(@rfm, $brt);
}
push(@mkattr_cmds, [ @mkattr_cmd ]);
} # loop VOBs
$this->get_type_mastership(BRANCHES => \@rfm) if @rfm;
my $ok = 0;
foreach(@mkattr_cmds) {
my ($stat,$out,$err) = cleartool(@$_);
if($stat) {
$this->log_warn(0, "[WARNING] Cannot attach attribute $args{ATTRIBUTE}=$args{VALUE} to branch '$args{BRANCH}':\n$out$err\n");
} else {
$ok++;
}
}
if($ok) {
$this->log_info(0, "[INFO] Set attribute $args{ATTRIBUTE}=$args{VALUE} on branch '$args{BRANCH}' in $ok VOB(s).\n");
}
1;
}
my %LocalReplica;
sub get_local_replica
{
my $this = shift;
my %args = validate(@_, {
VOB => { type => SCALAR }
});
return $LocalReplica{$args{VOB}} if defined $LocalReplica{$args{VOB}};
my ($stat,$out,$err) = cleartool('desc', '-fmt', '%[replica_name]p\n', "vob:$args{VOB}");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot get master replica for VOB '$args{VOB}':$out$err\n");
$out = '';
}
chomp $out;
# remember the local replica name for each branch type
$LocalReplica{$args{VOB}} = $out; # $out does not have @vob extension!
}
sub check_branch_checkouts
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
});
# quick check for checkouts - we better document them
my ($stat,$out,$err) = cleartool(qw(lsco -avob -arepl),
-brtype => $args{BRANCH},
-fmt => ' %n\n view: %Tf host: %h\n');
if(!$stat && $out !~ /^\s*$/s) {
$this->log_warn(0, "[WARNING] There are checkouts on branch '$args{BRANCH}':\n$out\n");
return 1;
}
return 0;
}
# BRANCHES contains fully qualified types: brtype:name@vob
sub get_type_mastership
{
my $this = shift;
my %args = validate(@_, {
BRANCHES => { type => ARRAYREF },
TIMEOUT => { type => SCALAR, default => 2 },
ORIGINAL_MASTERSHIP => { type => HASHREF, optional => 1}
});
my @req_branches = @{$args{BRANCHES}};
return 1 unless @req_branches;
my %local_replica;
foreach my $brt (@req_branches) {
if($brt =~ /\@([^\@]+)$/) {
$local_replica{$brt} = $this->get_local_replica(VOB => $1);
}
}
my ($stat,$out,$err) = multitool('reqmaster', @req_branches);
my ($item, $action, $replica);
my %arriving;
my $failures = 0;
foreach(split(/[\r\n]+/, "$out$err")) {
chomp;
# brtype:buggler_trial_lnz: Change of mastership at sibling replica "smartilu_LUP_prj_lnz" was successful.
if(/^(\S+):\s+Change of mastership at sibling replica "([^"]*)" was successful/) {
# ok
($item,$replica) = ($1,$2);
}
# Mastership is in transit to the new master replica.
elsif(/^Mastership is in transit to the new master replica/ ||
/Mastership of this object is already in transit to this replica\./) {
# success, or...
# ...somebody else triggered the RFM, or we triggered it earlier
if($item) {
$arriving{$item}++;
$args{ORIGINAL_MASTERSHIP}->{$item} = $replica
if $args{ORIGINAL_MASTERSHIP};
} else {
$this->log_warn(0, "[ERROR] Don't know which branch type 'is in transit'.\n");
}
($item, $action, $replica) = (undef,undef,undef);
next;
}
# ClearCase::MtCmd: Error: brtype:main@/vobs/smartilu-LUP-fe_dig
elsif(/^(?:multitool|ClearCase::MtCmd):\s*Error:\s*(.*?)\s*$/) {
$item = $1;
next;
}
elsif(/^The following blocked the "([^"]*)" operation at replica "([^"]*)"/) {
($action,$replica) = ($1,$2);
next;
}
elsif(/^The following prevented the "([^"]*)" operation from succeeding/) {
$action = $1;
next;
}
# Error/The following blocked...
# Mastership of this object is already in transit to this replica.
# Please check that replicas are in sync at the both sites.
elsif(/^Please check that replicas are in sync at the both sites\./) {
# ignore this extra message line
next;
}
elsif($item && $action) {
# the line should now contain the error
if(/The object is already mastered by replica/) {
# this is OK
}
# Could not resolve object "brtype:buggler_trial_lnssssz@/vobs/smartilu-LUP-prj".
elsif(/^Could not resolve object/) {
# the branch type does not exist - this is OK
}
# e.g. " At least one checkout prevents the request."
# TODO list checkouts using -arepl and put in error message?
else {
$replica ||= '';
$this->log_warn(0, "[ERROR] Could not get mastership of branch '$item' (replica: $replica, action: $action):\n$_\n");
$failures++;
}
($item, $action, $replica) = (undef,undef,undef);
}
else {
$this->log_warn(0, "[WARNING] Extra line in reqmaster output: $_\n");
}
} # end loop lines
if($failures) {
$args{TIMEOUT} = 1; # shorten the timeout
}
# wait for the mastership to arrive
if(keys %arriving) {
$this->log_info(0, "[INFO] Waiting for mastership of branches to arrive...\n");
my $start = time(); # seconds
my $wait = $args{TIMEOUT} * 60;
while(my @list = keys %arriving) {
foreach my $brtype (@list) {
my ($stat,$out,$err) = cleartool('desc', '-fmt', '%[master]p\\n', $brtype);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot describe '$brtype' for mastership:\n$out$err");
$failures++;
delete $arriving{$brtype};
next;
}
if($out =~ /^([^\@]*)/ && $1 eq $local_replica{$brtype}) {
$this->log_info(0, "[INFO] Mastership of '$brtype' arrived.\n");
delete $arriving{$brtype};
}
}
# did not arrive yet
if(time() - $start > $wait && keys %arriving) {
$this->log_warn(0, "[ERROR] Request-for-mastership timed out for:\n ".join("\n ", sort keys %arriving)."\n");
%arriving = (); # that's it
$failures++;
} else {
sleep 1;
}
} # end loop waiting for arrival
} # if arriving
if($failures) {
$this->log_warn(0, "[ERROR] Could not get mastership for all branches.\n");
return 0;
} else {
$this->log_info(0, "[INFO] Mastership of all branches arrived.\n");
}
1;
}
sub lock_obsolete_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
});
my $ok = 0;
foreach my $vob (@{$this->{VOBS}}) {
my ($stat,$out,$err) = cleartool(qw(lock -replace -obsolete),
"brtype:$args{BRANCH}\@$vob");
if($stat) {
$this->log_warn(0, "[ERROR] Cannot lock obsolete branch type '$args{BRANCH}' in VOB '$vob':\n$out$err");
next;
}
$ok++;
}
if($ok) {
$this->log_info(0, "[INFO] Branch type '$args{BRANCH}' locked obsolete in $ok VOB(s).\n");
}
return 1;
}
sub setup_vobs
{
my $this = shift;
foreach my $vob (@{$this->{VOBS}}) {
# the root label for the task branch (previous use model)
$this->_mktype('attype', "BRANCH_ROOT_LABEL\@$vob", '-shared',
-vtype => 'string',
-c => "this attribute is for documenting which label a branch is rooted at; it is attached to the branch type");
# the ACS for the task branch
$this->_mktype('attype', "ACS\@$vob", '-shared',
-vtype => 'string',
-c => "this attribute is for documenting which abstract config spec a branch is configured with; it is attached to the branch type");
# for locking the integration branch during integration
$this->_mktype('attype', "INTEGRATING\@$vob", '-shared',
-vtype => 'string',
'-c' => 'for locking the branch while integrating');
# the integration branch attribute (on label types and task branches)
$this->_mktype('attype', "INTEGRATION_BRANCH\@$vob", '-shared',
-vtype => 'string',
-c => "this attribute is for documenting the corresponding integration branch name");
# who is the integrator for this branch
$this->_mktype('attype', "INTEGRATOR_EMAIL\@$vob", '-shared',
-vtype => 'string',
'-c' => 'email address of integrator(s) for this integration branch');
# the recommended label on the integration branches
$this->_mktype('attype', "RECOMMENDED_LABEL\@$vob", '-shared',
-vtype => 'string',
-c => "this attribute contains the most recent successfully integrated baseline label name");
# the state of the task branch
$this->_mktype('attype', "TASK_STATE\@$vob", '-shared',
-vtype => 'string',
'-enum' => q("open","ready","rejected","integrated","obsolete"),
'-c' => 'mark the state of development branches');
# the baseline counter
$this->_mktype('attype', "BASELINE_COUNTER\@$vob", '-shared',
-vtype => 'string',
'-c' => 'the name of the latest baseline created on this branch');
# the hyperlink that shows which branch was delivered to which baseline(s)
$this->_mktype('hltype', "DELIVERED_TO\@$vob", '-shared',
'-c' => 'to which baseline a branch was integrated');
# the hyperlink that shows which branch was delivered to which baseline(s)
$this->_mktype('hltype', "INCREMENTAL_LABEL\@$vob", '-shared',
'-c' => 'to which baseline a branch was integrated');
# for temporary view creation
$this->_mktype('attype', "VIEW_SETUP_WINDOWS\@$vob", '-shared',
-vtype => 'string',
'-c' => 'information about view server and storage for temporary views on Windows');
$this->_mktype('attype', "VIEW_SETUP_UNIX\@$vob", '-shared',
-vtype => 'string',
'-c' => 'information about view server and storage for temporary views on UNIX');
}
1;
}
sub _mktype
{
my ($this,$kind,$type,@cmd) = @_;
my ($stat,$out,$err) = cleartool('lstype', "$kind:$type");
unless($stat) {
# does exist
unshift(@cmd, '-replace');
}
($stat,$out,$err) = cleartool("mk$kind", @cmd, $type);
if($stat) {
$this->log_warn(0, "[ERROR] Cannot create/update $kind:$type\n$out$err\n");
return;
}
1;
}
sub findmerge_with_rfm
{
my $this = shift;
my %args = validate(@_, {
OPTIONS => { type => ARRAYREF },
COMMENT => { type => SCALAR, default => 'merging...' },
BATCH => { type => SCALAR, default => 200 },
TIMEOUT => { type => SCALAR, default => 2 }
});
my $comment = $args{COMMENT};
my @fm_opts = @{$args{OPTIONS}};
my @vob_arg = qw(-avob);
local $ENV{CLEARCASE_AVOBS} = join($^O =~ /win/i ? ';':':', @{$this->{VOBS}});
my @voblist = @{$this->{VOBS}};
my $iter = 0;
while(++$iter) {
# first determine the directories to be merged
$this->log_info(0, "[INFO] Checking for required directory merges (iteration $iter) ...\n");
my ($stat,$out,$err) = cleartool('findmerge', @vob_arg, -type => 'd', @fm_opts, '-print', '-nxn');
if($stat) {
$this->log_warn(0, "[ERROR] Cannot run findmerge for directories (@fm_opts):\n$out$err");
return 0;
}
chomp $out;
# we must sort to process the leafs first -
# the leaf directory might be renamed
my @dirs = sort { $b cmp $a } split(/[\n\r]+/, $out);
# check out, with eventual request-for-mastership
unless(@dirs) {
$this->log_info(0, "[INFO] No more directories to merge.\n");
last; # no more dirs to merge
}
$this->log_info(0, "[INFO] Need to checkout ".scalar(@dirs)." directory/ies.\n");
my $status = 1;
my @todo = @dirs;
while(my @list = splice(@todo, 0, $args{BATCH})) {
# TODO the way ccco is executed!
system('ccco', -timeout => $args{TIMEOUT}, -comment => $comment, @list);
if($?) {
$this->log_warn(0, "[ERROR] Could not check out all directories.\n");
$status = 0;
}
} # loop parts
unless($status) {
$this->log_warn(0, "[ERROR] Could not check out all elements - will not be able to merge.\n");
return;
}
# now directories are checked out, we are ready to merge the dirs
$this->log_info(0, "[INFO] Starting directory merges...\n");
$status = 1;
@todo = @dirs;
while(my @list = splice(@todo, 0, $args{BATCH})) {
system('cleartool', 'findmerge', @list, '-dir', @fm_opts, qw(-merge -gmerge));
if($?) {
$this->log_warn(0, "[ERROR] Error merging directories, while $comment:\n$out$err");
$status = 0;
last;
} else {
$this->log_info(0, "[INFO] Successfully merged ".scalar(@list)." directory/ies.\n");
}
}
unless($status) {
$this->log_warn(0, "[ERROR] Merge failed, aborting.\n");
return;
} else {
$this->log_info(0, "[INFO] Completed merge of ".scalar(@dirs)." directory/ies.\n");
}
# ... recurse - we might have more dirs to merge
# but only into the VOBs where dirs were merged
# TODO does this match on Windows? Which paths come out of findmerge on Win?
my @newlist;
foreach my $vob (@voblist) {
if(grep(m{^\Q$vob\E(?:/|\\|$)}, @dirs)) {
push(@newlist, $vob);
}
}
@voblist = @newlist;
@vob_arg = (@newlist, '-all');
} # outer loop
# now for the rest - the files
my ($stat,$out,$err) = cleartool('findmerge', '-avob', @fm_opts, '-print', '-nxn');
if($stat) {
$this->log_warn(0, "[ERROR] Cannot run findmerge for all elements, while $comment:\n$out$err");
return 0;
}
chomp $out;
my @elements = split(/[\n\r]+/, $out);
# check out, with eventual request-for-mastership
my $status = 1;
if(@elements) {
$this->log_info(0, "[INFO] Need to checkout ".scalar(@elements)." element(s).\n");
my @todo = @elements;
while(my @list = splice(@todo, 0, $args{BATCH})) {
system('ccco', -timeout => $args{TIMEOUT}, -comment => $comment, @list);
if($?) {
$this->log_warn(0, "[ERROR] Could not check out all elements.\n");
$status = 0;
}
} # loop parts
if($status) {
$this->log_info(0, "[INFO] Successfully checked out all elements.\n");
} else {
$this->log_warn(0, "[ERROR] Could not check out all elements - will not be able to merge.\n");
return 0;
}
} # have elements
# now we are ready to merge - all elements are checked out with RFM
system('cleartool', 'findmerge', '-avob', @fm_opts, '-merge', '-gmerge');
if($?) {
$this->log_warn(0, <<"EOT");
[ERROR] Merge failed. There may be pending checkouts. You can restart the merge with:
cleartool findmerge -avob @fm_opts -merge -gmerge
EOT
return;
}
$this->log_info(0, <<"EOT");
[INFO] The findmerge command successfully completed. Merge results (if any,
marked with: $comment)
are checked out now. Complete the merge process after verification
by checking in all checkouts.
EOT
return 1;
}
sub get_lock_status
{
my $this = shift;
my %args = validate(@_, {
OBJECT => { type => SCALAR }
});
my $lock;
my ($stat,$out,$err) = cleartool(qw(lslock -l), $args{OBJECT});
if($stat) {
$this->log_warn(0, "[ERROR] Cannot list lock status on '$args{OBJECT}':\n$out$err");
return;
}
# preserve the lock status; the lslock may give the following output:
# "Locked for all users."
# "Locked except for users: smartilu rouchal"
# "Locked except for users: smartilu rouchal
# this is a comment"
# "Locked for all users.
# this is a comment"
$out =~ s/\s+$//s;
if($out =~ /"Locked (?:except for users: ([^\r\n]*)|for all users\.)\s*(.*)"$/s) {
my ($users, $comment) = ($1,$2);
$users =~ s/^\s+|\s+$//g;
$comment =~ s/^\s+|\s+$//gs;
$users =~ s/\s+/,/g;
my @opts;
if($users) {
push(@opts, '-nusers', $users);
}
if($comment) {
push(@opts, '-c', $comment);
}
$lock = \@opts;
} else {
$lock = 0; # unlocked
}
return $lock;
}
sub get_integration_branches
{
my $this = shift;
foreach my $vob (@{$this->{VOBS}}) {
# use external cleartool command, forking with an active CtCmd seems not good
Job->new(
vob => $vob,
command => [ qw(cleartool lstype), -kind => 'brtype', -fmt => '%n %[RECOMMENDED_LABEL]SNa\n', -invob => $vob ],
combine_err => 1
)->start;
} # end loop VOBs
my %ibranches;
while(my $job = Job->getCompletedJob) {
my $vob = $job->{vob};
if($job->{status}) {
# report the problem, but do not set fail status
$this->log_warn(0, "[ERROR] Cannot get branches from VOB '$vob':\n". $job->getOutput."\n");
} else {
my $out = $job->getOutput;
chomp $out;
foreach(split(/[\r\n]+/, $out)) {
if(/^(\S+)\s+"([^"\s]+)"/) {
$ibranches{$1}++;
}
}
}
} # loop jobs done
return sort keys %ibranches;
}
sub get_branch_mastership
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR }
});
# branch types in all VOBs
my @req_branches = map { "brtype:$args{BRANCH}\@$_" } $this->get_vobs;
return 1 unless(@req_branches);
$this->{_branch_mastership}->{$args{BRANCH}} = {};
my $stat = $this->get_type_mastership(BRANCHES => \@req_branches,
ORIGINAL_MASTERSHIP => $this->{_branch_mastership}->{$args{BRANCH}});
return $stat;
}
sub return_all_branch_masterships
{
my $this = shift;
return 1 unless $this->{_branch_mastership};
foreach my $branch (sort keys %{$this->{_branch_mastership}}) {
$this->log_info(0, "INFO: Returning branch masterships of '$branch'...\n");
foreach my $brtype (sort keys %{$this->{_branch_mastership}->{$branch}}) {
my $replica = $this->{_branch_mastership}->{$branch}->{$brtype};
my ($stat,$out,$err) = multitool('chmaster', $replica, $brtype);
if($stat) {
$this->log_warn(0, "ERROR: Cannot change mastership of '$brtype' to replica '$replica':\n$out$err");
} else {
$this->log_info(0, "INFO: Mastership of '$brtype' returned to replica '$replica'\n");
}
}
}
1;
}
sub lock_integration_branch
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
COMMENT => { type => SCALAR, default => 'CM integration action in progress' },
USER => { type => SCALAR, default => (getpwuid($<))[0] }
});
unless($this->get_branch_mastership(BRANCH => $args{BRANCH})) {
$this->log_warn(0, <<"EOT");
ERROR: Could not get branch mastership for integration branch types '$args{BRANCH}'
to the local site. This problem has to be fixed before reattempting new
integrations.
EOT
return 0;
}
my $lockstatus = $this->{_lockstatus}->{$args{BRANCH}} = {};
my $ilocks = $this->{_integrationLocks}->{$args{BRANCH}} = [];
# first step: lock the branch types to avoid that integration starts at other replica
foreach my $vob ($this->get_vobs) {
my $brtype = "brtype:$args{BRANCH}\@$vob";
$lockstatus->{$brtype} = $this->get_lock_status(OBJECT => $brtype);
# now place the lock for integration
my ($stat,$out,$err) = cleartool(qw(lock -replace),
-c => $args{COMMENT}, -nuser => $args{USER}, $brtype);
if($stat) {
$this->log_warn(0, "ERROR: Cannot lock branch type '$args{BRANCH}' in VOB '$vob':\n$out$err");
# no further error handling here, will eventually lead to other errors later in this sub
}
}
# second step: attach attribute to branch type - this is an atomic operation
foreach my $vob ($this->get_vobs) {
my ($stat,$out,$err) = cleartool(qw(mkattr INTEGRATING), qq("$args{USER}"),
"brtype:$args{BRANCH}\@$vob");
if($stat) {
if($err =~ /Error: Object already has an attribute of type "INTEGRATING"/) {
# someone is already integrating
($stat,$out,$err) = cleartool('desc', -fmt => '%[INTEGRATING]a\\n',
"brtype:$args{BRANCH}\@$vob");
my $other = '<unknown>';
if($out =~ /\bINTEGRATING="([^"]+)"/) {
$other = $1;
}
$this->log_warn(0, "ERROR: Cannot integrate, currently user '$other' is integrating on branch '$args{BRANCH}' in VOB '$vob'.\n");
} else {
# other, unspecific error
$this->log_warn(0, "ERROR: Cannot lock branch '$args{BRANCH}' in VOB '$vob' for integration, mkattr failed:\n$out\n$err\n");
}
return 0;
}
push(@$ilocks, "brtype:$args{BRANCH}\@$vob");
}
$this->log_info(0, "INFO: Locked branch '$args{BRANCH}' for integration in all VOBs.\n");
1;
}
sub set_lock_status
{
my $this = shift;
my %args = validate(@_, {
BRANCH => { type => SCALAR },
OBJECT => { type => SCALAR },
OPTIONS => { type => ARRAYREF }
});
$this->{_lockstatus}->{$args{BRANCH}}->{$args{OBJECT}} = $args{OPTIONS};
}
# remove the (atomic) integration attribute
sub unlock_integration_branches
{
my $this = shift;
return 1 unless $this->{_integrationLocks};
my $status = 1;
foreach my $branch (sort keys %{$this->{_integrationLocks}}) {
$this->log_info(0, "INFO: Removing integration locks on branch '$branch'...\n");
foreach my $obj (@{$this->{_integrationLocks}->{$branch}}) {
my ($stat,$out,$err) = cleartool(qw(rmattr INTEGRATING), $obj);
if($stat) {
$this->log_warn(0, "ERROR: failed to remove INTEGRATING attribute from $obj:\n$out$err");
$status = 0;
}
} # end loop
$this->log_info(0, "INFO: Done removing integration locks.\n");
}
delete $this->{_integrationLocks};
return $status;
}
sub restore_locks_on_all_branches
{
my $this = shift;
return 1 unless $this->{_lockstatus};
my $status = 1;
foreach my $branch (sort keys %{$this->{_lockstatus}}) {
$this->log_info(0, "INFO: Restoring/setting lock status on branch '$branch'...\n");
foreach my $brtype (sort keys %{$this->{_lockstatus}->{$branch}}) {
my $lstat = $this->{_lockstatus}->{$branch}->{$brtype};
next unless defined $lstat;
my @opts = qw(unlock);
if($lstat) {
@opts = (qw(lock -replace),@{$lstat});
}
my ($stat,$out,$err) = cleartool(@opts, $brtype);
if($stat) {
$this->log_warn(0, "ERROR: Cannot restore lock status (@opts) on branch type '$brtype':\n$out$err");
$status = 0;
}
}
}
delete $this->{_lockstatus};
return $status;
}
1;