1218 lines
40 KiB
Perl
Executable File
1218 lines
40 KiB
Perl
Executable File
# ------------------------------------------------------------------------------
|
|
# NAME
|
|
# Fcm::CmBranch
|
|
#
|
|
# DESCRIPTION
|
|
# This class contains methods for manipulating a branch. It is a sub-class of
|
|
# Fcm::CmUrl, and inherits all methods from that class.
|
|
#
|
|
# COPYRIGHT
|
|
# (C) Crown copyright Met Office. All rights reserved.
|
|
# For further details please refer to the file COPYRIGHT.txt
|
|
# which you should have received as part of this distribution.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
package Fcm::CmBranch;
|
|
@ISA = qw(Fcm::CmUrl);
|
|
|
|
# Standard pragma
|
|
use warnings;
|
|
use strict;
|
|
|
|
# Standard modules
|
|
use Carp;
|
|
use File::Spec;
|
|
|
|
# FCM component modules
|
|
use Fcm::CmCommitMessage;
|
|
use Fcm::CmUrl;
|
|
use Fcm::Config;
|
|
use Fcm::Interactive;
|
|
use Fcm::Keyword;
|
|
use Fcm::Util qw/run_command e_report w_report svn_date/;
|
|
|
|
my @properties = (
|
|
'CREATE_REV', # revision at which the branch is created
|
|
'DELETE_REV', # revision at which the branch is deleted
|
|
'PARENT', # reference to parent branch Fcm::CmBranch
|
|
'ANCESTOR', # list of common ancestors with other branches
|
|
# key = URL, value = ancestor Fcm::CmBranch
|
|
'LAST_MERGE', # list of last merges from branches
|
|
# key = URL@REV, value = [TARGET, UPPER, LOWER]
|
|
'AVAIL_MERGE', # list of available revisions for merging
|
|
# key = URL@REV, value = [REV ...]
|
|
'CHILDREN', # list of children of this branch
|
|
'SIBLINGS', # list of siblings of this branch
|
|
);
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $cm_branch = Fcm::CmBranch->new (URL => $url,);
|
|
#
|
|
# DESCRIPTION
|
|
# This method constructs a new instance of the Fcm::CmBranch class.
|
|
#
|
|
# ARGUMENTS
|
|
# URL - URL of a branch
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub new {
|
|
my $this = shift;
|
|
my %args = @_;
|
|
my $class = ref $this || $this;
|
|
|
|
my $self = Fcm::CmUrl->new (%args);
|
|
|
|
$self->{$_} = undef for (@properties);
|
|
|
|
bless $self, $class;
|
|
return $self;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $url = $cm_branch->url_peg;
|
|
# $cm_branch->url_peg ($url);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns/sets the current URL.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub url_peg {
|
|
my $self = shift;
|
|
|
|
if (@_) {
|
|
if (! $self->{URL} or $_[0] ne $self->{URL}) {
|
|
# Re-set URL and other essential variables in the SUPER-class
|
|
$self->SUPER::url_peg (@_);
|
|
|
|
# Re-set essential variables
|
|
$self->{$_} = undef for (@properties);
|
|
}
|
|
}
|
|
|
|
return $self->{URL};
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rev = $cm_branch->create_rev;
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns the revision at which the branch was created.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub create_rev {
|
|
my $self = shift;
|
|
|
|
if (not $self->{CREATE_REV}) {
|
|
return unless $self->url_exists ($self->pegrev);
|
|
|
|
# Use "svn log" to find out the first revision of the branch
|
|
my %log = $self->svnlog (STOP_ON_COPY => 1);
|
|
|
|
# Look at log in ascending order
|
|
my $rev = (sort {$a <=> $b} keys %log) [0];
|
|
my $paths = $log{$rev}{paths};
|
|
|
|
# Get revision when URL is first added to the repository
|
|
if (exists $paths->{$self->branch_path}) {
|
|
$self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A';
|
|
}
|
|
}
|
|
|
|
return $self->{CREATE_REV};
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $parent = $cm_branch->parent;
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns the parent (a Fcm::CmBranch object) of the current
|
|
# branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub parent {
|
|
my $self = shift;
|
|
|
|
if (not $self->{PARENT}) {
|
|
# Use the log to find out the parent revision
|
|
my %log = $self->svnlog (REV => $self->create_rev);
|
|
|
|
if (exists $log{paths}{$self->branch_path}) {
|
|
my $path = $log{paths}{$self->branch_path};
|
|
|
|
if ($path->{action} eq 'A') {
|
|
if (exists $path->{'copyfrom-path'}) {
|
|
# Current branch is copied from somewhere, set the source as the parent
|
|
my $url = $self->root . $path->{'copyfrom-path'};
|
|
my $rev = $path->{'copyfrom-rev'};
|
|
$self->{PARENT} = Fcm::CmBranch->new (URL => $url . '@' . $rev);
|
|
|
|
} else {
|
|
# Current branch is not copied from somewhere
|
|
$self->{PARENT} = $self;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
return $self->{PARENT};
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $rev = $cm_branch->delete_rev;
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns the revision at which the branch was deleted.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub delete_rev {
|
|
my $self = shift;
|
|
|
|
if (not $self->{DELETE_REV}) {
|
|
return if $self->url_exists ('HEAD');
|
|
|
|
# Container of the current URL
|
|
(my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##;
|
|
|
|
# Use "svn log" on the container between a revision where the branch exists
|
|
# and the HEAD
|
|
my $dir = Fcm::CmUrl->new (URL => $dir_url);
|
|
my %log = $dir->svnlog (
|
|
REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)],
|
|
);
|
|
|
|
# Go through the log to see when branch no longer exists
|
|
for my $rev (sort {$a <=> $b} keys %log) {
|
|
next unless exists $log{$rev}{paths}{$self->branch_path} and
|
|
$log{$rev}{paths}{$self->branch_path}{action} eq 'D';
|
|
|
|
$self->{DELETE_REV} = $rev;
|
|
last;
|
|
}
|
|
}
|
|
|
|
return $self->{DELETE_REV};
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $flag = $cm_branch->is_child_of ($branch);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns true if the current branch is a child of $branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub is_child_of {
|
|
my ($self, $branch) = @_;
|
|
|
|
# The trunk cannot be a child branch
|
|
return if $self->is_trunk;
|
|
|
|
# If $branch is a branch, use name of $self to see when it is created
|
|
if ($branch->is_branch and $self->url =~ m#/r(\d+)_[^/]+/*$#) {
|
|
my $rev = $1;
|
|
|
|
# $self can only be a child if it is copied from a revision > the create
|
|
# revision of $branch
|
|
return if $rev < $branch->create_rev;
|
|
}
|
|
|
|
return if $self->parent->url ne $branch->url;
|
|
|
|
# If $branch is a branch, ensure that it is created before $self
|
|
return if $branch->is_branch and $self->create_rev <= $branch->create_rev;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $flag = $cm_branch->is_sibling_of ($branch);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns true if the current branch is a sibling of $branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub is_sibling_of {
|
|
my ($self, $branch) = @_;
|
|
|
|
# The trunk cannot be a sibling branch
|
|
return if $branch->is_trunk;
|
|
|
|
return if $self->parent->url ne $branch->parent->url;
|
|
|
|
# If the parent is a branch, ensure they are actually the same branch
|
|
return if $branch->parent->is_branch and
|
|
$self->parent->create_rev != $branch->parent->create_rev;
|
|
|
|
return 1;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $self->_get_relatives ($relation);
|
|
#
|
|
# DESCRIPTION
|
|
# This method sets the $self->{$relation} variable by inspecting the list of
|
|
# branches at the current revision of the current branch. $relation can be
|
|
# either "CHILDREN" or "SIBLINGS".
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub _get_relatives {
|
|
my ($self, $relation) = @_;
|
|
|
|
my @branch_list = $self->branch_list;
|
|
|
|
$self->{$relation} = [];
|
|
|
|
# If we are searching for CHILDREN, get list of SIBLINGS, and vice versa
|
|
my $other = ($relation eq 'CHILDREN' ? 'SIBLINGS' : 'CHILDREN');
|
|
my %other_list;
|
|
if ($self->{$other}) {
|
|
%other_list = map {$_->url, 1} @{ $self->{$other} };
|
|
}
|
|
|
|
for my $u (@branch_list) {
|
|
# Ignore URL of current branch and its parent
|
|
next if $u eq $self->url;
|
|
next if $self->is_branch and $u eq $self->parent->url;
|
|
|
|
# Ignore if URL is a branch detected to be another type of relative
|
|
next if exists $other_list{$u};
|
|
|
|
# Construct new Fcm::CmBranch object from branch URL
|
|
my $url = $u . ($self->pegrev ? '@' . $self->pegrev : '');
|
|
my $branch = Fcm::CmBranch->new (URL => $url);
|
|
|
|
# Test whether $branch is a relative we are looking for
|
|
if ($relation eq 'CHILDREN') {
|
|
push @{ $self->{$relation} }, $branch if $branch->is_child_of ($self);
|
|
|
|
} else {
|
|
push @{ $self->{$relation} }, $branch if $branch->is_sibling_of ($self);
|
|
}
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# @children = $cm_branch->children;
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a list of children (Fcm::CmBranch objects) of the
|
|
# current branch that exists in the current revision.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub children {
|
|
my $self = shift;
|
|
|
|
$self->_get_relatives ('CHILDREN') if not $self->{CHILDREN};
|
|
|
|
return @{ $self->{CHILDREN} };
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# @siblings = $cm_branch->siblings;
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a list of siblings (Fcm::CmBranch objects) of the
|
|
# current branch that exists in the current revision.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub siblings {
|
|
my $self = shift;
|
|
|
|
$self->_get_relatives ('SIBLINGS') if not $self->{SIBLINGS};
|
|
|
|
return @{ $self->{SIBLINGS} };
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $ancestor = $cm_branch->ancestor ($branch);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns the common ancestor (a Fcm::CmBranch object) of a
|
|
# specified $branch and the current branch. The argument $branch must be a
|
|
# Fcm::CmBranch object. Both the current branch and $branch are assumed to be
|
|
# in the same project.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub ancestor {
|
|
my ($self, $branch) = @_;
|
|
|
|
if (not exists $self->{ANCESTOR}{$branch->url_peg}) {
|
|
if ($self->url_peg eq $branch->url_peg) {
|
|
$self->{ANCESTOR}{$branch->url_peg} = $self;
|
|
|
|
} else {
|
|
# Get family tree of current branch, from trunk to current branch
|
|
my @this_family = ($self);
|
|
while (not $this_family [0]->is_trunk) {
|
|
unshift @this_family, $this_family [0]->parent;
|
|
}
|
|
|
|
# Get family tree of $branch, from trunk to $branch
|
|
my @that_family = ($branch);
|
|
while (not $that_family [0]->is_trunk) {
|
|
unshift @that_family, $that_family [0]->parent;
|
|
}
|
|
|
|
# Find common ancestor from list of parents
|
|
my $ancestor = undef;
|
|
|
|
while (not $ancestor) {
|
|
# $this and $that should both start as some revisions on the trunk.
|
|
# Walk down a generation each time it loops around.
|
|
my $this = shift @this_family;
|
|
my $that = shift @that_family;
|
|
|
|
if ($this->url eq $that->url) {
|
|
if ($this->is_trunk or $this->create_rev eq $that->create_rev) {
|
|
# $this and $that are the same branch
|
|
if (@this_family and @that_family) {
|
|
# More generations in both branches, try comparing the next
|
|
# generations.
|
|
next;
|
|
|
|
} else {
|
|
# End of lineage in one of the branches, ancestor is at the lower
|
|
# revision of the current URL.
|
|
if ($this->pegrev and $that->pegrev) {
|
|
$ancestor = $this->pegrev < $that->pegrev ? $this : $that;
|
|
|
|
} else {
|
|
$ancestor = $this->pegrev ? $this : $that;
|
|
}
|
|
}
|
|
|
|
} else {
|
|
# Despite the same URL, $this and $that are different branches as
|
|
# they are created at different revisions. The ancestor must be the
|
|
# parent with the lower revision. (This should not occur at the
|
|
# start.)
|
|
$ancestor = $this->parent->pegrev < $that->parent->pegrev
|
|
? $this->parent : $that->parent;
|
|
}
|
|
|
|
} else {
|
|
# Different URLs, ancestor must be the parent with the lower revision.
|
|
# (This should not occur at the start.)
|
|
$ancestor = $this->parent->pegrev < $that->parent->pegrev
|
|
? $this->parent : $that->parent;
|
|
}
|
|
}
|
|
|
|
$self->{ANCESTOR}{$branch->url_peg} = $ancestor;
|
|
}
|
|
}
|
|
|
|
return $self->{ANCESTOR}{$branch->url_peg};
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# ($target, $upper, $lower) = $cm_branch->last_merge_from (
|
|
# $branch, $stop_on_copy,
|
|
# );
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a 3-element list with information of the last merge
|
|
# into the current branch from a specified $branch. The first element in the
|
|
# list $target (a Fcm::CmBranch object) is the target at which the merge was
|
|
# performed. (This can be the current branch or a parent branch up to the
|
|
# common ancestor with the specified $branch.) The second and third elements,
|
|
# $upper and $lower, (both Fcm::CmBranch objects), are the upper and lower
|
|
# ends of the source delta. If there is no merge from $branch into the
|
|
# current branch from their common ancestor to the current revision, this
|
|
# method will return an empty list. If $stop_on_copy is specified, it ignores
|
|
# merges from parents of $branch, and merges into parents of the current
|
|
# branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub last_merge_from {
|
|
my ($self, $branch, $stop_on_copy) = @_;
|
|
|
|
if (not exists $self->{LAST_MERGE}{$branch->url_peg}) {
|
|
# Get "log" of current branch down to the common ancestor
|
|
my %log = $self->svnlog (
|
|
REV => [
|
|
($self->pegrev ? $self->pegrev : 'HEAD'),
|
|
$self->ancestor ($branch)->pegrev,
|
|
],
|
|
|
|
STOP_ON_COPY => $stop_on_copy,
|
|
);
|
|
|
|
my $cr = $self;
|
|
|
|
# Go down the revision log, checking for merge template messages
|
|
REV: for my $rev (sort {$b <=> $a} keys %log) {
|
|
# Loop each line of the log message at each revision
|
|
my @msg = split /\n/, $log{$rev}{msg};
|
|
|
|
# Also consider merges into parents of current branch
|
|
$cr = $cr->parent if ($cr->is_branch and $rev < $cr->create_rev);
|
|
|
|
for (@msg) {
|
|
# Ignore unless log message matches a merge template
|
|
next unless /Merged into \S+: (\S+) cf\. (\S+)/;
|
|
|
|
# Upper $1 and lower $2 ends of the source delta
|
|
my $u_path = $1;
|
|
my $l_path = $2;
|
|
|
|
# Add the root directory to the paths if necessary
|
|
$u_path = '/' . $u_path if substr ($u_path, 0, 1) ne '/';
|
|
$l_path = '/' . $l_path if substr ($l_path, 0, 1) ne '/';
|
|
|
|
# Only consider merges with specified branch (and its parent)
|
|
(my $path = $u_path) =~ s/@(\d+)$//;
|
|
my $u_rev = $1;
|
|
|
|
my $br = $branch;
|
|
$br = $br->parent while (
|
|
$br->is_branch and $u_rev < $br->create_rev and not $stop_on_copy
|
|
);
|
|
|
|
next unless $br->branch_path eq $path;
|
|
|
|
# If $br is a parent of branch, ignore those merges with the parent
|
|
# above the branch point of the current branch
|
|
next if $br->pegrev and $br->pegrev < $u_rev;
|
|
|
|
# Set the return values
|
|
$self->{LAST_MERGE}{$branch->url_peg} = [
|
|
Fcm::CmBranch->new (URL => $cr->url . '@' . $rev), # target
|
|
Fcm::CmBranch->new (URL => $self->root . $u_path), # delta upper
|
|
Fcm::CmBranch->new (URL => $self->root . $l_path), # delta lower
|
|
];
|
|
|
|
last REV;
|
|
}
|
|
}
|
|
}
|
|
|
|
return (exists $self->{LAST_MERGE}{$branch->url_peg}
|
|
? @{ $self->{LAST_MERGE}{$branch->url_peg} } : ());
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# @revs = $cm_branch->avail_merge_from ($branch[, $stop_on_copy]);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a list of revisions of a specified $branch, which are
|
|
# available for merging into the current branch. If $stop_on_copy is
|
|
# specified, it will not list available merges from the parents of $branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub avail_merge_from {
|
|
my ($self, $branch, $stop_on_copy) = @_;
|
|
|
|
if (not exists $self->{AVAIL_MERGE}{$branch->url_peg}) {
|
|
# Find out the revision of the upper delta at the last merge from $branch
|
|
# If no merge is found, use revision of common ancestor with $branch
|
|
my @last_merge = $self->last_merge_from ($branch);
|
|
my $rev = $self->ancestor ($branch)->pegrev;
|
|
$rev = $last_merge [1]->pegrev
|
|
if @last_merge and $last_merge [1]->pegrev > $rev;
|
|
|
|
# Get the "log" of the $branch down to $rev
|
|
my %log = $branch->svnlog (
|
|
REV => [($branch->pegrev ? $branch->pegrev : 'HEAD'), $rev],
|
|
STOP_ON_COPY => $stop_on_copy,
|
|
);
|
|
|
|
# No need to include $rev itself, as it has already been merged
|
|
delete $log{$rev};
|
|
|
|
# No need to include the branch create revision
|
|
delete $log{$branch->create_rev}
|
|
if $branch->is_branch and exists $log{$branch->create_rev};
|
|
|
|
if (keys %log) {
|
|
# Check whether there is a latest merge from $self into $branch, if so,
|
|
# all revisions of $branch below that merge should become unavailable
|
|
my @last_merge_into = $branch->last_merge_from ($self);
|
|
|
|
if (@last_merge_into) {
|
|
for my $rev (keys %log) {
|
|
delete $log{$rev} if $rev < $last_merge_into [0]->pegrev;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Available merges include all revisions above the branch creation revision
|
|
# or the revision of the last merge
|
|
$self->{AVAIL_MERGE}{$branch->url_peg} = [sort {$b <=> $a} keys %log];
|
|
}
|
|
|
|
return @{ $self->{AVAIL_MERGE}{$branch->url_peg} };
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $lower = $cm_branch->base_of_merge_from ($branch);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns the lower delta (a Fcm::CmBranch object) for the next
|
|
# merge from $branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub base_of_merge_from {
|
|
my ($self, $branch) = @_;
|
|
|
|
# Base is the ancestor if there is no merge between $self and $branch
|
|
my $return = $self->ancestor ($branch);
|
|
|
|
# Get configuration for the last merge from $branch to $self
|
|
my @merge_from = $self->last_merge_from ($branch);
|
|
|
|
# Use the upper delta of the last merge from $branch, as all revisions below
|
|
# that have already been merged into the $self
|
|
$return = $merge_from [1]
|
|
if @merge_from and $merge_from [1]->pegrev > $return->pegrev;
|
|
|
|
# Get configuration for the last merge from $self to $branch
|
|
my @merge_into = $branch->last_merge_from ($self);
|
|
|
|
# Use the upper delta of the last merge from $self, as the current revision
|
|
# of $branch already contains changes of $self up to the peg revision of the
|
|
# upper delta
|
|
$return = $merge_into [1]
|
|
if @merge_into and $merge_into [0]->pegrev > $return->pegrev;
|
|
|
|
return $return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $flag = $cm_branch->allow_subdir_merge_from ($branch, $subdir);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns true if a merge from the sub-directory $subdir in
|
|
# $branch is allowed - i.e. it does not result in losing changes made in
|
|
# $branch outside of $subdir.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub allow_subdir_merge_from {
|
|
my ($self, $branch, $subdir) = @_;
|
|
|
|
# Get revision at last merge from $branch or ancestor
|
|
my @merge_from = $self->last_merge_from ($branch);
|
|
my $last = @merge_from ? $merge_from [1] : $self->ancestor ($branch);
|
|
my $rev = $last->pegrev;
|
|
|
|
my $return = 1;
|
|
if ($branch->pegrev > $rev) {
|
|
# Use "svn diff --summarize" to work out what's changed between last
|
|
# merge/ancestor and current revision
|
|
my $range = $branch->pegrev . ':' . $rev;
|
|
my @out = &run_command (
|
|
[qw/svn diff --summarize -r/, $range, $branch->url_peg], METHOD => 'qx',
|
|
);
|
|
|
|
# Returns false if there are changes outside of $subdir
|
|
my $url = join ('/', $branch->url, $subdir);
|
|
for my $line (@out) {
|
|
chomp $line;
|
|
$line = substr ($line, 7); # file name begins at column 7
|
|
if ($line !~ m#^$url(?:/|$)#) {
|
|
$return = 0;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
return $return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $cm_branch->create (
|
|
# SRC => $src,
|
|
# TYPE => $type,
|
|
# NAME => $name,
|
|
# [PASSWORD => $password,]
|
|
# [REV_FLAG => $rev_flag,]
|
|
# [TICKET => \@tickets,]
|
|
# [REV => $rev,]
|
|
# [NON_INTERACTIVE => 1,]
|
|
# [SVN_NON_INTERACTIVE => 1,]
|
|
# );
|
|
#
|
|
# DESCRIPTION
|
|
# This method creates a branch in a Subversion repository.
|
|
#
|
|
# OPTIONS
|
|
# SRC - reference to a Fcm::CmUrl object.
|
|
# TYPE - Specify the branch type. See help in "fcm branch" for
|
|
# further information.
|
|
# NAME - specify the name of the branch.
|
|
# NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE
|
|
# to true automatically.
|
|
# PASSWORD - specify the password for commit access.
|
|
# REV - specify the operative revision of the source.
|
|
# REV_FLAG - A flag to specify the behaviour of the prefix to the
|
|
# branch name. See help in "fcm branch" for further
|
|
# information.
|
|
# SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit,
|
|
# etc. This option is implied by NON_INTERACTIVE.
|
|
# TICKET - Specify one or more related tickets for the branch.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub create {
|
|
my $self = shift;
|
|
my %args = @_;
|
|
|
|
# Options
|
|
# ----------------------------------------------------------------------------
|
|
# Compulsory options
|
|
my $src = $args{SRC};
|
|
my $type = $args{TYPE};
|
|
my $name = $args{NAME};
|
|
|
|
# Other options
|
|
my $rev_flag = $args{REV_FLAG} ? $args{REV_FLAG} : 'NORMAL';
|
|
my @tickets = exists $args{TICKET} ? @{ $args{TICKET} } : ();
|
|
my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef;
|
|
my $orev = exists $args{REV} ? $args{REV} : 'HEAD';
|
|
|
|
my $non_interactive = exists $args{NON_INTERACTIVE}
|
|
? $args{NON_INTERACTIVE} : 0;
|
|
my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE}
|
|
? $args{SVN_NON_INTERACTIVE} : 0;
|
|
$svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive;
|
|
|
|
# Analyse the source URL
|
|
# ----------------------------------------------------------------------------
|
|
# Create branch from the trunk by default
|
|
$src->branch ('trunk') if not $src->branch;
|
|
|
|
# Remove "sub-directory" part from source URL
|
|
$src->subdir ('') if $src->subdir;
|
|
|
|
# Remove "peg revision" part because it does not work with "svn copy"
|
|
$src->pegrev ('') if $src->pegrev;
|
|
|
|
# Find out the URL and the last changed revision of the specified URL at the
|
|
# specified operative revision
|
|
my $url = $src->svninfo (FLAG => 'URL', REV => $orev);
|
|
e_report $src->url, ': cannot determine the operative URL at revision ',
|
|
$orev, ', abort.' if not $url;
|
|
|
|
$src->url ($url) if $url ne $src->url;
|
|
|
|
my $rev = $src->svninfo (FLAG => 'Last Changed Rev', REV => $orev);
|
|
e_report $src->url, ': cannot determine the last changed rev at revision',
|
|
$orev, ', abort.' if not $rev;
|
|
|
|
# Warn user if last changed revision is not the specified revision
|
|
w_report 'Warning: branch will be created from revision ', $rev,
|
|
', i.e. the last changed rev.'
|
|
unless $orev and $orev eq $rev;
|
|
|
|
# Determine the sub-directory names of the branch
|
|
# ----------------------------------------------------------------------------
|
|
my @branch_dirs = ('branches');
|
|
|
|
# Split branch type flags into a hash table
|
|
my %type_flags = ();
|
|
$type_flags{$_} = 1 for ((split /$Fcm::Config::DELIMITER/, $type));
|
|
|
|
# Branch sub-directory 1, development, test or package
|
|
for my $flag (qw/DEV TEST PKG/) {
|
|
if (exists $type_flags{$flag}) {
|
|
push @branch_dirs, lc ($flag);
|
|
last;
|
|
}
|
|
}
|
|
|
|
# Branch sub-directory 2, user, share, configuration or release
|
|
if (exists $type_flags{USER}) {
|
|
die 'Unable to determine your user ID, abort' unless $self->config->user_id;
|
|
|
|
push @branch_dirs, $self->config->user_id;
|
|
|
|
} else {
|
|
for my $flag (keys %Fcm::CmUrl::owner_keywords) {
|
|
if (exists $type_flags{uc ($flag)}) {
|
|
push @branch_dirs, $flag;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
# Branch sub-directory 3, branch name
|
|
# Prefix branch name with revision number/keyword if necessary
|
|
my $prefix = '';
|
|
if ($rev_flag ne 'NONE') {
|
|
$prefix = $rev;
|
|
|
|
# Attempt to replace revision number with a revision keyword if necessary
|
|
if ($rev_flag eq 'NORMAL') {
|
|
$prefix = (Fcm::Keyword::unexpand($src->url_peg(), $rev))[1];
|
|
}
|
|
|
|
# $prefix is still a revision number, add "r" in front of it
|
|
$prefix = 'r' . $prefix if $prefix eq $rev;
|
|
|
|
# Add an underscore before the branch name
|
|
$prefix.= '_';
|
|
}
|
|
|
|
# Branch name
|
|
push @branch_dirs, $prefix . $name;
|
|
|
|
# Check whether the branch already exists, fail if so
|
|
# ----------------------------------------------------------------------------
|
|
# Construct the URL of the branch
|
|
$self->project_url ($src->project_url);
|
|
$self->branch (join ('/', @branch_dirs));
|
|
|
|
# Check that branch does not already exists
|
|
e_report $self->url, ': branch already exists, abort.' if $self->url_exists;
|
|
|
|
# Message for the commit log
|
|
# ----------------------------------------------------------------------------
|
|
my @message = ('Created ' . $self->branch_path . ' from ' .
|
|
$src->branch_path . '@' . $rev . '.' . "\n");
|
|
|
|
# Add related Trac ticket links to commit log if set
|
|
if (@tickets) {
|
|
my $ticket_mesg = 'Relates to ticket' . (@tickets > 1 ? 's' : '');
|
|
|
|
while (my $ticket = shift @tickets) {
|
|
$ticket_mesg .= ' #' . $ticket;
|
|
$ticket_mesg .= (@tickets > 1 ? ',' : ' and') if @tickets >= 1;
|
|
}
|
|
|
|
push @message, $ticket_mesg . ".\n";
|
|
}
|
|
|
|
# Create a temporary file for the commit log message
|
|
my $ci_mesg = Fcm::CmCommitMessage->new;
|
|
$ci_mesg->auto_mesg (\@message);
|
|
$ci_mesg->ignore_mesg (['A' . ' ' x 4 . $self->url . "\n"]);
|
|
my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive);
|
|
|
|
# Check with the user to see if he/she wants to go ahead
|
|
# ----------------------------------------------------------------------------
|
|
if (not $non_interactive) {
|
|
my $reply = Fcm::Interactive::get_input(
|
|
title => 'fcm branch',
|
|
message => 'Would you like to go ahead and create this branch?',
|
|
type => 'yn',
|
|
default => 'n',
|
|
);
|
|
|
|
return unless $reply eq 'y';
|
|
}
|
|
|
|
# Ensure existence of container sub-directories of the branch
|
|
# ----------------------------------------------------------------------------
|
|
for my $i (0 .. $#branch_dirs - 1) {
|
|
my $subdir = join ('/', @branch_dirs[0 .. $i]);
|
|
my $subdir_url = Fcm::CmUrl->new (URL => $src->project_url . '/' . $subdir);
|
|
|
|
# Check whether each sub-directory of the branch already exists,
|
|
# if sub-directory does not exist, create it
|
|
next if $subdir_url->url_exists;
|
|
|
|
print 'Creating sub-directory: ', $subdir, "\n";
|
|
|
|
my @command = (
|
|
qw/svn mkdir/,
|
|
'-m', 'Created ' . $subdir . ' directory.',
|
|
($svn_non_interactive ? '--non-interactive' : ()),
|
|
(defined $password ? ('--password', $password) : ()),
|
|
|
|
$subdir_url->url,
|
|
);
|
|
&run_command (\@command);
|
|
}
|
|
|
|
# Create the branch
|
|
# ----------------------------------------------------------------------------
|
|
{
|
|
print 'Creating branch ', $self->url, ' ...', "\n";
|
|
my @command = (
|
|
qw/svn copy/,
|
|
'-r', $rev,
|
|
'-F', $logfile,
|
|
($svn_non_interactive ? '--non-interactive' : ()),
|
|
(defined $password ? ('--password', $password) : ()),
|
|
|
|
$src->url, $self->url,
|
|
);
|
|
&run_command (\@command);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $cm_branch->delete (
|
|
# [NON_INTERACTIVE => 1,]
|
|
# [PASSWORD => $password,]
|
|
# [SVN_NON_INTERACTIVE => 1,]
|
|
# );
|
|
#
|
|
# DESCRIPTION
|
|
# This method deletes the current branch from the Subversion repository.
|
|
#
|
|
# OPTIONS
|
|
# NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE
|
|
# to true automatically.
|
|
# PASSWORD - specify the password for commit access.
|
|
# SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit,
|
|
# etc. This option is implied by NON_INTERACTIVE.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub del {
|
|
my $self = shift;
|
|
my %args = @_;
|
|
|
|
# Options
|
|
# ----------------------------------------------------------------------------
|
|
my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef;
|
|
my $non_interactive = exists $args{NON_INTERACTIVE}
|
|
? $args{NON_INTERACTIVE} : 0;
|
|
my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE}
|
|
? $args{SVN_NON_INTERACTIVE} : 0;
|
|
$svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive;
|
|
|
|
# Ensure URL is a branch
|
|
# ----------------------------------------------------------------------------
|
|
e_report $self->url_peg, ': not a branch, abort.' if not $self->is_branch;
|
|
|
|
# Message for the commit log
|
|
# ----------------------------------------------------------------------------
|
|
my @message = ('Deleted ' . $self->branch_path . '.' . "\n");
|
|
|
|
# Create a temporary file for the commit log message
|
|
my $ci_mesg = Fcm::CmCommitMessage->new;
|
|
$ci_mesg->auto_mesg (\@message);
|
|
$ci_mesg->ignore_mesg (['D' . ' ' x 4 . $self->url . "\n"]);
|
|
my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive);
|
|
|
|
# Check with the user to see if he/she wants to go ahead
|
|
# ----------------------------------------------------------------------------
|
|
if (not $non_interactive) {
|
|
my $mesg = '';
|
|
my $user = $self->config->user_id;
|
|
|
|
if ($user and $self->branch_owner ne $user) {
|
|
$mesg .= "\n";
|
|
|
|
if (exists $Fcm::CmUrl::owner_keywords{$self->branch_owner}) {
|
|
my $type = $Fcm::CmUrl::owner_keywords{$self->branch_owner};
|
|
$mesg .= '*** WARNING: YOU ARE DELETING A ' . uc ($type) .
|
|
' BRANCH.';
|
|
|
|
} else {
|
|
$mesg .= '*** WARNING: YOU ARE DELETING A BRANCH NOT OWNED BY YOU.';
|
|
}
|
|
|
|
$mesg .= "\n" .
|
|
'*** Please ensure that you have the owner\'s permission.' .
|
|
"\n\n";
|
|
}
|
|
|
|
$mesg .= 'Would you like to go ahead and delete this branch?';
|
|
|
|
my $reply = Fcm::Interactive::get_input (
|
|
title => 'fcm branch',
|
|
message => $mesg,
|
|
type => 'yn',
|
|
default => 'n',
|
|
);
|
|
|
|
return unless $reply eq 'y';
|
|
}
|
|
|
|
# Delete branch if answer is "y" for "yes"
|
|
# ----------------------------------------------------------------------------
|
|
print 'Deleting branch ', $self->url, ' ...', "\n";
|
|
my @command = (
|
|
qw/svn delete/,
|
|
'-F', $logfile,
|
|
(defined $password ? ('--password', $password) : ()),
|
|
($svn_non_interactive ? '--non-interactive' : ()),
|
|
|
|
$self->url,
|
|
);
|
|
&run_command (\@command);
|
|
|
|
return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $cm_branch->display_info (
|
|
# [SHOW_CHILDREN => 1],
|
|
# [SHOW_OTHER => 1]
|
|
# [SHOW_SIBLINGS => 1]
|
|
# );
|
|
#
|
|
# DESCRIPTION
|
|
# This method displays information of the current branch. If SHOW_CHILDREN is
|
|
# set, it shows information of all current children branches of the current
|
|
# branch. If SHOW_SIBLINGS is set, it shows information of siblings that have
|
|
# been merged recently with the current branch. If SHOW_OTHER is set, it shows
|
|
# information of custom/reverse merges.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub display_info {
|
|
my $self = shift;
|
|
my %args = @_;
|
|
|
|
# Arguments
|
|
# ----------------------------------------------------------------------------
|
|
my $show_children = exists $args{SHOW_CHILDREN} ? $args{SHOW_CHILDREN} : 0;
|
|
my $show_other = exists $args{SHOW_OTHER } ? $args{SHOW_OTHER} : 0;
|
|
my $show_siblings = exists $args{SHOW_SIBLINGS} ? $args{SHOW_SIBLINGS} : 0;
|
|
|
|
# Useful variables
|
|
# ----------------------------------------------------------------------------
|
|
my $separator = '-' x 80 . "\n";
|
|
my $separator2 = ' ' . '-' x 78 . "\n";
|
|
|
|
# Print "info" as returned by "svn info"
|
|
# ----------------------------------------------------------------------------
|
|
for my $key ('URL', 'Repository Root', 'Revision', 'Last Changed Author',
|
|
'Last Changed Rev', 'Last Changed Date') {
|
|
print $key, ': ', $self->svninfo (FLAG => $key), "\n"
|
|
if $self->svninfo (FLAG => $key);
|
|
}
|
|
|
|
if ($self->config->verbose) {
|
|
# Verbose mode, print log message at last changed revision
|
|
my %log = $self->svnlog (REV => $self->svninfo (FLAG => 'Last Changed Rev'));
|
|
my @log = split /\n/, $log{msg};
|
|
print 'Last Changed Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n";
|
|
}
|
|
|
|
if ($self->is_branch) {
|
|
# Print create information
|
|
# --------------------------------------------------------------------------
|
|
my %log = $self->svnlog (REV => $self->create_rev);
|
|
|
|
print $separator;
|
|
print 'Branch Create Author: ', $log{author}, "\n" if $log{author};
|
|
print 'Branch Create Rev: ', $self->create_rev, "\n";
|
|
print 'Branch Create Date: ', &svn_date ($log{date}), "\n";
|
|
|
|
if ($self->config->verbose) {
|
|
# Verbose mode, print log message at last create revision
|
|
my @log = split /\n/, $log{msg};
|
|
print 'Branch Create Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n";
|
|
}
|
|
|
|
# Print delete information if branch no longer exists
|
|
# --------------------------------------------------------------------------
|
|
print 'Branch Delete Rev: ', $self->delete_rev, "\n" if $self->delete_rev;
|
|
|
|
# Report merges into/from the parent
|
|
# --------------------------------------------------------------------------
|
|
# Print the URL@REV of the parent branch
|
|
print $separator, 'Branch Parent: ', $self->parent->url_peg, "\n";
|
|
|
|
# Set up a new object for the parent at the current revision
|
|
# --------------------------------------------------------------------------
|
|
my $p_url = $self->parent->url;
|
|
$p_url .= '@' . $self->pegrev if $self->pegrev;
|
|
my $parent = Fcm::CmBranch->new (URL => $p_url);
|
|
|
|
if (not $parent->url_exists) {
|
|
print 'Branch parent deleted.', "\n";
|
|
return;
|
|
}
|
|
|
|
# Report merges into/from the parent
|
|
# --------------------------------------------------------------------------
|
|
print $self->_report_merges ($parent, 'Parent');
|
|
}
|
|
|
|
# Report merges with siblings
|
|
# ----------------------------------------------------------------------------
|
|
if ($show_siblings) {
|
|
# Report number of sibling branches found
|
|
print $separator, 'Searching for siblings ... ';
|
|
my @siblings = $self->siblings;
|
|
print scalar (@siblings), ' ', (@siblings> 1 ? 'siblings' : 'sibling'),
|
|
' found.', "\n";
|
|
|
|
# Report branch name and merge information only if there are recent merges
|
|
my $out = '';
|
|
for my $sibling (@siblings) {
|
|
my $string = $self->_report_merges ($sibling, 'Sibling');
|
|
|
|
$out .= $separator2 . ' ' . $sibling->url . "\n" . $string if $string;
|
|
}
|
|
|
|
if (@siblings) {
|
|
if ($out) {
|
|
print 'Merges with existing siblings:', "\n", $out;
|
|
|
|
} else {
|
|
print 'No merges with existing siblings.', "\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
# Report children
|
|
# ----------------------------------------------------------------------------
|
|
if ($show_children) {
|
|
# Report number of child branches found
|
|
print $separator, 'Searching for children ... ';
|
|
my @children = $self->children;
|
|
print scalar (@children), ' ', (@children > 1 ? 'children' : 'child'),
|
|
' found.', "\n";
|
|
|
|
# Report children if they exist
|
|
print 'Current children:', "\n" if @children;
|
|
|
|
for my $child (@children) {
|
|
print $separator2, ' ', $child->url, "\n";
|
|
print ' Child Create Rev: ', $child->create_rev, "\n";
|
|
print $self->_report_merges ($child, 'Child');
|
|
}
|
|
}
|
|
|
|
# Report custom/reverse merges into the branch
|
|
# ----------------------------------------------------------------------------
|
|
if ($show_other) {
|
|
my %log = $self->svnlog (STOP_ON_COPY => 1);
|
|
my @out;
|
|
|
|
# Go down the revision log, checking for merge template messages
|
|
REV: for my $rev (sort {$b <=> $a} keys %log) {
|
|
# Loop each line of the log message at each revision
|
|
my @msg = split /\n/, $log{$rev}{msg};
|
|
|
|
for (@msg) {
|
|
# Ignore unless log message matches a merge template
|
|
if (/^Reversed r\d+(:\d+)? of \S+$/ or
|
|
s/^(Custom merge) into \S+(:.+)$/$1$2/) {
|
|
push @out, ('r' . $rev . ': ' . $_) . "\n";
|
|
}
|
|
}
|
|
}
|
|
|
|
print $separator, 'Other merges:', "\n", @out if @out;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
# SYNOPSIS
|
|
# $string = $self->_report_merges ($branch, $relation);
|
|
#
|
|
# DESCRIPTION
|
|
# This method returns a string for displaying merge information with a
|
|
# branch, the $relation of which can be a Parent, a Sibling or a Child.
|
|
# ------------------------------------------------------------------------------
|
|
|
|
sub _report_merges {
|
|
my ($self, $branch, $relation) = @_;
|
|
|
|
my $indent = ($relation eq 'Parent') ? '' : ' ';
|
|
my $separator = ($relation eq 'Parent') ? ('-' x 80) : (' ' . '-' x 78);
|
|
$separator .= "\n";
|
|
|
|
my $return = '';
|
|
|
|
# Report last merges into/from the $branch
|
|
# ----------------------------------------------------------------------------
|
|
my %merge = (
|
|
'Last Merge From ' . $relation . ':'
|
|
=> [$self->last_merge_from ($branch, 1)],
|
|
'Last Merge Into ' . $relation . ':'
|
|
=> [$branch->last_merge_from ($self, 1)],
|
|
);
|
|
|
|
if ($self->config->verbose) {
|
|
# Verbose mode, print the log of the merge
|
|
for my $key (keys %merge) {
|
|
next if not @{ $merge{$key} };
|
|
|
|
# From: target (0) is self, upper delta (1) is $branch
|
|
# Into: target (0) is $branch, upper delta (1) is self
|
|
my $t = ($key =~ /From/) ? $self : $branch;
|
|
|
|
$return .= $indent . $key . "\n";
|
|
$return .= $separator . $t->display_svnlog ($merge{$key}[0]->pegrev);
|
|
}
|
|
|
|
} else {
|
|
# Normal mode, print in simplified form (rREV Parent@REV)
|
|
for my $key (keys %merge) {
|
|
next if not @{ $merge{$key} };
|
|
|
|
# From: target (0) is self, upper delta (1) is $branch
|
|
# Into: target (0) is $branch, upper delta (1) is self
|
|
$return .= $indent . $key . ' r' . $merge{$key}[0]->pegrev . ' ' .
|
|
$merge{$key}[1]->path_peg . ' cf. ' .
|
|
$merge{$key}[2]->path_peg . "\n";
|
|
}
|
|
}
|
|
|
|
if ($relation eq 'Sibling') {
|
|
# For sibling, do not report further if there is no recent merge
|
|
my @values = values %merge;
|
|
|
|
return $return unless (@{ $values[0] } or @{ $values[1] });
|
|
}
|
|
|
|
# Report available merges into/from the $branch
|
|
# ----------------------------------------------------------------------------
|
|
my %avail = (
|
|
'Merges Avail From ' . $relation . ':'
|
|
=> ($self->delete_rev ? [] : [$self->avail_merge_from ($branch, 1)]),
|
|
'Merges Avail Into ' . $relation . ':'
|
|
=> [$branch->avail_merge_from ($self, 1)],
|
|
);
|
|
|
|
if ($self->config->verbose) {
|
|
# Verbose mode, print the log of each revision
|
|
for my $key (keys %avail) {
|
|
next unless @{ $avail{$key} };
|
|
|
|
$return .= $indent . $key . "\n";
|
|
|
|
my $s = ($key =~ /From/) ? $branch: $self;
|
|
|
|
for my $rev (@{ $avail{$key} }) {
|
|
$return .= $separator . $s->display_svnlog ($rev);
|
|
}
|
|
}
|
|
|
|
} else {
|
|
# Normal mode, print only the revisions
|
|
for my $key (keys %avail) {
|
|
next unless @{ $avail{$key} };
|
|
|
|
$return .= $indent . $key . ' ' . join (' ', @{ $avail{$key} }) . "\n";
|
|
}
|
|
}
|
|
|
|
return $return;
|
|
}
|
|
|
|
# ------------------------------------------------------------------------------
|
|
|
|
1;
|
|
|
|
__END__
|