New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
CmBranch.pm in vendors/lib/FCM1 – NEMO

source: vendors/lib/FCM1/CmBranch.pm @ 10669

Last change on this file since 10669 was 10669, checked in by nicolasmartin, 5 years ago

Import latest FCM release from Github into the repository for testing
File size: 33.2 KB
Line 
1# ------------------------------------------------------------------------------
2# (C) British Crown Copyright 2006-17 Met Office.
3#
4# This file is part of FCM, tools for managing and building source code.
5#
6# FCM is free software: you can redistribute it and/or modify
7# it under the terms of the GNU General Public License as published by
8# the Free Software Foundation, either version 3 of the License, or
9# (at your option) any later version.
10#
11# FCM is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14# GNU General Public License for more details.
15#
16# You should have received a copy of the GNU General Public License
17# along with FCM. If not, see <http://www.gnu.org/licenses/>.
18# ------------------------------------------------------------------------------
19# NAME
20#   FCM1::CmBranch
21#
22# DESCRIPTION
23#   This class contains methods for manipulating a branch. It is a sub-class of
24#   FCM1::CmUrl, and inherits all methods from that class.
25#
26# ------------------------------------------------------------------------------
27
28package FCM1::CmBranch;
29use base qw{FCM1::CmUrl};
30
31use strict;
32use warnings;
33
34use FCM1::Config;
35use FCM1::Interactive;
36use FCM1::Keyword;
37use FCM1::Util qw/e_report w_report svn_date/;
38
39my @properties = (
40  'CREATE_REV',  # revision at which the branch is created
41  'DELETE_REV',  # revision at which the branch is deleted
42  'PARENT',      # reference to parent branch FCM1::CmBranch
43  'ANCESTOR',    # list of common ancestors with other branches
44                 # key = URL, value = ancestor FCM1::CmBranch
45  'LAST_MERGE',  # list of last merges from branches
46                 # key = URL@REV, value = [TARGET, UPPER, LOWER]
47  'AVAIL_MERGE', # list of available revisions for merging
48                 # key = URL@REV, value = [REV ...]
49  'CHILDREN',    # list of children of this branch
50  'SIBLINGS',    # list of siblings of this branch
51);
52
53# Set the commit message utility provided by FCM::System::CM.
54our $COMMIT_MESSAGE_UTIL;
55sub set_commit_message_util {
56    $COMMIT_MESSAGE_UTIL = shift();
57}
58
59# Set the SVN utility provided by FCM::System::CM.
60our $SVN;
61sub set_svn_util {
62    $SVN = shift();
63}
64
65# ------------------------------------------------------------------------------
66# SYNOPSIS
67#   $cm_branch = FCM1::CmBranch->new (URL => $url,);
68#
69# DESCRIPTION
70#   This method constructs a new instance of the FCM1::CmBranch class.
71#
72# ARGUMENTS
73#   URL    - URL of a branch
74# ------------------------------------------------------------------------------
75
76sub new {
77  my $this  = shift;
78  my %args  = @_;
79  my $class = ref $this || $this;
80
81  my $self = FCM1::CmUrl->new (%args);
82
83  $self->{$_} = undef for (@properties);
84
85  bless $self, $class;
86  return $self;
87}
88
89# ------------------------------------------------------------------------------
90# SYNOPSIS
91#   $url = $cm_branch->url_peg;
92#   $cm_branch->url_peg ($url);
93#
94# DESCRIPTION
95#   This method returns/sets the current URL.
96# ------------------------------------------------------------------------------
97
98sub url_peg {
99  my $self = shift;
100
101  if (@_) {
102    if (! $self->{URL} or $_[0] ne $self->{URL}) {
103      # Re-set URL and other essential variables in the SUPER-class
104      $self->SUPER::url_peg (@_);
105
106      # Re-set essential variables
107      $self->{$_} = undef for (@properties);
108    }
109  }
110
111  return $self->{URL};
112}
113
114# ------------------------------------------------------------------------------
115# SYNOPSIS
116#   $rev = $cm_branch->create_rev;
117#
118# DESCRIPTION
119#   This method returns the revision at which the branch was created.
120# ------------------------------------------------------------------------------
121
122sub create_rev {
123  my $self = shift;
124
125  if (not $self->{CREATE_REV}) {
126    return unless $self->url_exists ($self->pegrev);
127
128    # Use "svn log" to find out the first revision of the branch
129    my %log = $self->svnlog (STOP_ON_COPY => 1);
130
131    # Look at log in ascending order
132    my $rev   = (sort {$a <=> $b} keys %log) [0];
133    my $paths = $log{$rev}{paths};
134
135    # Get revision when URL is first added to the repository
136    if (exists $paths->{$self->branch_path}) {
137      $self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A';
138    }
139  }
140
141  return $self->{CREATE_REV};
142}
143
144# ------------------------------------------------------------------------------
145# SYNOPSIS
146#   $parent = $cm_branch->parent;
147#
148# DESCRIPTION
149#   This method returns the parent (a FCM1::CmBranch object) of the current
150#   branch.
151# ------------------------------------------------------------------------------
152
153sub parent {
154  my $self = shift;
155
156  if (not $self->{PARENT}) {
157    # Use the log to find out the parent revision
158    my %log = $self->svnlog (REV => $self->create_rev);
159
160    if (exists $log{paths}{$self->branch_path}) {
161      my $path = $log{paths}{$self->branch_path};
162
163      if ($path->{action} eq 'A') {
164        if (exists $path->{'copyfrom-path'}) {
165          # Current branch is copied from somewhere, set the source as the parent
166          my $url = $self->root .  $path->{'copyfrom-path'};
167          my $rev = $path->{'copyfrom-rev'};
168          $self->{PARENT} = FCM1::CmBranch->new (URL => $url . '@' . $rev);
169
170        } else {
171          # Current branch is not copied from somewhere
172          $self->{PARENT} = $self;
173        }
174      }
175    }
176  }
177
178  return $self->{PARENT};
179}
180
181# ------------------------------------------------------------------------------
182# SYNOPSIS
183#   $rev = $cm_branch->delete_rev;
184#
185# DESCRIPTION
186#   This method returns the revision at which the branch was deleted.
187# ------------------------------------------------------------------------------
188
189sub delete_rev {
190  my $self = shift;
191
192  if (not $self->{DELETE_REV}) {
193    return if $self->url_exists ('HEAD');
194
195    # Container of the current URL
196    (my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##;
197
198    # Use "svn log" on the container between a revision where the branch exists
199    # and the HEAD
200    my $dir = FCM1::CmUrl->new (URL => $dir_url);
201    my %log = $dir->svnlog (
202      REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)],
203    );
204
205    # Go through the log to see when branch no longer exists
206    for my $rev (sort {$a <=> $b} keys %log) {
207      next unless exists $log{$rev}{paths}{$self->branch_path} and
208                  $log{$rev}{paths}{$self->branch_path}{action} eq 'D';
209
210      $self->{DELETE_REV} = $rev;
211      last;
212    }
213  }
214
215  return $self->{DELETE_REV};
216}
217
218# ------------------------------------------------------------------------------
219# SYNOPSIS
220#   $flag = $cm_branch->is_child_of ($branch);
221#
222# DESCRIPTION
223#   This method returns true if the current branch is a child of $branch.
224# ------------------------------------------------------------------------------
225
226sub is_child_of {
227  my ($self, $branch) = @_;
228  !$self->is_trunk()
229    && $self->parent()->url() eq $branch->url()
230    && (!$branch->is_branch() || $self->create_rev() >= $branch->create_rev());
231}
232
233# ------------------------------------------------------------------------------
234# SYNOPSIS
235#   $flag = $cm_branch->is_sibling_of ($branch);
236#
237# DESCRIPTION
238#   This method returns true if the current branch is a sibling of $branch.
239# ------------------------------------------------------------------------------
240
241sub is_sibling_of {
242  my ($self, $branch) = @_;
243
244  # The trunk cannot be a sibling branch
245  return if $branch->is_trunk;
246
247  return if $self->parent->url ne $branch->parent->url;
248
249  # If the parent is a branch, ensure they are actually the same branch
250  return if $branch->parent->is_branch and
251            $self->parent->create_rev != $branch->parent->create_rev;
252
253  return 1;
254}
255
256# ------------------------------------------------------------------------------
257# SYNOPSIS
258#   $self->_get_relatives ($relation);
259#
260# DESCRIPTION
261#   This method sets the $self->{$relation} variable by inspecting the list of
262#   branches at the current revision of the current branch. $relation can be
263#   either "CHILDREN" or "SIBLINGS".
264# ------------------------------------------------------------------------------
265
266sub _get_relatives {
267  my ($self, $relation) = @_;
268
269  $self->{$relation} = [];
270
271  # If we are searching for CHILDREN, get list of SIBLINGS, and vice versa
272  my $other = ($relation eq 'CHILDREN' ? 'SIBLINGS' : 'CHILDREN');
273  my %other_list;
274  if ($self->{$other}) {
275    %other_list = map {$_->url(), 1} @{$self->{$other}};
276  }
277
278  my @url_peg_list = $self->branch_list();
279  URL:
280  for my $url_peg (@url_peg_list) {
281    my ($url, $peg) = $SVN->split_by_peg($url_peg);
282    # Ignore URL of current branch and its parent
283    if ( $url eq $self->url()
284         # Ignore parent
285      || $self->is_branch() && $url eq $self->parent()->url()
286         # Ignore the other type of relatives
287      || exists($other_list{$url})
288    ) {
289      next URL;
290    }
291
292    my $branch = FCM1::CmBranch->new(URL => $url_peg);
293
294    # Test whether $branch is a relative we are looking for
295    my $can_return = $relation eq 'CHILDREN'
296      ? $branch->is_child_of($self) : $branch->is_sibling_of($self);
297    if ($can_return) {
298      push(@{$self->{$relation}}, $branch);
299    }
300  }
301
302  return;
303}
304
305# ------------------------------------------------------------------------------
306# SYNOPSIS
307#   @children = $cm_branch->children;
308#
309# DESCRIPTION
310#   This method returns a list of children (FCM1::CmBranch objects) of the
311#   current branch that exists in the current revision.
312# ------------------------------------------------------------------------------
313
314sub children {
315  my $self = shift;
316
317  $self->_get_relatives ('CHILDREN') if not $self->{CHILDREN};
318
319  return @{ $self->{CHILDREN} };
320}
321
322# ------------------------------------------------------------------------------
323# SYNOPSIS
324#   @siblings = $cm_branch->siblings;
325#
326# DESCRIPTION
327#   This method returns a list of siblings (FCM1::CmBranch objects) of the
328#   current branch that exists in the current revision.
329# ------------------------------------------------------------------------------
330
331sub siblings {
332  my $self = shift;
333
334  $self->_get_relatives ('SIBLINGS') if not $self->{SIBLINGS};
335
336  return @{ $self->{SIBLINGS} };
337}
338
339# ------------------------------------------------------------------------------
340# SYNOPSIS
341#   $ancestor = $cm_branch->ancestor ($branch);
342#
343# DESCRIPTION
344#   This method returns the common ancestor (a FCM1::CmBranch object) of a
345#   specified $branch and the current branch. The argument $branch must be a
346#   FCM1::CmBranch object. Both the current branch and $branch are assumed to be
347#   in the same project.
348# ------------------------------------------------------------------------------
349
350sub ancestor {
351  my ($self, $branch) = @_;
352
353  if (not exists $self->{ANCESTOR}{$branch->url_peg}) {
354    if ($self->url_peg eq $branch->url_peg) {
355      $self->{ANCESTOR}{$branch->url_peg} = $self;
356
357    } else {
358      # Get family tree of current branch, from trunk to current branch
359      my @this_family = ($self);
360      while (not $this_family [0]->is_trunk) {
361        unshift @this_family, $this_family [0]->parent;
362      }
363
364      # Get family tree of $branch, from trunk to $branch
365      my @that_family = ($branch);
366      while (not $that_family [0]->is_trunk) {
367        unshift @that_family, $that_family [0]->parent;
368      }
369
370      # Find common ancestor from list of parents
371      my $ancestor = undef;
372
373      while (not $ancestor) {
374        # $this and $that should both start as some revisions on the trunk.
375        # Walk down a generation each time it loops around.
376        my $this = shift @this_family;
377        my $that = shift @that_family;
378
379        if ($this->url eq $that->url) {
380          if ($this->is_trunk or $this->create_rev eq $that->create_rev) {
381            # $this and $that are the same branch
382            if (@this_family and @that_family) {
383              # More generations in both branches, try comparing the next
384              # generations.
385              next;
386
387            } else {
388              # End of lineage in one of the branches, ancestor is at the lower
389              # revision of the current URL.
390              if ($this->pegrev and $that->pegrev) {
391                $ancestor = $this->pegrev < $that->pegrev ? $this : $that;
392
393              } else {
394                $ancestor = $this->pegrev ? $this : $that;
395              }
396            }
397
398          } else {
399            # Despite the same URL, $this and $that are different branches as
400            # they are created at different revisions. The ancestor must be the
401            # parent with the lower revision. (This should not occur at the
402            # start.)
403            $ancestor = $this->parent->pegrev < $that->parent->pegrev
404                        ? $this->parent : $that->parent;
405          }
406
407        } else {
408          # Different URLs, ancestor must be the parent with the lower revision.
409          # (This should not occur at the start.)
410          $ancestor = $this->parent->pegrev < $that->parent->pegrev
411                      ? $this->parent : $that->parent;
412        }
413      }
414
415      $self->{ANCESTOR}{$branch->url_peg} = $ancestor;
416    }
417  }
418
419  return $self->{ANCESTOR}{$branch->url_peg};
420}
421
422# ------------------------------------------------------------------------------
423# SYNOPSIS
424#   ($target, $upper, $lower) = $cm_branch->last_merge_from (
425#     $branch, $stop_on_copy,
426#   );
427#
428# DESCRIPTION
429#   This method returns a 3-element list with information of the last merge
430#   into the current branch from a specified $branch. The first element in the
431#   list $target (a FCM1::CmBranch object) is the target at which the merge was
432#   performed. (This can be the current branch or a parent branch up to the
433#   common ancestor with the specified $branch.) The second and third elements,
434#   $upper and $lower, (both FCM1::CmBranch objects), are the upper and lower
435#   ends of the source delta. If there is no merge from $branch into the
436#   current branch from their common ancestor to the current revision, this
437#   method will return an empty list. If $stop_on_copy is specified, it ignores
438#   merges from parents of $branch, and merges into parents of the current
439#   branch.
440# ------------------------------------------------------------------------------
441
442sub last_merge_from {
443  my ($self, $branch, $stop_on_copy) = @_;
444
445  if (not exists $self->{LAST_MERGE}{$branch->url_peg}) {
446    # Get "log" of current branch down to the common ancestor
447    my %log = $self->svnlog (
448      REV => [
449       ($self->pegrev ? $self->pegrev : 'HEAD'),
450       $self->ancestor ($branch)->pegrev,
451      ],
452
453      STOP_ON_COPY => $stop_on_copy,
454    );
455
456    my $cr = $self;
457
458    # Go down the revision log, checking for merge template messages
459    REV: for my $rev (sort {$b <=> $a} keys %log) {
460      # Loop each line of the log message at each revision
461      my @msg = split /\n/, $log{$rev}{msg};
462
463      # Also consider merges into parents of current branch
464      $cr = $cr->parent if ($cr->is_branch and $rev < $cr->create_rev);
465
466      for (@msg) {
467        # Ignore unless log message matches a merge template
468        next unless /Merged into \S+: (\S+) cf\. (\S+)/;
469
470        # Upper $1 and lower $2 ends of the source delta
471        my $u_path = $1;
472        my $l_path = $2;
473
474        # Add the root directory to the paths if necessary
475        $u_path = '/' . $u_path if substr ($u_path, 0, 1) ne '/';
476        $l_path = '/' . $l_path if substr ($l_path, 0, 1) ne '/';
477
478        # Only consider merges with specified branch (and its parent)
479        (my $path = $u_path) =~ s/@(\d+)$//;
480        my $u_rev = $1;
481
482        my $br = $branch;
483        $br    = $br->parent while (
484          $br->is_branch and $u_rev < $br->create_rev and not $stop_on_copy
485        );
486
487        next unless $br->branch_path eq $path;
488
489        # If $br is a parent of branch, ignore those merges with the parent
490        # above the branch point of the current branch
491        next if $br->pegrev and $br->pegrev < $u_rev;
492
493        # Set the return values
494        $self->{LAST_MERGE}{$branch->url_peg} = [
495          FCM1::CmBranch->new (URL => $cr->url . '@' . $rev), # target
496          FCM1::CmBranch->new (URL => $self->root . $u_path), # delta upper
497          FCM1::CmBranch->new (URL => $self->root . $l_path), # delta lower
498        ];
499
500        last REV;
501      }
502    }
503  }
504
505  return (exists $self->{LAST_MERGE}{$branch->url_peg}
506          ? @{ $self->{LAST_MERGE}{$branch->url_peg} } : ());
507}
508
509# ------------------------------------------------------------------------------
510# SYNOPSIS
511#   @revs = $cm_branch->avail_merge_from ($branch[, $stop_on_copy]);
512#
513# DESCRIPTION
514#   This method returns a list of revisions of a specified $branch, which are
515#   available for merging into the current branch. If $stop_on_copy is
516#   specified, it will not list available merges from the parents of $branch.
517# ------------------------------------------------------------------------------
518
519sub avail_merge_from {
520  my ($self, $branch, $stop_on_copy) = @_;
521
522  if (not exists $self->{AVAIL_MERGE}{$branch->url_peg}) {
523    # Find out the revision of the upper delta at the last merge from $branch
524    # If no merge is found, use revision of common ancestor with $branch
525    my @last_merge = $self->last_merge_from ($branch);
526    my $rev        = $self->ancestor ($branch)->pegrev;
527    $rev           = $last_merge [1]->pegrev
528      if @last_merge and $last_merge [1]->pegrev > $rev;
529
530    # Get the "log" of the $branch down to $rev
531    my %log = $branch->svnlog (
532      REV          => [($branch->pegrev ? $branch->pegrev : 'HEAD'), $rev],
533      STOP_ON_COPY => $stop_on_copy,
534    );
535
536    # No need to include $rev itself, as it has already been merged
537    delete $log{$rev};
538
539    # No need to include the branch create revision
540    delete $log{$branch->create_rev}
541      if $branch->is_branch and exists $log{$branch->create_rev};
542
543    if (keys %log) {
544      # Check whether there is a latest merge from $self into $branch, if so,
545      # all revisions of $branch below that merge should become unavailable
546      my @last_merge_into = $branch->last_merge_from ($self);
547
548      if (@last_merge_into) {
549        for my $rev (keys %log) {
550          delete $log{$rev} if $rev < $last_merge_into [0]->pegrev;
551        }
552      }
553    }
554
555    # Available merges include all revisions above the branch creation revision
556    # or the revision of the last merge
557    $self->{AVAIL_MERGE}{$branch->url_peg} = [sort {$b <=> $a} keys %log];
558  }
559
560  return @{ $self->{AVAIL_MERGE}{$branch->url_peg} };
561}
562
563# ------------------------------------------------------------------------------
564# SYNOPSIS
565#   $lower = $cm_branch->base_of_merge_from ($branch);
566#
567# DESCRIPTION
568#   This method returns the lower delta (a FCM1::CmBranch object) for the next
569#   merge from $branch.
570# ------------------------------------------------------------------------------
571
572sub base_of_merge_from {
573  my ($self, $branch) = @_;
574
575  # Base is the ancestor if there is no merge between $self and $branch
576  my $return = $self->ancestor ($branch);
577
578  # Get configuration for the last merge from $branch to $self
579  my @merge_from = $self->last_merge_from ($branch);
580
581  # Use the upper delta of the last merge from $branch, as all revisions below
582  # that have already been merged into the $self
583  $return = $merge_from [1]
584    if @merge_from and $merge_from [1]->pegrev > $return->pegrev;
585
586  # Get configuration for the last merge from $self to $branch
587  my @merge_into = $branch->last_merge_from ($self);
588
589  # Use the upper delta of the last merge from $self, as the current revision
590  # of $branch already contains changes of $self up to the peg revision of the
591  # upper delta
592  $return = $merge_into [1]
593    if @merge_into and $merge_into [0]->pegrev > $return->pegrev;
594
595  return $return;
596}
597
598# ------------------------------------------------------------------------------
599# SYNOPSIS
600#   $flag = $cm_branch->allow_subdir_merge_from ($branch, $subdir);
601#
602# DESCRIPTION
603#   This method returns true if a merge from the sub-directory $subdir in
604#   $branch  is allowed - i.e. it does not result in losing changes made in
605#   $branch outside of $subdir.
606# ------------------------------------------------------------------------------
607
608sub allow_subdir_merge_from {
609  my ($self, $branch, $subdir) = @_;
610
611  # Get revision at last merge from $branch or ancestor
612  my @merge_from = $self->last_merge_from ($branch);
613  my $last       = @merge_from ? $merge_from [1] : $self->ancestor ($branch);
614  my $rev        = $last->pegrev;
615
616  my $return = 1;
617  if ($branch->pegrev > $rev) {
618    # Use "svn diff --summarize" to work out what's changed between last
619    # merge/ancestor and current revision
620    my $range = $branch->pegrev . ':' . $rev;
621    my @out = $SVN->stdout(
622        qw{svn diff --summarize -r}, $range, $branch->url_peg(),
623    );
624
625    # Returns false if there are changes outside of $subdir
626    my $url = join ('/', $branch->url, $subdir);
627    for my $line (@out) {
628      chomp $line;
629      $line = substr ($line, 7); # file name begins at column 7
630      if ($line !~ m#^$url(?:/|$)#) {
631        $return = 0;
632        last;
633      }
634    }
635  }
636
637  return $return;
638}
639
640# ------------------------------------------------------------------------------
641# SYNOPSIS
642#   $cm_branch->delete (
643#     [NON_INTERACTIVE     => 1,]
644#     [PASSWORD            => $password,]
645#     [SVN_NON_INTERACTIVE => 1,]
646#   );
647#
648# DESCRIPTION
649#   This method deletes the current branch from the Subversion repository.
650#
651# OPTIONS
652#   NON_INTERACTIVE     - Do no interactive prompting, set SVN_NON_INTERACTIVE
653#                         to true automatically.
654#   PASSWORD            - specify the password for commit access.
655#   SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit,
656#                         etc. This option is implied by NON_INTERACTIVE.
657# ------------------------------------------------------------------------------
658
659sub del {
660  my $self = shift;
661  my %args = @_;
662
663  # Options
664  # ----------------------------------------------------------------------------
665  my $password            = exists $args{PASSWORD} ? $args{PASSWORD} : undef;
666  my $non_interactive     = exists $args{NON_INTERACTIVE}
667                            ? $args{NON_INTERACTIVE} : 0;
668  my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE}
669                            ? $args{SVN_NON_INTERACTIVE} : 0;
670  $svn_non_interactive    = $non_interactive ? 1 : $svn_non_interactive;
671
672  # Ensure URL is a branch
673  # ----------------------------------------------------------------------------
674  e_report $self->url_peg, ': not a branch, abort.' if not $self->is_branch;
675
676  # Create a temporary file for the commit log message
677  my $temp_handle = $self->_commit_message(
678    sprintf("Deleted %s.\n", $self->branch_path()), 'D', $non_interactive,
679  );
680
681  # Check with the user to see if he/she wants to go ahead
682  # ----------------------------------------------------------------------------
683  if (!$non_interactive) {
684    my $mesg = '';
685    if ($self->branch_owner() && !$self->layout()->is_owned_by_user()) {
686      $mesg .= "\n";
687
688      if (exists $FCM1::CmUrl::owner_keywords{$self->branch_owner()}) {
689        my $type = $FCM1::CmUrl::owner_keywords{$self->branch_owner()};
690        $mesg .= '*** WARNING: YOU ARE DELETING A ' . uc ($type) .
691                 ' BRANCH.';
692
693      } else {
694        $mesg .= '*** WARNING: YOU ARE DELETING A BRANCH NOT OWNED BY YOU.';
695      }
696
697      $mesg .= "\n" .
698               '*** Please ensure that you have the owner\'s permission.' .
699               "\n\n";
700    }
701
702    $mesg   .= 'Would you like to go ahead and delete this branch?';
703
704    my $reply = FCM1::Interactive::get_input (
705      title   => 'fcm branch',
706      message => $mesg,
707      type    => 'yn',
708      default => 'n',
709    );
710
711    return unless $reply eq 'y';
712  }
713
714  # Delete branch if answer is "y" for "yes"
715  # ----------------------------------------------------------------------------
716  print 'Deleting branch ', $self->url, ' ...', "\n";
717  $SVN->call(
718    'delete',
719    '-F', $temp_handle->filename(),
720    (defined $password    ? ('--password', $password) : ()),
721    ($svn_non_interactive ? '--non-interactive'       : ()),
722    $self->url(),
723  );
724
725  return;
726}
727
728# ------------------------------------------------------------------------------
729# SYNOPSIS
730#   $cm_branch->display_info (
731#     [SHOW_CHILDREN => 1],
732#     [SHOW_OTHER    => 1]
733#     [SHOW_SIBLINGS => 1]
734#   );
735#
736# DESCRIPTION
737#   This method displays information of the current branch. If SHOW_CHILDREN is
738#   set, it shows information of all current children branches of the current
739#   branch. If SHOW_SIBLINGS is set, it shows information of siblings that have
740#   been merged recently with the current branch. If SHOW_OTHER is set, it shows
741#   information of custom/reverse merges.
742# ------------------------------------------------------------------------------
743
744sub display_info {
745  my $self = shift;
746  my %args = @_;
747
748  # Arguments
749  # ----------------------------------------------------------------------------
750  my $show_children = exists $args{SHOW_CHILDREN} ? $args{SHOW_CHILDREN} : 0;
751  my $show_other    = exists $args{SHOW_OTHER   } ? $args{SHOW_OTHER}    : 0;
752  my $show_siblings = exists $args{SHOW_SIBLINGS} ? $args{SHOW_SIBLINGS} : 0;
753
754  # Useful variables
755  # ----------------------------------------------------------------------------
756  my $separator  = '-' x 80 . "\n";
757  my $separator2 = '  ' . '-' x 78 . "\n";
758
759  # Print "info" as returned by "svn info"
760  # ----------------------------------------------------------------------------
761  for (
762    ['URL',                 'url'            ],
763    ['Repository Root',     'repository:root'],
764    ['Revision',            'revision'       ],
765    ['Last Changed Author', 'commit:author'  ],
766    ['Last Changed Rev',    'commit:revision'],
767    ['Last Changed Date',   'commit:date'    ],
768  ) {
769    my ($key, $flag) = @{$_};
770    if ($self->svninfo(FLAG => $flag)) {
771      printf("%s: %s\n", $key, $self->svninfo(FLAG => $flag));
772    }
773  }
774
775  if ($self->config->verbose) {
776    # Verbose mode, print log message at last changed revision
777    my %log = $self->svnlog (REV => $self->svninfo(FLAG => 'commit:revision'));
778    my @log = split /\n/, $log{msg};
779    print 'Last Changed Log:', "\n\n", map ({'  ' . $_ . "\n"} @log), "\n";
780  }
781
782  if ($self->is_branch) {
783    # Print create information
784    # --------------------------------------------------------------------------
785    my %log = $self->svnlog (REV => $self->create_rev);
786
787    print $separator;
788    print 'Branch Create Author: ', $log{author}, "\n" if $log{author};
789    print 'Branch Create Rev: ', $self->create_rev, "\n";
790    print 'Branch Create Date: ', &svn_date ($log{date}), "\n";
791
792    if ($self->config->verbose) {
793      # Verbose mode, print log message at last create revision
794      my @log = split /\n/, $log{msg};
795      print 'Branch Create Log:', "\n\n", map ({'  ' . $_ . "\n"} @log), "\n";
796    }
797
798    # Print delete information if branch no longer exists
799    # --------------------------------------------------------------------------
800    print 'Branch Delete Rev: ', $self->delete_rev, "\n" if $self->delete_rev;
801
802    # Report merges into/from the parent
803    # --------------------------------------------------------------------------
804    # Print the URL@REV of the parent branch
805    print $separator, 'Branch Parent: ', $self->parent->url_peg, "\n";
806
807    # Set up a new object for the parent at the current revision
808    # --------------------------------------------------------------------------
809    my $p_url  = $self->parent->url;
810    $p_url    .= '@' . $self->pegrev if $self->pegrev;
811    my $parent = FCM1::CmBranch->new (URL => $p_url);
812
813    if (not $parent->url_exists) {
814      print 'Branch parent deleted.', "\n";
815      return;
816    }
817
818    # Report merges into/from the parent
819    # --------------------------------------------------------------------------
820    print $self->_report_merges ($parent, 'Parent');
821  }
822
823  # Report merges with siblings
824  # ----------------------------------------------------------------------------
825  if ($show_siblings) {
826    # Report number of sibling branches found
827    print $separator, 'Searching for siblings ... ';
828    my @siblings = $self->siblings;
829    print scalar (@siblings), ' ', (@siblings> 1 ? 'siblings' : 'sibling'),
830          ' found.', "\n";
831
832    # Report branch name and merge information only if there are recent merges
833    my $out = '';
834    for my $sibling (@siblings) {
835      my $string = $self->_report_merges ($sibling, 'Sibling');
836
837      $out .= $separator2 . '  ' . $sibling->url . "\n" . $string if $string;
838    }
839
840    if (@siblings) {
841      if ($out) {
842        print 'Merges with existing siblings:', "\n", $out;
843
844      } else {
845        print 'No merges with existing siblings.', "\n";
846      }
847    }
848  }
849
850  # Report children
851  # ----------------------------------------------------------------------------
852  if ($show_children) {
853    # Report number of child branches found
854    print $separator, 'Searching for children ... ';
855    my @children = $self->children;
856    print scalar (@children), ' ', (@children > 1 ? 'children' : 'child'),
857          ' found.', "\n";
858
859    # Report children if they exist
860    print 'Current children:', "\n" if @children;
861
862    for my $child (@children) {
863      print $separator2, '  ', $child->url, "\n";
864      print '  Child Create Rev: ', $child->create_rev, "\n";
865      print $self->_report_merges ($child, 'Child');
866    }
867  }
868
869  # Report custom/reverse merges into the branch
870  # ----------------------------------------------------------------------------
871  if ($show_other) {
872    my %log = $self->svnlog (STOP_ON_COPY => 1);
873    my @out;
874
875    # Go down the revision log, checking for merge template messages
876    REV: for my $rev (sort {$b <=> $a} keys %log) {
877      # Loop each line of the log message at each revision
878      my @msg = split /\n/, $log{$rev}{msg};
879
880      for (@msg) {
881        # Ignore unless log message matches a merge template
882        if (/^Reversed r\d+(:\d+)? of \S+$/ or
883            s/^(Custom merge) into \S+(:.+)$/$1$2/) {
884          push @out, ('r' . $rev . ': ' . $_) . "\n";
885        }
886      }
887    }
888
889    print $separator, 'Other merges:', "\n", @out if @out;
890  }
891
892  return;
893}
894
895# ------------------------------------------------------------------------------
896# SYNOPSIS
897#   $string = $self->_report_merges ($branch, $relation);
898#
899# DESCRIPTION
900#   This method returns a string for displaying merge information with a
901#   branch, the $relation of which can be a Parent, a Sibling or a Child.
902# ------------------------------------------------------------------------------
903
904sub _report_merges {
905  my ($self, $branch, $relation) = @_;
906
907  my $indent    = ($relation eq 'Parent') ? '' : '  ';
908  my $separator = ($relation eq 'Parent') ? ('-' x 80) : ('  ' . '-' x 78);
909  $separator   .= "\n";
910
911  my $return = '';
912
913  # Report last merges into/from the $branch
914  # ----------------------------------------------------------------------------
915  my %merge  = (
916    'Last Merge From ' . $relation . ':'
917    => [$self->last_merge_from ($branch, 1)],
918    'Last Merge Into ' . $relation . ':'
919    => [$branch->last_merge_from ($self, 1)],
920  );
921
922  if ($self->config->verbose) {
923    # Verbose mode, print the log of the merge
924    for my $key (keys %merge) {
925      next if not @{ $merge{$key} };
926
927      # From: target (0) is self, upper delta (1) is $branch
928      # Into: target (0) is $branch, upper delta (1) is self
929      my $t = ($key =~ /From/) ? $self : $branch;
930
931      $return .= $indent . $key . "\n";
932      $return .= $separator . $t->display_svnlog ($merge{$key}[0]->pegrev);
933    }
934
935  } else {
936    # Normal mode, print in simplified form (rREV Parent@REV)
937    for my $key (keys %merge) {
938      next if not @{ $merge{$key} };
939
940      # From: target (0) is self, upper delta (1) is $branch
941      # Into: target (0) is $branch, upper delta (1) is self
942      $return .= $indent . $key . ' r' . $merge{$key}[0]->pegrev . ' ' .
943                 $merge{$key}[1]->path_peg . ' cf. ' .
944                 $merge{$key}[2]->path_peg . "\n";
945    }
946  }
947
948  if ($relation eq 'Sibling') {
949    # For sibling, do not report further if there is no recent merge
950    my @values = values %merge;
951
952    return $return unless (@{ $values[0] } or @{ $values[1] });
953  }
954
955  # Report available merges into/from the $branch
956  # ----------------------------------------------------------------------------
957  my %avail = (
958    'Merges Avail From ' . $relation . ':'
959    => ($self->delete_rev ? [] : [$self->avail_merge_from ($branch, 1)]),
960    'Merges Avail Into ' . $relation . ':'
961    => [$branch->avail_merge_from ($self, 1)],
962  );
963
964  if ($self->config->verbose) {
965    # Verbose mode, print the log of each revision
966    for my $key (sort keys %avail) {
967      next unless @{ $avail{$key} };
968
969      $return .= $indent . $key . "\n";
970
971      my $s = ($key =~ /From/) ? $branch: $self;
972
973      for my $rev (@{ $avail{$key} }) {
974        $return .= $separator . $s->display_svnlog ($rev);
975      }
976    }
977
978  } else {
979    # Normal mode, print only the revisions
980    for my $key (sort keys %avail) {
981      next unless @{ $avail{$key} };
982
983      $return .= $indent . $key . ' ' . join (' ', @{ $avail{$key} }) . "\n";
984    }
985  }
986
987  return $return;
988}
989
990# Returns a File::Temp object containing the commit log for create/del.
991sub _commit_message {
992    my ($self, $message, $action, $non_interactive) = @_;
993    my $commit_message_ctx = $COMMIT_MESSAGE_UTIL->ctx();
994    $commit_message_ctx->set_auto_part($message);
995    $commit_message_ctx->set_info_part(
996        sprintf("%s    %s\n", $action, $self->url())
997    );
998    if (!$non_interactive) {
999        $COMMIT_MESSAGE_UTIL->edit($commit_message_ctx);
1000    }
1001    $COMMIT_MESSAGE_UTIL->notify($commit_message_ctx);
1002    $COMMIT_MESSAGE_UTIL->temp($commit_message_ctx);
1003}
1004
1005# ------------------------------------------------------------------------------
1006
10071;
1008
1009__END__
Note: See TracBrowser for help on using the repository browser.