[1980] | 1 | # ------------------------------------------------------------------------------ |
---|
| 2 | # NAME |
---|
| 3 | # Fcm::CmBranch |
---|
| 4 | # |
---|
| 5 | # DESCRIPTION |
---|
| 6 | # This class contains methods for manipulating a branch. It is a sub-class of |
---|
| 7 | # Fcm::CmUrl, and inherits all methods from that class. |
---|
| 8 | # |
---|
| 9 | # COPYRIGHT |
---|
| 10 | # (C) Crown copyright Met Office. All rights reserved. |
---|
| 11 | # For further details please refer to the file COPYRIGHT.txt |
---|
| 12 | # which you should have received as part of this distribution. |
---|
| 13 | # ------------------------------------------------------------------------------ |
---|
| 14 | |
---|
| 15 | package Fcm::CmBranch; |
---|
| 16 | @ISA = qw(Fcm::CmUrl); |
---|
| 17 | |
---|
| 18 | # Standard pragma |
---|
| 19 | use warnings; |
---|
| 20 | use strict; |
---|
| 21 | |
---|
| 22 | # Standard modules |
---|
| 23 | use Carp; |
---|
| 24 | use File::Spec; |
---|
| 25 | |
---|
| 26 | # FCM component modules |
---|
| 27 | use Fcm::CmCommitMessage; |
---|
| 28 | use Fcm::CmUrl; |
---|
| 29 | use Fcm::Config; |
---|
| 30 | use Fcm::Interactive; |
---|
| 31 | use Fcm::Keyword; |
---|
| 32 | use Fcm::Util qw/run_command e_report w_report svn_date/; |
---|
| 33 | |
---|
| 34 | my @properties = ( |
---|
| 35 | 'CREATE_REV', # revision at which the branch is created |
---|
| 36 | 'DELETE_REV', # revision at which the branch is deleted |
---|
| 37 | 'PARENT', # reference to parent branch Fcm::CmBranch |
---|
| 38 | 'ANCESTOR', # list of common ancestors with other branches |
---|
| 39 | # key = URL, value = ancestor Fcm::CmBranch |
---|
| 40 | 'LAST_MERGE', # list of last merges from branches |
---|
| 41 | # key = URL@REV, value = [TARGET, UPPER, LOWER] |
---|
| 42 | 'AVAIL_MERGE', # list of available revisions for merging |
---|
| 43 | # key = URL@REV, value = [REV ...] |
---|
| 44 | 'CHILDREN', # list of children of this branch |
---|
| 45 | 'SIBLINGS', # list of siblings of this branch |
---|
| 46 | ); |
---|
| 47 | |
---|
| 48 | # ------------------------------------------------------------------------------ |
---|
| 49 | # SYNOPSIS |
---|
| 50 | # $cm_branch = Fcm::CmBranch->new (URL => $url,); |
---|
| 51 | # |
---|
| 52 | # DESCRIPTION |
---|
| 53 | # This method constructs a new instance of the Fcm::CmBranch class. |
---|
| 54 | # |
---|
| 55 | # ARGUMENTS |
---|
| 56 | # URL - URL of a branch |
---|
| 57 | # ------------------------------------------------------------------------------ |
---|
| 58 | |
---|
| 59 | sub new { |
---|
| 60 | my $this = shift; |
---|
| 61 | my %args = @_; |
---|
| 62 | my $class = ref $this || $this; |
---|
| 63 | |
---|
| 64 | my $self = Fcm::CmUrl->new (%args); |
---|
| 65 | |
---|
| 66 | $self->{$_} = undef for (@properties); |
---|
| 67 | |
---|
| 68 | bless $self, $class; |
---|
| 69 | return $self; |
---|
| 70 | } |
---|
| 71 | |
---|
| 72 | # ------------------------------------------------------------------------------ |
---|
| 73 | # SYNOPSIS |
---|
| 74 | # $url = $cm_branch->url_peg; |
---|
| 75 | # $cm_branch->url_peg ($url); |
---|
| 76 | # |
---|
| 77 | # DESCRIPTION |
---|
| 78 | # This method returns/sets the current URL. |
---|
| 79 | # ------------------------------------------------------------------------------ |
---|
| 80 | |
---|
| 81 | sub url_peg { |
---|
| 82 | my $self = shift; |
---|
| 83 | |
---|
| 84 | if (@_) { |
---|
| 85 | if (! $self->{URL} or $_[0] ne $self->{URL}) { |
---|
| 86 | # Re-set URL and other essential variables in the SUPER-class |
---|
| 87 | $self->SUPER::url_peg (@_); |
---|
| 88 | |
---|
| 89 | # Re-set essential variables |
---|
| 90 | $self->{$_} = undef for (@properties); |
---|
| 91 | } |
---|
| 92 | } |
---|
| 93 | |
---|
| 94 | return $self->{URL}; |
---|
| 95 | } |
---|
| 96 | |
---|
| 97 | # ------------------------------------------------------------------------------ |
---|
| 98 | # SYNOPSIS |
---|
| 99 | # $rev = $cm_branch->create_rev; |
---|
| 100 | # |
---|
| 101 | # DESCRIPTION |
---|
| 102 | # This method returns the revision at which the branch was created. |
---|
| 103 | # ------------------------------------------------------------------------------ |
---|
| 104 | |
---|
| 105 | sub create_rev { |
---|
| 106 | my $self = shift; |
---|
| 107 | |
---|
| 108 | if (not $self->{CREATE_REV}) { |
---|
| 109 | return unless $self->url_exists ($self->pegrev); |
---|
| 110 | |
---|
| 111 | # Use "svn log" to find out the first revision of the branch |
---|
| 112 | my %log = $self->svnlog (STOP_ON_COPY => 1); |
---|
| 113 | |
---|
| 114 | # Look at log in ascending order |
---|
| 115 | my $rev = (sort {$a <=> $b} keys %log) [0]; |
---|
| 116 | my $paths = $log{$rev}{paths}; |
---|
| 117 | |
---|
| 118 | # Get revision when URL is first added to the repository |
---|
| 119 | if (exists $paths->{$self->branch_path}) { |
---|
| 120 | $self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A'; |
---|
| 121 | } |
---|
| 122 | } |
---|
| 123 | |
---|
| 124 | return $self->{CREATE_REV}; |
---|
| 125 | } |
---|
| 126 | |
---|
| 127 | # ------------------------------------------------------------------------------ |
---|
| 128 | # SYNOPSIS |
---|
| 129 | # $parent = $cm_branch->parent; |
---|
| 130 | # |
---|
| 131 | # DESCRIPTION |
---|
| 132 | # This method returns the parent (a Fcm::CmBranch object) of the current |
---|
| 133 | # branch. |
---|
| 134 | # ------------------------------------------------------------------------------ |
---|
| 135 | |
---|
| 136 | sub parent { |
---|
| 137 | my $self = shift; |
---|
| 138 | |
---|
| 139 | if (not $self->{PARENT}) { |
---|
| 140 | # Use the log to find out the parent revision |
---|
| 141 | my %log = $self->svnlog (REV => $self->create_rev); |
---|
| 142 | |
---|
| 143 | if (exists $log{paths}{$self->branch_path}) { |
---|
| 144 | my $path = $log{paths}{$self->branch_path}; |
---|
| 145 | |
---|
| 146 | if ($path->{action} eq 'A') { |
---|
| 147 | if (exists $path->{'copyfrom-path'}) { |
---|
| 148 | # Current branch is copied from somewhere, set the source as the parent |
---|
| 149 | my $url = $self->root . $path->{'copyfrom-path'}; |
---|
| 150 | my $rev = $path->{'copyfrom-rev'}; |
---|
| 151 | $self->{PARENT} = Fcm::CmBranch->new (URL => $url . '@' . $rev); |
---|
| 152 | |
---|
| 153 | } else { |
---|
| 154 | # Current branch is not copied from somewhere |
---|
| 155 | $self->{PARENT} = $self; |
---|
| 156 | } |
---|
| 157 | } |
---|
| 158 | } |
---|
| 159 | } |
---|
| 160 | |
---|
| 161 | return $self->{PARENT}; |
---|
| 162 | } |
---|
| 163 | |
---|
| 164 | # ------------------------------------------------------------------------------ |
---|
| 165 | # SYNOPSIS |
---|
| 166 | # $rev = $cm_branch->delete_rev; |
---|
| 167 | # |
---|
| 168 | # DESCRIPTION |
---|
| 169 | # This method returns the revision at which the branch was deleted. |
---|
| 170 | # ------------------------------------------------------------------------------ |
---|
| 171 | |
---|
| 172 | sub delete_rev { |
---|
| 173 | my $self = shift; |
---|
| 174 | |
---|
| 175 | if (not $self->{DELETE_REV}) { |
---|
| 176 | return if $self->url_exists ('HEAD'); |
---|
| 177 | |
---|
| 178 | # Container of the current URL |
---|
| 179 | (my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##; |
---|
| 180 | |
---|
| 181 | # Use "svn log" on the container between a revision where the branch exists |
---|
| 182 | # and the HEAD |
---|
| 183 | my $dir = Fcm::CmUrl->new (URL => $dir_url); |
---|
| 184 | my %log = $dir->svnlog ( |
---|
| 185 | REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)], |
---|
| 186 | ); |
---|
| 187 | |
---|
| 188 | # Go through the log to see when branch no longer exists |
---|
| 189 | for my $rev (sort {$a <=> $b} keys %log) { |
---|
| 190 | next unless exists $log{$rev}{paths}{$self->branch_path} and |
---|
| 191 | $log{$rev}{paths}{$self->branch_path}{action} eq 'D'; |
---|
| 192 | |
---|
| 193 | $self->{DELETE_REV} = $rev; |
---|
| 194 | last; |
---|
| 195 | } |
---|
| 196 | } |
---|
| 197 | |
---|
| 198 | return $self->{DELETE_REV}; |
---|
| 199 | } |
---|
| 200 | |
---|
| 201 | # ------------------------------------------------------------------------------ |
---|
| 202 | # SYNOPSIS |
---|
| 203 | # $flag = $cm_branch->is_child_of ($branch); |
---|
| 204 | # |
---|
| 205 | # DESCRIPTION |
---|
| 206 | # This method returns true if the current branch is a child of $branch. |
---|
| 207 | # ------------------------------------------------------------------------------ |
---|
| 208 | |
---|
| 209 | sub is_child_of { |
---|
| 210 | my ($self, $branch) = @_; |
---|
| 211 | |
---|
| 212 | # The trunk cannot be a child branch |
---|
| 213 | return if $self->is_trunk; |
---|
| 214 | |
---|
| 215 | # If $branch is a branch, use name of $self to see when it is created |
---|
| 216 | if ($branch->is_branch and $self->url =~ m#/r(\d+)_[^/]+/*$#) { |
---|
| 217 | my $rev = $1; |
---|
| 218 | |
---|
| 219 | # $self can only be a child if it is copied from a revision > the create |
---|
| 220 | # revision of $branch |
---|
| 221 | return if $rev < $branch->create_rev; |
---|
| 222 | } |
---|
| 223 | |
---|
| 224 | return if $self->parent->url ne $branch->url; |
---|
| 225 | |
---|
| 226 | # If $branch is a branch, ensure that it is created before $self |
---|
| 227 | return if $branch->is_branch and $self->create_rev <= $branch->create_rev; |
---|
| 228 | |
---|
| 229 | return 1; |
---|
| 230 | } |
---|
| 231 | |
---|
| 232 | # ------------------------------------------------------------------------------ |
---|
| 233 | # SYNOPSIS |
---|
| 234 | # $flag = $cm_branch->is_sibling_of ($branch); |
---|
| 235 | # |
---|
| 236 | # DESCRIPTION |
---|
| 237 | # This method returns true if the current branch is a sibling of $branch. |
---|
| 238 | # ------------------------------------------------------------------------------ |
---|
| 239 | |
---|
| 240 | sub is_sibling_of { |
---|
| 241 | my ($self, $branch) = @_; |
---|
| 242 | |
---|
| 243 | # The trunk cannot be a sibling branch |
---|
| 244 | return if $branch->is_trunk; |
---|
| 245 | |
---|
| 246 | return if $self->parent->url ne $branch->parent->url; |
---|
| 247 | |
---|
| 248 | # If the parent is a branch, ensure they are actually the same branch |
---|
| 249 | return if $branch->parent->is_branch and |
---|
| 250 | $self->parent->create_rev != $branch->parent->create_rev; |
---|
| 251 | |
---|
| 252 | return 1; |
---|
| 253 | } |
---|
| 254 | |
---|
| 255 | # ------------------------------------------------------------------------------ |
---|
| 256 | # SYNOPSIS |
---|
| 257 | # $self->_get_relatives ($relation); |
---|
| 258 | # |
---|
| 259 | # DESCRIPTION |
---|
| 260 | # This method sets the $self->{$relation} variable by inspecting the list of |
---|
| 261 | # branches at the current revision of the current branch. $relation can be |
---|
| 262 | # either "CHILDREN" or "SIBLINGS". |
---|
| 263 | # ------------------------------------------------------------------------------ |
---|
| 264 | |
---|
| 265 | sub _get_relatives { |
---|
| 266 | my ($self, $relation) = @_; |
---|
| 267 | |
---|
| 268 | my @branch_list = $self->branch_list; |
---|
| 269 | |
---|
| 270 | $self->{$relation} = []; |
---|
| 271 | |
---|
| 272 | # If we are searching for CHILDREN, get list of SIBLINGS, and vice versa |
---|
| 273 | my $other = ($relation eq 'CHILDREN' ? 'SIBLINGS' : 'CHILDREN'); |
---|
| 274 | my %other_list; |
---|
| 275 | if ($self->{$other}) { |
---|
| 276 | %other_list = map {$_->url, 1} @{ $self->{$other} }; |
---|
| 277 | } |
---|
| 278 | |
---|
| 279 | for my $u (@branch_list) { |
---|
| 280 | # Ignore URL of current branch and its parent |
---|
| 281 | next if $u eq $self->url; |
---|
| 282 | next if $self->is_branch and $u eq $self->parent->url; |
---|
| 283 | |
---|
| 284 | # Ignore if URL is a branch detected to be another type of relative |
---|
| 285 | next if exists $other_list{$u}; |
---|
| 286 | |
---|
| 287 | # Construct new Fcm::CmBranch object from branch URL |
---|
| 288 | my $url = $u . ($self->pegrev ? '@' . $self->pegrev : ''); |
---|
| 289 | my $branch = Fcm::CmBranch->new (URL => $url); |
---|
| 290 | |
---|
| 291 | # Test whether $branch is a relative we are looking for |
---|
| 292 | if ($relation eq 'CHILDREN') { |
---|
| 293 | push @{ $self->{$relation} }, $branch if $branch->is_child_of ($self); |
---|
| 294 | |
---|
| 295 | } else { |
---|
| 296 | push @{ $self->{$relation} }, $branch if $branch->is_sibling_of ($self); |
---|
| 297 | } |
---|
| 298 | } |
---|
| 299 | |
---|
| 300 | return; |
---|
| 301 | } |
---|
| 302 | |
---|
| 303 | # ------------------------------------------------------------------------------ |
---|
| 304 | # SYNOPSIS |
---|
| 305 | # @children = $cm_branch->children; |
---|
| 306 | # |
---|
| 307 | # DESCRIPTION |
---|
| 308 | # This method returns a list of children (Fcm::CmBranch objects) of the |
---|
| 309 | # current branch that exists in the current revision. |
---|
| 310 | # ------------------------------------------------------------------------------ |
---|
| 311 | |
---|
| 312 | sub children { |
---|
| 313 | my $self = shift; |
---|
| 314 | |
---|
| 315 | $self->_get_relatives ('CHILDREN') if not $self->{CHILDREN}; |
---|
| 316 | |
---|
| 317 | return @{ $self->{CHILDREN} }; |
---|
| 318 | } |
---|
| 319 | |
---|
| 320 | # ------------------------------------------------------------------------------ |
---|
| 321 | # SYNOPSIS |
---|
| 322 | # @siblings = $cm_branch->siblings; |
---|
| 323 | # |
---|
| 324 | # DESCRIPTION |
---|
| 325 | # This method returns a list of siblings (Fcm::CmBranch objects) of the |
---|
| 326 | # current branch that exists in the current revision. |
---|
| 327 | # ------------------------------------------------------------------------------ |
---|
| 328 | |
---|
| 329 | sub siblings { |
---|
| 330 | my $self = shift; |
---|
| 331 | |
---|
| 332 | $self->_get_relatives ('SIBLINGS') if not $self->{SIBLINGS}; |
---|
| 333 | |
---|
| 334 | return @{ $self->{SIBLINGS} }; |
---|
| 335 | } |
---|
| 336 | |
---|
| 337 | # ------------------------------------------------------------------------------ |
---|
| 338 | # SYNOPSIS |
---|
| 339 | # $ancestor = $cm_branch->ancestor ($branch); |
---|
| 340 | # |
---|
| 341 | # DESCRIPTION |
---|
| 342 | # This method returns the common ancestor (a Fcm::CmBranch object) of a |
---|
| 343 | # specified $branch and the current branch. The argument $branch must be a |
---|
| 344 | # Fcm::CmBranch object. Both the current branch and $branch are assumed to be |
---|
| 345 | # in the same project. |
---|
| 346 | # ------------------------------------------------------------------------------ |
---|
| 347 | |
---|
| 348 | sub ancestor { |
---|
| 349 | my ($self, $branch) = @_; |
---|
| 350 | |
---|
| 351 | if (not exists $self->{ANCESTOR}{$branch->url_peg}) { |
---|
| 352 | if ($self->url_peg eq $branch->url_peg) { |
---|
| 353 | $self->{ANCESTOR}{$branch->url_peg} = $self; |
---|
| 354 | |
---|
| 355 | } else { |
---|
| 356 | # Get family tree of current branch, from trunk to current branch |
---|
| 357 | my @this_family = ($self); |
---|
| 358 | while (not $this_family [0]->is_trunk) { |
---|
| 359 | unshift @this_family, $this_family [0]->parent; |
---|
| 360 | } |
---|
| 361 | |
---|
| 362 | # Get family tree of $branch, from trunk to $branch |
---|
| 363 | my @that_family = ($branch); |
---|
| 364 | while (not $that_family [0]->is_trunk) { |
---|
| 365 | unshift @that_family, $that_family [0]->parent; |
---|
| 366 | } |
---|
| 367 | |
---|
| 368 | # Find common ancestor from list of parents |
---|
| 369 | my $ancestor = undef; |
---|
| 370 | |
---|
| 371 | while (not $ancestor) { |
---|
| 372 | # $this and $that should both start as some revisions on the trunk. |
---|
| 373 | # Walk down a generation each time it loops around. |
---|
| 374 | my $this = shift @this_family; |
---|
| 375 | my $that = shift @that_family; |
---|
| 376 | |
---|
| 377 | if ($this->url eq $that->url) { |
---|
| 378 | if ($this->is_trunk or $this->create_rev eq $that->create_rev) { |
---|
| 379 | # $this and $that are the same branch |
---|
| 380 | if (@this_family and @that_family) { |
---|
| 381 | # More generations in both branches, try comparing the next |
---|
| 382 | # generations. |
---|
| 383 | next; |
---|
| 384 | |
---|
| 385 | } else { |
---|
| 386 | # End of lineage in one of the branches, ancestor is at the lower |
---|
| 387 | # revision of the current URL. |
---|
| 388 | if ($this->pegrev and $that->pegrev) { |
---|
| 389 | $ancestor = $this->pegrev < $that->pegrev ? $this : $that; |
---|
| 390 | |
---|
| 391 | } else { |
---|
| 392 | $ancestor = $this->pegrev ? $this : $that; |
---|
| 393 | } |
---|
| 394 | } |
---|
| 395 | |
---|
| 396 | } else { |
---|
| 397 | # Despite the same URL, $this and $that are different branches as |
---|
| 398 | # they are created at different revisions. The ancestor must be the |
---|
| 399 | # parent with the lower revision. (This should not occur at the |
---|
| 400 | # start.) |
---|
| 401 | $ancestor = $this->parent->pegrev < $that->parent->pegrev |
---|
| 402 | ? $this->parent : $that->parent; |
---|
| 403 | } |
---|
| 404 | |
---|
| 405 | } else { |
---|
| 406 | # Different URLs, ancestor must be the parent with the lower revision. |
---|
| 407 | # (This should not occur at the start.) |
---|
| 408 | $ancestor = $this->parent->pegrev < $that->parent->pegrev |
---|
| 409 | ? $this->parent : $that->parent; |
---|
| 410 | } |
---|
| 411 | } |
---|
| 412 | |
---|
| 413 | $self->{ANCESTOR}{$branch->url_peg} = $ancestor; |
---|
| 414 | } |
---|
| 415 | } |
---|
| 416 | |
---|
| 417 | return $self->{ANCESTOR}{$branch->url_peg}; |
---|
| 418 | } |
---|
| 419 | |
---|
| 420 | # ------------------------------------------------------------------------------ |
---|
| 421 | # SYNOPSIS |
---|
| 422 | # ($target, $upper, $lower) = $cm_branch->last_merge_from ( |
---|
| 423 | # $branch, $stop_on_copy, |
---|
| 424 | # ); |
---|
| 425 | # |
---|
| 426 | # DESCRIPTION |
---|
| 427 | # This method returns a 3-element list with information of the last merge |
---|
| 428 | # into the current branch from a specified $branch. The first element in the |
---|
| 429 | # list $target (a Fcm::CmBranch object) is the target at which the merge was |
---|
| 430 | # performed. (This can be the current branch or a parent branch up to the |
---|
| 431 | # common ancestor with the specified $branch.) The second and third elements, |
---|
| 432 | # $upper and $lower, (both Fcm::CmBranch objects), are the upper and lower |
---|
| 433 | # ends of the source delta. If there is no merge from $branch into the |
---|
| 434 | # current branch from their common ancestor to the current revision, this |
---|
| 435 | # method will return an empty list. If $stop_on_copy is specified, it ignores |
---|
| 436 | # merges from parents of $branch, and merges into parents of the current |
---|
| 437 | # branch. |
---|
| 438 | # ------------------------------------------------------------------------------ |
---|
| 439 | |
---|
| 440 | sub last_merge_from { |
---|
| 441 | my ($self, $branch, $stop_on_copy) = @_; |
---|
| 442 | |
---|
| 443 | if (not exists $self->{LAST_MERGE}{$branch->url_peg}) { |
---|
| 444 | # Get "log" of current branch down to the common ancestor |
---|
| 445 | my %log = $self->svnlog ( |
---|
| 446 | REV => [ |
---|
| 447 | ($self->pegrev ? $self->pegrev : 'HEAD'), |
---|
| 448 | $self->ancestor ($branch)->pegrev, |
---|
| 449 | ], |
---|
| 450 | |
---|
| 451 | STOP_ON_COPY => $stop_on_copy, |
---|
| 452 | ); |
---|
| 453 | |
---|
| 454 | my $cr = $self; |
---|
| 455 | |
---|
| 456 | # Go down the revision log, checking for merge template messages |
---|
| 457 | REV: for my $rev (sort {$b <=> $a} keys %log) { |
---|
| 458 | # Loop each line of the log message at each revision |
---|
| 459 | my @msg = split /\n/, $log{$rev}{msg}; |
---|
| 460 | |
---|
| 461 | # Also consider merges into parents of current branch |
---|
| 462 | $cr = $cr->parent if ($cr->is_branch and $rev < $cr->create_rev); |
---|
| 463 | |
---|
| 464 | for (@msg) { |
---|
| 465 | # Ignore unless log message matches a merge template |
---|
| 466 | next unless /Merged into \S+: (\S+) cf\. (\S+)/; |
---|
| 467 | |
---|
| 468 | # Upper $1 and lower $2 ends of the source delta |
---|
| 469 | my $u_path = $1; |
---|
| 470 | my $l_path = $2; |
---|
| 471 | |
---|
| 472 | # Add the root directory to the paths if necessary |
---|
| 473 | $u_path = '/' . $u_path if substr ($u_path, 0, 1) ne '/'; |
---|
| 474 | $l_path = '/' . $l_path if substr ($l_path, 0, 1) ne '/'; |
---|
| 475 | |
---|
| 476 | # Only consider merges with specified branch (and its parent) |
---|
| 477 | (my $path = $u_path) =~ s/@(\d+)$//; |
---|
| 478 | my $u_rev = $1; |
---|
| 479 | |
---|
| 480 | my $br = $branch; |
---|
| 481 | $br = $br->parent while ( |
---|
| 482 | $br->is_branch and $u_rev < $br->create_rev and not $stop_on_copy |
---|
| 483 | ); |
---|
| 484 | |
---|
| 485 | next unless $br->branch_path eq $path; |
---|
| 486 | |
---|
| 487 | # If $br is a parent of branch, ignore those merges with the parent |
---|
| 488 | # above the branch point of the current branch |
---|
| 489 | next if $br->pegrev and $br->pegrev < $u_rev; |
---|
| 490 | |
---|
| 491 | # Set the return values |
---|
| 492 | $self->{LAST_MERGE}{$branch->url_peg} = [ |
---|
| 493 | Fcm::CmBranch->new (URL => $cr->url . '@' . $rev), # target |
---|
| 494 | Fcm::CmBranch->new (URL => $self->root . $u_path), # delta upper |
---|
| 495 | Fcm::CmBranch->new (URL => $self->root . $l_path), # delta lower |
---|
| 496 | ]; |
---|
| 497 | |
---|
| 498 | last REV; |
---|
| 499 | } |
---|
| 500 | } |
---|
| 501 | } |
---|
| 502 | |
---|
| 503 | return (exists $self->{LAST_MERGE}{$branch->url_peg} |
---|
| 504 | ? @{ $self->{LAST_MERGE}{$branch->url_peg} } : ()); |
---|
| 505 | } |
---|
| 506 | |
---|
| 507 | # ------------------------------------------------------------------------------ |
---|
| 508 | # SYNOPSIS |
---|
| 509 | # @revs = $cm_branch->avail_merge_from ($branch[, $stop_on_copy]); |
---|
| 510 | # |
---|
| 511 | # DESCRIPTION |
---|
| 512 | # This method returns a list of revisions of a specified $branch, which are |
---|
| 513 | # available for merging into the current branch. If $stop_on_copy is |
---|
| 514 | # specified, it will not list available merges from the parents of $branch. |
---|
| 515 | # ------------------------------------------------------------------------------ |
---|
| 516 | |
---|
| 517 | sub avail_merge_from { |
---|
| 518 | my ($self, $branch, $stop_on_copy) = @_; |
---|
| 519 | |
---|
| 520 | if (not exists $self->{AVAIL_MERGE}{$branch->url_peg}) { |
---|
| 521 | # Find out the revision of the upper delta at the last merge from $branch |
---|
| 522 | # If no merge is found, use revision of common ancestor with $branch |
---|
| 523 | my @last_merge = $self->last_merge_from ($branch); |
---|
| 524 | my $rev = $self->ancestor ($branch)->pegrev; |
---|
| 525 | $rev = $last_merge [1]->pegrev |
---|
| 526 | if @last_merge and $last_merge [1]->pegrev > $rev; |
---|
| 527 | |
---|
| 528 | # Get the "log" of the $branch down to $rev |
---|
| 529 | my %log = $branch->svnlog ( |
---|
| 530 | REV => [($branch->pegrev ? $branch->pegrev : 'HEAD'), $rev], |
---|
| 531 | STOP_ON_COPY => $stop_on_copy, |
---|
| 532 | ); |
---|
| 533 | |
---|
| 534 | # No need to include $rev itself, as it has already been merged |
---|
| 535 | delete $log{$rev}; |
---|
| 536 | |
---|
| 537 | # No need to include the branch create revision |
---|
| 538 | delete $log{$branch->create_rev} |
---|
| 539 | if $branch->is_branch and exists $log{$branch->create_rev}; |
---|
| 540 | |
---|
| 541 | if (keys %log) { |
---|
| 542 | # Check whether there is a latest merge from $self into $branch, if so, |
---|
| 543 | # all revisions of $branch below that merge should become unavailable |
---|
| 544 | my @last_merge_into = $branch->last_merge_from ($self); |
---|
| 545 | |
---|
| 546 | if (@last_merge_into) { |
---|
| 547 | for my $rev (keys %log) { |
---|
| 548 | delete $log{$rev} if $rev < $last_merge_into [0]->pegrev; |
---|
| 549 | } |
---|
| 550 | } |
---|
| 551 | } |
---|
| 552 | |
---|
| 553 | # Available merges include all revisions above the branch creation revision |
---|
| 554 | # or the revision of the last merge |
---|
| 555 | $self->{AVAIL_MERGE}{$branch->url_peg} = [sort {$b <=> $a} keys %log]; |
---|
| 556 | } |
---|
| 557 | |
---|
| 558 | return @{ $self->{AVAIL_MERGE}{$branch->url_peg} }; |
---|
| 559 | } |
---|
| 560 | |
---|
| 561 | # ------------------------------------------------------------------------------ |
---|
| 562 | # SYNOPSIS |
---|
| 563 | # $lower = $cm_branch->base_of_merge_from ($branch); |
---|
| 564 | # |
---|
| 565 | # DESCRIPTION |
---|
| 566 | # This method returns the lower delta (a Fcm::CmBranch object) for the next |
---|
| 567 | # merge from $branch. |
---|
| 568 | # ------------------------------------------------------------------------------ |
---|
| 569 | |
---|
| 570 | sub base_of_merge_from { |
---|
| 571 | my ($self, $branch) = @_; |
---|
| 572 | |
---|
| 573 | # Base is the ancestor if there is no merge between $self and $branch |
---|
| 574 | my $return = $self->ancestor ($branch); |
---|
| 575 | |
---|
| 576 | # Get configuration for the last merge from $branch to $self |
---|
| 577 | my @merge_from = $self->last_merge_from ($branch); |
---|
| 578 | |
---|
| 579 | # Use the upper delta of the last merge from $branch, as all revisions below |
---|
| 580 | # that have already been merged into the $self |
---|
| 581 | $return = $merge_from [1] |
---|
| 582 | if @merge_from and $merge_from [1]->pegrev > $return->pegrev; |
---|
| 583 | |
---|
| 584 | # Get configuration for the last merge from $self to $branch |
---|
| 585 | my @merge_into = $branch->last_merge_from ($self); |
---|
| 586 | |
---|
| 587 | # Use the upper delta of the last merge from $self, as the current revision |
---|
| 588 | # of $branch already contains changes of $self up to the peg revision of the |
---|
| 589 | # upper delta |
---|
| 590 | $return = $merge_into [1] |
---|
| 591 | if @merge_into and $merge_into [0]->pegrev > $return->pegrev; |
---|
| 592 | |
---|
| 593 | return $return; |
---|
| 594 | } |
---|
| 595 | |
---|
| 596 | # ------------------------------------------------------------------------------ |
---|
| 597 | # SYNOPSIS |
---|
| 598 | # $flag = $cm_branch->allow_subdir_merge_from ($branch, $subdir); |
---|
| 599 | # |
---|
| 600 | # DESCRIPTION |
---|
| 601 | # This method returns true if a merge from the sub-directory $subdir in |
---|
| 602 | # $branch is allowed - i.e. it does not result in losing changes made in |
---|
| 603 | # $branch outside of $subdir. |
---|
| 604 | # ------------------------------------------------------------------------------ |
---|
| 605 | |
---|
| 606 | sub allow_subdir_merge_from { |
---|
| 607 | my ($self, $branch, $subdir) = @_; |
---|
| 608 | |
---|
| 609 | # Get revision at last merge from $branch or ancestor |
---|
| 610 | my @merge_from = $self->last_merge_from ($branch); |
---|
| 611 | my $last = @merge_from ? $merge_from [1] : $self->ancestor ($branch); |
---|
| 612 | my $rev = $last->pegrev; |
---|
| 613 | |
---|
| 614 | my $return = 1; |
---|
| 615 | if ($branch->pegrev > $rev) { |
---|
| 616 | # Use "svn diff --summarize" to work out what's changed between last |
---|
| 617 | # merge/ancestor and current revision |
---|
| 618 | my $range = $branch->pegrev . ':' . $rev; |
---|
| 619 | my @out = &run_command ( |
---|
| 620 | [qw/svn diff --summarize -r/, $range, $branch->url_peg], METHOD => 'qx', |
---|
| 621 | ); |
---|
| 622 | |
---|
| 623 | # Returns false if there are changes outside of $subdir |
---|
| 624 | my $url = join ('/', $branch->url, $subdir); |
---|
| 625 | for my $line (@out) { |
---|
| 626 | chomp $line; |
---|
| 627 | $line = substr ($line, 7); # file name begins at column 7 |
---|
| 628 | if ($line !~ m#^$url(?:/|$)#) { |
---|
| 629 | $return = 0; |
---|
| 630 | last; |
---|
| 631 | } |
---|
| 632 | } |
---|
| 633 | } |
---|
| 634 | |
---|
| 635 | return $return; |
---|
| 636 | } |
---|
| 637 | |
---|
| 638 | # ------------------------------------------------------------------------------ |
---|
| 639 | # SYNOPSIS |
---|
| 640 | # $cm_branch->create ( |
---|
| 641 | # SRC => $src, |
---|
| 642 | # TYPE => $type, |
---|
| 643 | # NAME => $name, |
---|
| 644 | # [PASSWORD => $password,] |
---|
| 645 | # [REV_FLAG => $rev_flag,] |
---|
| 646 | # [TICKET => \@tickets,] |
---|
| 647 | # [REV => $rev,] |
---|
| 648 | # [NON_INTERACTIVE => 1,] |
---|
| 649 | # [SVN_NON_INTERACTIVE => 1,] |
---|
| 650 | # ); |
---|
| 651 | # |
---|
| 652 | # DESCRIPTION |
---|
| 653 | # This method creates a branch in a Subversion repository. |
---|
| 654 | # |
---|
| 655 | # OPTIONS |
---|
| 656 | # SRC - reference to a Fcm::CmUrl object. |
---|
| 657 | # TYPE - Specify the branch type. See help in "fcm branch" for |
---|
| 658 | # further information. |
---|
| 659 | # NAME - specify the name of the branch. |
---|
| 660 | # NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE |
---|
| 661 | # to true automatically. |
---|
| 662 | # PASSWORD - specify the password for commit access. |
---|
| 663 | # REV - specify the operative revision of the source. |
---|
| 664 | # REV_FLAG - A flag to specify the behaviour of the prefix to the |
---|
| 665 | # branch name. See help in "fcm branch" for further |
---|
| 666 | # information. |
---|
| 667 | # SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit, |
---|
| 668 | # etc. This option is implied by NON_INTERACTIVE. |
---|
| 669 | # TICKET - Specify one or more related tickets for the branch. |
---|
| 670 | # ------------------------------------------------------------------------------ |
---|
| 671 | |
---|
| 672 | sub create { |
---|
| 673 | my $self = shift; |
---|
| 674 | my %args = @_; |
---|
| 675 | |
---|
| 676 | # Options |
---|
| 677 | # ---------------------------------------------------------------------------- |
---|
| 678 | # Compulsory options |
---|
| 679 | my $src = $args{SRC}; |
---|
| 680 | my $type = $args{TYPE}; |
---|
| 681 | my $name = $args{NAME}; |
---|
| 682 | |
---|
| 683 | # Other options |
---|
| 684 | my $rev_flag = $args{REV_FLAG} ? $args{REV_FLAG} : 'NORMAL'; |
---|
| 685 | my @tickets = exists $args{TICKET} ? @{ $args{TICKET} } : (); |
---|
| 686 | my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef; |
---|
| 687 | my $orev = exists $args{REV} ? $args{REV} : 'HEAD'; |
---|
| 688 | |
---|
| 689 | my $non_interactive = exists $args{NON_INTERACTIVE} |
---|
| 690 | ? $args{NON_INTERACTIVE} : 0; |
---|
| 691 | my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE} |
---|
| 692 | ? $args{SVN_NON_INTERACTIVE} : 0; |
---|
| 693 | $svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive; |
---|
| 694 | |
---|
| 695 | # Analyse the source URL |
---|
| 696 | # ---------------------------------------------------------------------------- |
---|
| 697 | # Create branch from the trunk by default |
---|
| 698 | $src->branch ('trunk') if not $src->branch; |
---|
| 699 | |
---|
| 700 | # Remove "sub-directory" part from source URL |
---|
| 701 | $src->subdir ('') if $src->subdir; |
---|
| 702 | |
---|
| 703 | # Remove "peg revision" part because it does not work with "svn copy" |
---|
| 704 | $src->pegrev ('') if $src->pegrev; |
---|
| 705 | |
---|
| 706 | # Find out the URL and the last changed revision of the specified URL at the |
---|
| 707 | # specified operative revision |
---|
| 708 | my $url = $src->svninfo (FLAG => 'URL', REV => $orev); |
---|
| 709 | e_report $src->url, ': cannot determine the operative URL at revision ', |
---|
| 710 | $orev, ', abort.' if not $url; |
---|
| 711 | |
---|
| 712 | $src->url ($url) if $url ne $src->url; |
---|
| 713 | |
---|
| 714 | my $rev = $src->svninfo (FLAG => 'Last Changed Rev', REV => $orev); |
---|
| 715 | e_report $src->url, ': cannot determine the last changed rev at revision', |
---|
| 716 | $orev, ', abort.' if not $rev; |
---|
| 717 | |
---|
| 718 | # Warn user if last changed revision is not the specified revision |
---|
| 719 | w_report 'Warning: branch will be created from revision ', $rev, |
---|
| 720 | ', i.e. the last changed rev.' |
---|
| 721 | unless $orev and $orev eq $rev; |
---|
| 722 | |
---|
| 723 | # Determine the sub-directory names of the branch |
---|
| 724 | # ---------------------------------------------------------------------------- |
---|
| 725 | my @branch_dirs = ('branches'); |
---|
| 726 | |
---|
| 727 | # Split branch type flags into a hash table |
---|
| 728 | my %type_flags = (); |
---|
| 729 | $type_flags{$_} = 1 for ((split /$Fcm::Config::DELIMITER/, $type)); |
---|
| 730 | |
---|
| 731 | # Branch sub-directory 1, development, test or package |
---|
| 732 | for my $flag (qw/DEV TEST PKG/) { |
---|
| 733 | if (exists $type_flags{$flag}) { |
---|
| 734 | push @branch_dirs, lc ($flag); |
---|
| 735 | last; |
---|
| 736 | } |
---|
| 737 | } |
---|
| 738 | |
---|
| 739 | # Branch sub-directory 2, user, share, configuration or release |
---|
| 740 | if (exists $type_flags{USER}) { |
---|
| 741 | die 'Unable to determine your user ID, abort' unless $self->config->user_id; |
---|
| 742 | |
---|
| 743 | push @branch_dirs, $self->config->user_id; |
---|
| 744 | |
---|
| 745 | } else { |
---|
| 746 | for my $flag (keys %Fcm::CmUrl::owner_keywords) { |
---|
| 747 | if (exists $type_flags{uc ($flag)}) { |
---|
| 748 | push @branch_dirs, $flag; |
---|
| 749 | last; |
---|
| 750 | } |
---|
| 751 | } |
---|
| 752 | } |
---|
| 753 | |
---|
| 754 | # Branch sub-directory 3, branch name |
---|
| 755 | # Prefix branch name with revision number/keyword if necessary |
---|
| 756 | my $prefix = ''; |
---|
| 757 | if ($rev_flag ne 'NONE') { |
---|
| 758 | $prefix = $rev; |
---|
| 759 | |
---|
| 760 | # Attempt to replace revision number with a revision keyword if necessary |
---|
| 761 | if ($rev_flag eq 'NORMAL') { |
---|
| 762 | $prefix = (Fcm::Keyword::unexpand($src->url_peg(), $rev))[1]; |
---|
| 763 | } |
---|
| 764 | |
---|
| 765 | # $prefix is still a revision number, add "r" in front of it |
---|
| 766 | $prefix = 'r' . $prefix if $prefix eq $rev; |
---|
| 767 | |
---|
| 768 | # Add an underscore before the branch name |
---|
| 769 | $prefix.= '_'; |
---|
| 770 | } |
---|
| 771 | |
---|
| 772 | # Branch name |
---|
| 773 | push @branch_dirs, $prefix . $name; |
---|
| 774 | |
---|
| 775 | # Check whether the branch already exists, fail if so |
---|
| 776 | # ---------------------------------------------------------------------------- |
---|
| 777 | # Construct the URL of the branch |
---|
| 778 | $self->project_url ($src->project_url); |
---|
| 779 | $self->branch (join ('/', @branch_dirs)); |
---|
| 780 | |
---|
| 781 | # Check that branch does not already exists |
---|
| 782 | e_report $self->url, ': branch already exists, abort.' if $self->url_exists; |
---|
| 783 | |
---|
| 784 | # Message for the commit log |
---|
| 785 | # ---------------------------------------------------------------------------- |
---|
| 786 | my @message = ('Created ' . $self->branch_path . ' from ' . |
---|
| 787 | $src->branch_path . '@' . $rev . '.' . "\n"); |
---|
| 788 | |
---|
| 789 | # Add related Trac ticket links to commit log if set |
---|
| 790 | if (@tickets) { |
---|
| 791 | my $ticket_mesg = 'Relates to ticket' . (@tickets > 1 ? 's' : ''); |
---|
| 792 | |
---|
| 793 | while (my $ticket = shift @tickets) { |
---|
| 794 | $ticket_mesg .= ' #' . $ticket; |
---|
| 795 | $ticket_mesg .= (@tickets > 1 ? ',' : ' and') if @tickets >= 1; |
---|
| 796 | } |
---|
| 797 | |
---|
| 798 | push @message, $ticket_mesg . ".\n"; |
---|
| 799 | } |
---|
| 800 | |
---|
| 801 | # Create a temporary file for the commit log message |
---|
| 802 | my $ci_mesg = Fcm::CmCommitMessage->new; |
---|
| 803 | $ci_mesg->auto_mesg (\@message); |
---|
| 804 | $ci_mesg->ignore_mesg (['A' . ' ' x 4 . $self->url . "\n"]); |
---|
| 805 | my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive); |
---|
| 806 | |
---|
| 807 | # Check with the user to see if he/she wants to go ahead |
---|
| 808 | # ---------------------------------------------------------------------------- |
---|
| 809 | if (not $non_interactive) { |
---|
| 810 | my $reply = Fcm::Interactive::get_input( |
---|
| 811 | title => 'fcm branch', |
---|
| 812 | message => 'Would you like to go ahead and create this branch?', |
---|
| 813 | type => 'yn', |
---|
| 814 | default => 'n', |
---|
| 815 | ); |
---|
| 816 | |
---|
| 817 | return unless $reply eq 'y'; |
---|
| 818 | } |
---|
| 819 | |
---|
| 820 | # Ensure existence of container sub-directories of the branch |
---|
| 821 | # ---------------------------------------------------------------------------- |
---|
| 822 | for my $i (0 .. $#branch_dirs - 1) { |
---|
| 823 | my $subdir = join ('/', @branch_dirs[0 .. $i]); |
---|
| 824 | my $subdir_url = Fcm::CmUrl->new (URL => $src->project_url . '/' . $subdir); |
---|
| 825 | |
---|
| 826 | # Check whether each sub-directory of the branch already exists, |
---|
| 827 | # if sub-directory does not exist, create it |
---|
| 828 | next if $subdir_url->url_exists; |
---|
| 829 | |
---|
| 830 | print 'Creating sub-directory: ', $subdir, "\n"; |
---|
| 831 | |
---|
| 832 | my @command = ( |
---|
| 833 | qw/svn mkdir/, |
---|
| 834 | '-m', 'Created ' . $subdir . ' directory.', |
---|
| 835 | ($svn_non_interactive ? '--non-interactive' : ()), |
---|
| 836 | (defined $password ? ('--password', $password) : ()), |
---|
| 837 | |
---|
| 838 | $subdir_url->url, |
---|
| 839 | ); |
---|
| 840 | &run_command (\@command); |
---|
| 841 | } |
---|
| 842 | |
---|
| 843 | # Create the branch |
---|
| 844 | # ---------------------------------------------------------------------------- |
---|
| 845 | { |
---|
| 846 | print 'Creating branch ', $self->url, ' ...', "\n"; |
---|
| 847 | my @command = ( |
---|
| 848 | qw/svn copy/, |
---|
| 849 | '-r', $rev, |
---|
| 850 | '-F', $logfile, |
---|
| 851 | ($svn_non_interactive ? '--non-interactive' : ()), |
---|
| 852 | (defined $password ? ('--password', $password) : ()), |
---|
| 853 | |
---|
| 854 | $src->url, $self->url, |
---|
| 855 | ); |
---|
| 856 | &run_command (\@command); |
---|
| 857 | } |
---|
| 858 | |
---|
| 859 | return; |
---|
| 860 | } |
---|
| 861 | |
---|
| 862 | # ------------------------------------------------------------------------------ |
---|
| 863 | # SYNOPSIS |
---|
| 864 | # $cm_branch->delete ( |
---|
| 865 | # [NON_INTERACTIVE => 1,] |
---|
| 866 | # [PASSWORD => $password,] |
---|
| 867 | # [SVN_NON_INTERACTIVE => 1,] |
---|
| 868 | # ); |
---|
| 869 | # |
---|
| 870 | # DESCRIPTION |
---|
| 871 | # This method deletes the current branch from the Subversion repository. |
---|
| 872 | # |
---|
| 873 | # OPTIONS |
---|
| 874 | # NON_INTERACTIVE - Do no interactive prompting, set SVN_NON_INTERACTIVE |
---|
| 875 | # to true automatically. |
---|
| 876 | # PASSWORD - specify the password for commit access. |
---|
| 877 | # SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit, |
---|
| 878 | # etc. This option is implied by NON_INTERACTIVE. |
---|
| 879 | # ------------------------------------------------------------------------------ |
---|
| 880 | |
---|
| 881 | sub del { |
---|
| 882 | my $self = shift; |
---|
| 883 | my %args = @_; |
---|
| 884 | |
---|
| 885 | # Options |
---|
| 886 | # ---------------------------------------------------------------------------- |
---|
| 887 | my $password = exists $args{PASSWORD} ? $args{PASSWORD} : undef; |
---|
| 888 | my $non_interactive = exists $args{NON_INTERACTIVE} |
---|
| 889 | ? $args{NON_INTERACTIVE} : 0; |
---|
| 890 | my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE} |
---|
| 891 | ? $args{SVN_NON_INTERACTIVE} : 0; |
---|
| 892 | $svn_non_interactive = $non_interactive ? 1 : $svn_non_interactive; |
---|
| 893 | |
---|
| 894 | # Ensure URL is a branch |
---|
| 895 | # ---------------------------------------------------------------------------- |
---|
| 896 | e_report $self->url_peg, ': not a branch, abort.' if not $self->is_branch; |
---|
| 897 | |
---|
| 898 | # Message for the commit log |
---|
| 899 | # ---------------------------------------------------------------------------- |
---|
| 900 | my @message = ('Deleted ' . $self->branch_path . '.' . "\n"); |
---|
| 901 | |
---|
| 902 | # Create a temporary file for the commit log message |
---|
| 903 | my $ci_mesg = Fcm::CmCommitMessage->new; |
---|
| 904 | $ci_mesg->auto_mesg (\@message); |
---|
| 905 | $ci_mesg->ignore_mesg (['D' . ' ' x 4 . $self->url . "\n"]); |
---|
| 906 | my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive); |
---|
| 907 | |
---|
| 908 | # Check with the user to see if he/she wants to go ahead |
---|
| 909 | # ---------------------------------------------------------------------------- |
---|
| 910 | if (not $non_interactive) { |
---|
| 911 | my $mesg = ''; |
---|
| 912 | my $user = $self->config->user_id; |
---|
| 913 | |
---|
| 914 | if ($user and $self->branch_owner ne $user) { |
---|
| 915 | $mesg .= "\n"; |
---|
| 916 | |
---|
| 917 | if (exists $Fcm::CmUrl::owner_keywords{$self->branch_owner}) { |
---|
| 918 | my $type = $Fcm::CmUrl::owner_keywords{$self->branch_owner}; |
---|
| 919 | $mesg .= '*** WARNING: YOU ARE DELETING A ' . uc ($type) . |
---|
| 920 | ' BRANCH.'; |
---|
| 921 | |
---|
| 922 | } else { |
---|
| 923 | $mesg .= '*** WARNING: YOU ARE DELETING A BRANCH NOT OWNED BY YOU.'; |
---|
| 924 | } |
---|
| 925 | |
---|
| 926 | $mesg .= "\n" . |
---|
| 927 | '*** Please ensure that you have the owner\'s permission.' . |
---|
| 928 | "\n\n"; |
---|
| 929 | } |
---|
| 930 | |
---|
| 931 | $mesg .= 'Would you like to go ahead and delete this branch?'; |
---|
| 932 | |
---|
| 933 | my $reply = Fcm::Interactive::get_input ( |
---|
| 934 | title => 'fcm branch', |
---|
| 935 | message => $mesg, |
---|
| 936 | type => 'yn', |
---|
| 937 | default => 'n', |
---|
| 938 | ); |
---|
| 939 | |
---|
| 940 | return unless $reply eq 'y'; |
---|
| 941 | } |
---|
| 942 | |
---|
| 943 | # Delete branch if answer is "y" for "yes" |
---|
| 944 | # ---------------------------------------------------------------------------- |
---|
| 945 | print 'Deleting branch ', $self->url, ' ...', "\n"; |
---|
| 946 | my @command = ( |
---|
| 947 | qw/svn delete/, |
---|
| 948 | '-F', $logfile, |
---|
| 949 | (defined $password ? ('--password', $password) : ()), |
---|
| 950 | ($svn_non_interactive ? '--non-interactive' : ()), |
---|
| 951 | |
---|
| 952 | $self->url, |
---|
| 953 | ); |
---|
| 954 | &run_command (\@command); |
---|
| 955 | |
---|
| 956 | return; |
---|
| 957 | } |
---|
| 958 | |
---|
| 959 | # ------------------------------------------------------------------------------ |
---|
| 960 | # SYNOPSIS |
---|
| 961 | # $cm_branch->display_info ( |
---|
| 962 | # [SHOW_CHILDREN => 1], |
---|
| 963 | # [SHOW_OTHER => 1] |
---|
| 964 | # [SHOW_SIBLINGS => 1] |
---|
| 965 | # ); |
---|
| 966 | # |
---|
| 967 | # DESCRIPTION |
---|
| 968 | # This method displays information of the current branch. If SHOW_CHILDREN is |
---|
| 969 | # set, it shows information of all current children branches of the current |
---|
| 970 | # branch. If SHOW_SIBLINGS is set, it shows information of siblings that have |
---|
| 971 | # been merged recently with the current branch. If SHOW_OTHER is set, it shows |
---|
| 972 | # information of custom/reverse merges. |
---|
| 973 | # ------------------------------------------------------------------------------ |
---|
| 974 | |
---|
| 975 | sub display_info { |
---|
| 976 | my $self = shift; |
---|
| 977 | my %args = @_; |
---|
| 978 | |
---|
| 979 | # Arguments |
---|
| 980 | # ---------------------------------------------------------------------------- |
---|
| 981 | my $show_children = exists $args{SHOW_CHILDREN} ? $args{SHOW_CHILDREN} : 0; |
---|
| 982 | my $show_other = exists $args{SHOW_OTHER } ? $args{SHOW_OTHER} : 0; |
---|
| 983 | my $show_siblings = exists $args{SHOW_SIBLINGS} ? $args{SHOW_SIBLINGS} : 0; |
---|
| 984 | |
---|
| 985 | # Useful variables |
---|
| 986 | # ---------------------------------------------------------------------------- |
---|
| 987 | my $separator = '-' x 80 . "\n"; |
---|
| 988 | my $separator2 = ' ' . '-' x 78 . "\n"; |
---|
| 989 | |
---|
| 990 | # Print "info" as returned by "svn info" |
---|
| 991 | # ---------------------------------------------------------------------------- |
---|
| 992 | for my $key ('URL', 'Repository Root', 'Revision', 'Last Changed Author', |
---|
| 993 | 'Last Changed Rev', 'Last Changed Date') { |
---|
| 994 | print $key, ': ', $self->svninfo (FLAG => $key), "\n" |
---|
| 995 | if $self->svninfo (FLAG => $key); |
---|
| 996 | } |
---|
| 997 | |
---|
| 998 | if ($self->config->verbose) { |
---|
| 999 | # Verbose mode, print log message at last changed revision |
---|
| 1000 | my %log = $self->svnlog (REV => $self->svninfo (FLAG => 'Last Changed Rev')); |
---|
| 1001 | my @log = split /\n/, $log{msg}; |
---|
| 1002 | print 'Last Changed Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n"; |
---|
| 1003 | } |
---|
| 1004 | |
---|
| 1005 | if ($self->is_branch) { |
---|
| 1006 | # Print create information |
---|
| 1007 | # -------------------------------------------------------------------------- |
---|
| 1008 | my %log = $self->svnlog (REV => $self->create_rev); |
---|
| 1009 | |
---|
| 1010 | print $separator; |
---|
| 1011 | print 'Branch Create Author: ', $log{author}, "\n" if $log{author}; |
---|
| 1012 | print 'Branch Create Rev: ', $self->create_rev, "\n"; |
---|
| 1013 | print 'Branch Create Date: ', &svn_date ($log{date}), "\n"; |
---|
| 1014 | |
---|
| 1015 | if ($self->config->verbose) { |
---|
| 1016 | # Verbose mode, print log message at last create revision |
---|
| 1017 | my @log = split /\n/, $log{msg}; |
---|
| 1018 | print 'Branch Create Log:', "\n\n", map ({' ' . $_ . "\n"} @log), "\n"; |
---|
| 1019 | } |
---|
| 1020 | |
---|
| 1021 | # Print delete information if branch no longer exists |
---|
| 1022 | # -------------------------------------------------------------------------- |
---|
| 1023 | print 'Branch Delete Rev: ', $self->delete_rev, "\n" if $self->delete_rev; |
---|
| 1024 | |
---|
| 1025 | # Report merges into/from the parent |
---|
| 1026 | # -------------------------------------------------------------------------- |
---|
| 1027 | # Print the URL@REV of the parent branch |
---|
| 1028 | print $separator, 'Branch Parent: ', $self->parent->url_peg, "\n"; |
---|
| 1029 | |
---|
| 1030 | # Set up a new object for the parent at the current revision |
---|
| 1031 | # -------------------------------------------------------------------------- |
---|
| 1032 | my $p_url = $self->parent->url; |
---|
| 1033 | $p_url .= '@' . $self->pegrev if $self->pegrev; |
---|
| 1034 | my $parent = Fcm::CmBranch->new (URL => $p_url); |
---|
| 1035 | |
---|
| 1036 | if (not $parent->url_exists) { |
---|
| 1037 | print 'Branch parent deleted.', "\n"; |
---|
| 1038 | return; |
---|
| 1039 | } |
---|
| 1040 | |
---|
| 1041 | # Report merges into/from the parent |
---|
| 1042 | # -------------------------------------------------------------------------- |
---|
| 1043 | print $self->_report_merges ($parent, 'Parent'); |
---|
| 1044 | } |
---|
| 1045 | |
---|
| 1046 | # Report merges with siblings |
---|
| 1047 | # ---------------------------------------------------------------------------- |
---|
| 1048 | if ($show_siblings) { |
---|
| 1049 | # Report number of sibling branches found |
---|
| 1050 | print $separator, 'Searching for siblings ... '; |
---|
| 1051 | my @siblings = $self->siblings; |
---|
| 1052 | print scalar (@siblings), ' ', (@siblings> 1 ? 'siblings' : 'sibling'), |
---|
| 1053 | ' found.', "\n"; |
---|
| 1054 | |
---|
| 1055 | # Report branch name and merge information only if there are recent merges |
---|
| 1056 | my $out = ''; |
---|
| 1057 | for my $sibling (@siblings) { |
---|
| 1058 | my $string = $self->_report_merges ($sibling, 'Sibling'); |
---|
| 1059 | |
---|
| 1060 | $out .= $separator2 . ' ' . $sibling->url . "\n" . $string if $string; |
---|
| 1061 | } |
---|
| 1062 | |
---|
| 1063 | if (@siblings) { |
---|
| 1064 | if ($out) { |
---|
| 1065 | print 'Merges with existing siblings:', "\n", $out; |
---|
| 1066 | |
---|
| 1067 | } else { |
---|
| 1068 | print 'No merges with existing siblings.', "\n"; |
---|
| 1069 | } |
---|
| 1070 | } |
---|
| 1071 | } |
---|
| 1072 | |
---|
| 1073 | # Report children |
---|
| 1074 | # ---------------------------------------------------------------------------- |
---|
| 1075 | if ($show_children) { |
---|
| 1076 | # Report number of child branches found |
---|
| 1077 | print $separator, 'Searching for children ... '; |
---|
| 1078 | my @children = $self->children; |
---|
| 1079 | print scalar (@children), ' ', (@children > 1 ? 'children' : 'child'), |
---|
| 1080 | ' found.', "\n"; |
---|
| 1081 | |
---|
| 1082 | # Report children if they exist |
---|
| 1083 | print 'Current children:', "\n" if @children; |
---|
| 1084 | |
---|
| 1085 | for my $child (@children) { |
---|
| 1086 | print $separator2, ' ', $child->url, "\n"; |
---|
| 1087 | print ' Child Create Rev: ', $child->create_rev, "\n"; |
---|
| 1088 | print $self->_report_merges ($child, 'Child'); |
---|
| 1089 | } |
---|
| 1090 | } |
---|
| 1091 | |
---|
| 1092 | # Report custom/reverse merges into the branch |
---|
| 1093 | # ---------------------------------------------------------------------------- |
---|
| 1094 | if ($show_other) { |
---|
| 1095 | my %log = $self->svnlog (STOP_ON_COPY => 1); |
---|
| 1096 | my @out; |
---|
| 1097 | |
---|
| 1098 | # Go down the revision log, checking for merge template messages |
---|
| 1099 | REV: for my $rev (sort {$b <=> $a} keys %log) { |
---|
| 1100 | # Loop each line of the log message at each revision |
---|
| 1101 | my @msg = split /\n/, $log{$rev}{msg}; |
---|
| 1102 | |
---|
| 1103 | for (@msg) { |
---|
| 1104 | # Ignore unless log message matches a merge template |
---|
| 1105 | if (/^Reversed r\d+(:\d+)? of \S+$/ or |
---|
| 1106 | s/^(Custom merge) into \S+(:.+)$/$1$2/) { |
---|
| 1107 | push @out, ('r' . $rev . ': ' . $_) . "\n"; |
---|
| 1108 | } |
---|
| 1109 | } |
---|
| 1110 | } |
---|
| 1111 | |
---|
| 1112 | print $separator, 'Other merges:', "\n", @out if @out; |
---|
| 1113 | } |
---|
| 1114 | |
---|
| 1115 | return; |
---|
| 1116 | } |
---|
| 1117 | |
---|
| 1118 | # ------------------------------------------------------------------------------ |
---|
| 1119 | # SYNOPSIS |
---|
| 1120 | # $string = $self->_report_merges ($branch, $relation); |
---|
| 1121 | # |
---|
| 1122 | # DESCRIPTION |
---|
| 1123 | # This method returns a string for displaying merge information with a |
---|
| 1124 | # branch, the $relation of which can be a Parent, a Sibling or a Child. |
---|
| 1125 | # ------------------------------------------------------------------------------ |
---|
| 1126 | |
---|
| 1127 | sub _report_merges { |
---|
| 1128 | my ($self, $branch, $relation) = @_; |
---|
| 1129 | |
---|
| 1130 | my $indent = ($relation eq 'Parent') ? '' : ' '; |
---|
| 1131 | my $separator = ($relation eq 'Parent') ? ('-' x 80) : (' ' . '-' x 78); |
---|
| 1132 | $separator .= "\n"; |
---|
| 1133 | |
---|
| 1134 | my $return = ''; |
---|
| 1135 | |
---|
| 1136 | # Report last merges into/from the $branch |
---|
| 1137 | # ---------------------------------------------------------------------------- |
---|
| 1138 | my %merge = ( |
---|
| 1139 | 'Last Merge From ' . $relation . ':' |
---|
| 1140 | => [$self->last_merge_from ($branch, 1)], |
---|
| 1141 | 'Last Merge Into ' . $relation . ':' |
---|
| 1142 | => [$branch->last_merge_from ($self, 1)], |
---|
| 1143 | ); |
---|
| 1144 | |
---|
| 1145 | if ($self->config->verbose) { |
---|
| 1146 | # Verbose mode, print the log of the merge |
---|
| 1147 | for my $key (keys %merge) { |
---|
| 1148 | next if not @{ $merge{$key} }; |
---|
| 1149 | |
---|
| 1150 | # From: target (0) is self, upper delta (1) is $branch |
---|
| 1151 | # Into: target (0) is $branch, upper delta (1) is self |
---|
| 1152 | my $t = ($key =~ /From/) ? $self : $branch; |
---|
| 1153 | |
---|
| 1154 | $return .= $indent . $key . "\n"; |
---|
| 1155 | $return .= $separator . $t->display_svnlog ($merge{$key}[0]->pegrev); |
---|
| 1156 | } |
---|
| 1157 | |
---|
| 1158 | } else { |
---|
| 1159 | # Normal mode, print in simplified form (rREV Parent@REV) |
---|
| 1160 | for my $key (keys %merge) { |
---|
| 1161 | next if not @{ $merge{$key} }; |
---|
| 1162 | |
---|
| 1163 | # From: target (0) is self, upper delta (1) is $branch |
---|
| 1164 | # Into: target (0) is $branch, upper delta (1) is self |
---|
| 1165 | $return .= $indent . $key . ' r' . $merge{$key}[0]->pegrev . ' ' . |
---|
| 1166 | $merge{$key}[1]->path_peg . ' cf. ' . |
---|
| 1167 | $merge{$key}[2]->path_peg . "\n"; |
---|
| 1168 | } |
---|
| 1169 | } |
---|
| 1170 | |
---|
| 1171 | if ($relation eq 'Sibling') { |
---|
| 1172 | # For sibling, do not report further if there is no recent merge |
---|
| 1173 | my @values = values %merge; |
---|
| 1174 | |
---|
| 1175 | return $return unless (@{ $values[0] } or @{ $values[1] }); |
---|
| 1176 | } |
---|
| 1177 | |
---|
| 1178 | # Report available merges into/from the $branch |
---|
| 1179 | # ---------------------------------------------------------------------------- |
---|
| 1180 | my %avail = ( |
---|
| 1181 | 'Merges Avail From ' . $relation . ':' |
---|
| 1182 | => ($self->delete_rev ? [] : [$self->avail_merge_from ($branch, 1)]), |
---|
| 1183 | 'Merges Avail Into ' . $relation . ':' |
---|
| 1184 | => [$branch->avail_merge_from ($self, 1)], |
---|
| 1185 | ); |
---|
| 1186 | |
---|
| 1187 | if ($self->config->verbose) { |
---|
| 1188 | # Verbose mode, print the log of each revision |
---|
| 1189 | for my $key (keys %avail) { |
---|
| 1190 | next unless @{ $avail{$key} }; |
---|
| 1191 | |
---|
| 1192 | $return .= $indent . $key . "\n"; |
---|
| 1193 | |
---|
| 1194 | my $s = ($key =~ /From/) ? $branch: $self; |
---|
| 1195 | |
---|
| 1196 | for my $rev (@{ $avail{$key} }) { |
---|
| 1197 | $return .= $separator . $s->display_svnlog ($rev); |
---|
| 1198 | } |
---|
| 1199 | } |
---|
| 1200 | |
---|
| 1201 | } else { |
---|
| 1202 | # Normal mode, print only the revisions |
---|
| 1203 | for my $key (keys %avail) { |
---|
| 1204 | next unless @{ $avail{$key} }; |
---|
| 1205 | |
---|
| 1206 | $return .= $indent . $key . ' ' . join (' ', @{ $avail{$key} }) . "\n"; |
---|
| 1207 | } |
---|
| 1208 | } |
---|
| 1209 | |
---|
| 1210 | return $return; |
---|
| 1211 | } |
---|
| 1212 | |
---|
| 1213 | # ------------------------------------------------------------------------------ |
---|
| 1214 | |
---|
| 1215 | 1; |
---|
| 1216 | |
---|
| 1217 | __END__ |
---|