source: OFFICIAL/FCM_V1.3/lib/Fcm/CmBranch.pm

Last change on this file was 1, checked in by fcm, 15 years ago

creation de larborescence
File size: 40.3 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   Fcm::CmBranch
5#
6# DESCRIPTION
7#   This class contains methods for manipulating a branch. It is a sub-class of
8#   Fcm::CmUrl, and inherits all methods from that class.
9#
10# COPYRIGHT
11#   (C) Crown copyright Met Office. All rights reserved.
12#   For further details please refer to the file COPYRIGHT.txt
13#   which you should have received as part of this distribution.
14# ------------------------------------------------------------------------------
15
16package Fcm::CmBranch;
17@ISA = qw(Fcm::CmUrl);
18
19# Standard pragma
20use warnings;
21use strict;
22
23# Standard modules
24use Carp;
25use File::Spec;
26
27# FCM component modules
28use Fcm::CmCommitMessage;
29use Fcm::CmUrl;
30use Fcm::Config;
31use Fcm::Util qw/run_command e_report w_report get_rev_keyword svn_date/;
32
33my @properties = (
34  'CREATE_REV',  # revision at which the branch is created
35  'DELETE_REV',  # revision at which the branch is deleted
36  'PARENT',      # reference to parent branch Fcm::CmBranch
37  'ANCESTOR',    # list of common ancestors with other branches
38                 # key = URL, value = ancestor Fcm::CmBranch
39  'LAST_MERGE',  # list of last merges from branches
40                 # key = URL@REV, value = [TARGET, UPPER, LOWER]
41  'AVAIL_MERGE', # list of available revisions for merging
42                 # key = URL@REV, value = [REV ...]
43  'CHILDREN',    # list of children of this branch
44  'SIBLINGS',    # list of siblings of this branch
45);
46
47# ------------------------------------------------------------------------------
48# SYNOPSIS
49#   $cm_branch = Fcm::CmBranch->new (URL => $url,);
50#
51# DESCRIPTION
52#   This method constructs a new instance of the Fcm::CmBranch class.
53#
54# ARGUMENTS
55#   URL    - URL of a branch
56# ------------------------------------------------------------------------------
57
58sub new {
59  my $this  = shift;
60  my %args  = @_;
61  my $class = ref $this || $this;
62
63  my $self = Fcm::CmUrl->new (%args);
64
65  $self->{$_} = undef for (@properties);
66
67  bless $self, $class;
68  return $self;
69}
70
71# ------------------------------------------------------------------------------
72# SYNOPSIS
73#   $url = $cm_branch->url_peg;
74#   $cm_branch->url_peg ($url);
75#
76# DESCRIPTION
77#   This method returns/sets the current URL.
78# ------------------------------------------------------------------------------
79
80sub url_peg {
81  my $self = shift;
82
83  if (@_) {
84    if (! $self->{URL} or $_[0] ne $self->{URL}) {
85      # Re-set URL and other essential variables in the SUPER-class
86      $self->SUPER::url_peg (@_);
87
88      # Re-set essential variables
89      $self->{$_} = undef for (@properties);
90    }
91  }
92
93  return $self->{URL};
94}
95
96# ------------------------------------------------------------------------------
97# SYNOPSIS
98#   $rev = $cm_branch->create_rev;
99#
100# DESCRIPTION
101#   This method returns the revision at which the branch was created.
102# ------------------------------------------------------------------------------
103
104sub create_rev {
105  my $self = shift;
106
107  if (not $self->{CREATE_REV}) {
108    return unless $self->url_exists ($self->pegrev);
109
110    # Use "svn log" to find out the first revision of the branch
111    my %log = $self->svnlog (STOP_ON_COPY => 1);
112
113    # Look at log in ascending order
114    my $rev   = (sort {$a <=> $b} keys %log) [0];
115    my $paths = $log{$rev}{paths};
116
117    # Get revision when URL is first added to the repository
118    if (exists $paths->{$self->branch_path}) {
119      $self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A';
120    }
121  }
122
123  return $self->{CREATE_REV};
124}
125
126# ------------------------------------------------------------------------------
127# SYNOPSIS
128#   $parent = $cm_branch->parent;
129#
130# DESCRIPTION
131#   This method returns the parent (a Fcm::CmBranch object) of the current
132#   branch.
133# ------------------------------------------------------------------------------
134
135sub parent {
136  my $self = shift;
137
138  if (not $self->{PARENT}) {
139    # Use the log to find out the parent revision
140    my %log = $self->svnlog (REV => $self->create_rev);
141
142    if (exists $log{paths}{$self->branch_path}) {
143      my $path = $log{paths}{$self->branch_path};
144
145      if ($path->{action} eq 'A') {
146        if (exists $path->{'copyfrom-path'}) {
147          # Current branch is copied from somewhere, set the source as the parent
148          my $url = $self->root .  $path->{'copyfrom-path'};
149          my $rev = $path->{'copyfrom-rev'};
150          $self->{PARENT} = Fcm::CmBranch->new (URL => $url . '@' . $rev);
151
152        } else {
153          # Current branch is not copied from somewhere
154          $self->{PARENT} = $self;
155        }
156      }
157    }
158  }
159
160  return $self->{PARENT};
161}
162
163# ------------------------------------------------------------------------------
164# SYNOPSIS
165#   $rev = $cm_branch->delete_rev;
166#
167# DESCRIPTION
168#   This method returns the revision at which the branch was deleted.
169# ------------------------------------------------------------------------------
170
171sub delete_rev {
172  my $self = shift;
173
174  if (not $self->{DELETE_REV}) {
175    return if $self->url_exists ('HEAD');
176
177    # Container of the current URL
178    (my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##;
179
180    # Use "svn log" on the container between a revision where the branch exists
181    # and the HEAD
182    my $dir = Fcm::CmUrl->new (URL => $dir_url);
183    my %log = $dir->svnlog (
184      REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)],
185    );
186
187    # Go through the log to see when branch no longer exists
188    for my $rev (sort {$a <=> $b} keys %log) {
189      next unless exists $log{$rev}{paths}{$self->branch_path} and
190                  $log{$rev}{paths}{$self->branch_path}{action} eq 'D';
191
192      $self->{DELETE_REV} = $rev;
193      last;
194    }
195  }
196
197  return $self->{DELETE_REV};
198}
199
200# ------------------------------------------------------------------------------
201# SYNOPSIS
202#   $flag = $cm_branch->is_child_of ($branch);
203#
204# DESCRIPTION
205#   This method returns true if the current branch is a child of $branch.
206# ------------------------------------------------------------------------------
207
208sub is_child_of {
209  my ($self, $branch) = @_;
210
211  # The trunk cannot be a child branch
212  return if $self->is_trunk;
213
214  # If $branch is a branch, use name of $self to see when it is created
215  if ($branch->is_branch and $self->url =~ m#/r(\d+)_[^/]+/*$#) {
216    my $rev = $1;
217
218    # $self can only be a child if it is copied from a revision > the create
219    # revision of $branch
220    return if $rev < $branch->create_rev;
221  }
222
223  return if $self->parent->url ne $branch->url;
224
225  # If $branch is a branch, ensure that it is created before $self
226  return if $branch->is_branch and $self->create_rev <= $branch->create_rev;
227
228  return 1;
229}
230
231# ------------------------------------------------------------------------------
232# SYNOPSIS
233#   $flag = $cm_branch->is_sibling_of ($branch);
234#
235# DESCRIPTION
236#   This method returns true if the current branch is a sibling of $branch.
237# ------------------------------------------------------------------------------
238
239sub is_sibling_of {
240  my ($self, $branch) = @_;
241
242  # The trunk cannot be a sibling branch
243  return if $branch->is_trunk;
244
245  return if $self->parent->url ne $branch->parent->url;
246
247  # If the parent is a branch, ensure they are actually the same branch
248  return if $branch->parent->is_branch and
249            $self->parent->create_rev != $branch->parent->create_rev;
250
251  return 1;
252}
253
254# ------------------------------------------------------------------------------
255# SYNOPSIS
256#   $self->_get_relatives ($relation);
257#
258# DESCRIPTION
259#   This method sets the $self->{$relation} variable by inspecting the list of
260#   branches at the current revision of the current branch. $relation can be
261#   either "CHILDREN" or "SIBLINGS".
262# ------------------------------------------------------------------------------
263
264sub _get_relatives {
265  my ($self, $relation) = @_;
266
267  my @branch_list = $self->branch_list;
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  for my $u (@branch_list) {
279    # Ignore URL of current branch and its parent
280    next if $u eq $self->url;
281    next if $self->is_branch and $u eq $self->parent->url;
282
283    # Ignore if URL is a branch detected to be another type of relative
284    next if exists $other_list{$u};
285
286    # Construct new Fcm::CmBranch object from branch URL
287    my $url = $u . ($self->pegrev ? '@' . $self->pegrev : '');
288    my $branch = Fcm::CmBranch->new (URL => $url);
289
290    # Test whether $branch is a relative we are looking for
291    if ($relation eq 'CHILDREN') {
292      push @{ $self->{$relation} }, $branch if $branch->is_child_of ($self);
293
294    } else {
295      push @{ $self->{$relation} }, $branch if $branch->is_sibling_of ($self);
296    }
297  }
298
299  return;
300}
301
302# ------------------------------------------------------------------------------
303# SYNOPSIS
304#   @children = $cm_branch->children;
305#
306# DESCRIPTION
307#   This method returns a list of children (Fcm::CmBranch objects) of the
308#   current branch that exists in the current revision.
309# ------------------------------------------------------------------------------
310
311sub children {
312  my $self = shift;
313
314  $self->_get_relatives ('CHILDREN') if not $self->{CHILDREN};
315
316  return @{ $self->{CHILDREN} };
317}
318
319# ------------------------------------------------------------------------------
320# SYNOPSIS
321#   @siblings = $cm_branch->siblings;
322#
323# DESCRIPTION
324#   This method returns a list of siblings (Fcm::CmBranch objects) of the
325#   current branch that exists in the current revision.
326# ------------------------------------------------------------------------------
327
328sub siblings {
329  my $self = shift;
330
331  $self->_get_relatives ('SIBLINGS') if not $self->{SIBLINGS};
332
333  return @{ $self->{SIBLINGS} };
334}
335
336# ------------------------------------------------------------------------------
337# SYNOPSIS
338#   $ancestor = $cm_branch->ancestor ($branch);
339#
340# DESCRIPTION
341#   This method returns the common ancestor (a Fcm::CmBranch object) of a
342#   specified $branch and the current branch. The argument $branch must be a
343#   Fcm::CmBranch object. Both the current branch and $branch are assumed to be
344#   in the same project.
345# ------------------------------------------------------------------------------
346
347sub ancestor {
348  my ($self, $branch) = @_;
349
350  if (not exists $self->{ANCESTOR}{$branch->url_peg}) {
351    if ($self->url_peg eq $branch->url_peg) {
352      $self->{ANCESTOR}{$branch->url_peg} = $self;
353
354    } else {
355      # Get family tree of current branch, from trunk to current branch
356      my @this_family = ($self);
357      while (not $this_family [0]->is_trunk) {
358        unshift @this_family, $this_family [0]->parent;
359      }
360
361      # Get family tree of $branch, from trunk to $branch
362      my @that_family = ($branch);
363      while (not $that_family [0]->is_trunk) {
364        unshift @that_family, $that_family [0]->parent;
365      }
366
367      # Find common ancestor from list of parents
368      my $ancestor = undef;
369
370      while (not $ancestor) {
371        # $this and $that should both start as some revisions on the trunk.
372        # Walk down a generation each time it loops around.
373        my $this = shift @this_family;
374        my $that = shift @that_family;
375
376        if ($this->url eq $that->url) {
377          if ($this->is_trunk or $this->create_rev eq $that->create_rev) {
378            # $this and $that are the same branch
379            if (@this_family and @that_family) {
380              # More generations in both branches, try comparing the next
381              # generations.
382              next;
383
384            } else {
385              # End of lineage in one of the branches, ancestor is at the lower
386              # revision of the current URL.
387              if ($this->pegrev and $that->pegrev) {
388                $ancestor = $this->pegrev < $that->pegrev ? $this : $that;
389
390              } else {
391                $ancestor = $this->pegrev ? $this : $that;
392              }
393            }
394
395          } else {
396            # Despite the same URL, $this and $that are different branches as
397            # they are created at different revisions. The ancestor must be the
398            # parent with the lower revision. (This should not occur at the
399            # start.)
400            $ancestor = $this->parent->pegrev < $that->parent->pegrev
401                        ? $this->parent : $that->parent;
402          }
403
404        } else {
405          # Different URLs, ancestor must be the parent with the lower revision.
406          # (This should not occur at the start.)
407          $ancestor = $this->parent->pegrev < $that->parent->pegrev
408                      ? $this->parent : $that->parent;
409        }
410      }
411
412      $self->{ANCESTOR}{$branch->url_peg} = $ancestor;
413    }
414  }
415
416  return $self->{ANCESTOR}{$branch->url_peg};
417}
418
419# ------------------------------------------------------------------------------
420# SYNOPSIS
421#   ($target, $upper, $lower) = $cm_branch->last_merge_from (
422#     $branch, $stop_on_copy,
423#   );
424#
425# DESCRIPTION
426#   This method returns a 3-element list with information of the last merge
427#   into the current branch from a specified $branch. The first element in the
428#   list $target (a Fcm::CmBranch object) is the target at which the merge was
429#   performed. (This can be the current branch or a parent branch up to the
430#   common ancestor with the specified $branch.) The second and third elements,
431#   $upper and $lower, (both Fcm::CmBranch objects), are the upper and lower
432#   ends of the source delta. If there is no merge from $branch into the
433#   current branch from their common ancestor to the current revision, this
434#   method will return an empty list. If $stop_on_copy is specified, it ignores
435#   merges from parents of $branch, and merges into parents of the current
436#   branch.
437# ------------------------------------------------------------------------------
438
439sub last_merge_from {
440  my ($self, $branch, $stop_on_copy) = @_;
441
442  if (not exists $self->{LAST_MERGE}{$branch->url_peg}) {
443    # Get "log" of current branch down to the common ancestor
444    my %log = $self->svnlog (
445      REV => [
446       ($self->pegrev ? $self->pegrev : 'HEAD'),
447       $self->ancestor ($branch)->pegrev,
448      ],
449
450      STOP_ON_COPY => $stop_on_copy,
451    );
452
453    my $cr = $self;
454
455    # Go down the revision log, checking for merge template messages
456    REV: for my $rev (sort {$b <=> $a} keys %log) {
457      # Loop each line of the log message at each revision
458      my @msg = split /\n/, $log{$rev}{msg};
459
460      # Also consider merges into parents of current branch
461      $cr = $cr->parent if ($cr->is_branch and $rev < $cr->create_rev);
462
463      for (@msg) {
464        # Ignore unless log message matches a merge template
465        next unless /Merged into \S+: (\S+) cf\. (\S+)/;
466
467        # Upper $1 and lower $2 ends of the source delta
468        my $u_path = $1;
469        my $l_path = $2;
470
471        # Add the root directory to the paths if necessary
472        $u_path = '/' . $u_path if substr ($u_path, 0, 1) ne '/';
473        $l_path = '/' . $l_path if substr ($l_path, 0, 1) ne '/';
474
475        # Only consider merges with specified branch (and its parent)
476        (my $path = $u_path) =~ s/@(\d+)$//;
477        my $u_rev = $1;
478
479        my $br = $branch;
480        $br    = $br->parent while (
481          $br->is_branch and $u_rev < $br->create_rev and not $stop_on_copy
482        );
483
484        next unless $br->branch_path eq $path;
485
486        # If $br is a parent of branch, ignore those merges with the parent
487        # above the branch point of the current branch
488        next if $br->pegrev and $br->pegrev < $u_rev;
489
490        # Set the return values
491        $self->{LAST_MERGE}{$branch->url_peg} = [
492          Fcm::CmBranch->new (URL => $cr->url . '@' . $rev), # target
493          Fcm::CmBranch->new (URL => $self->root . $u_path), # delta upper
494          Fcm::CmBranch->new (URL => $self->root . $l_path), # delta lower
495        ];
496
497        last REV;
498      }
499    }
500  }
501
502  return (exists $self->{LAST_MERGE}{$branch->url_peg}
503          ? @{ $self->{LAST_MERGE}{$branch->url_peg} } : ());
504}
505
506# ------------------------------------------------------------------------------
507# SYNOPSIS
508#   @revs = $cm_branch->avail_merge_from ($branch[, $stop_on_copy]);
509#
510# DESCRIPTION
511#   This method returns a list of revisions of a specified $branch, which are
512#   available for merging into the current branch. If $stop_on_copy is
513#   specified, it will not list available merges from the parents of $branch.
514# ------------------------------------------------------------------------------
515
516sub avail_merge_from {
517  my ($self, $branch, $stop_on_copy) = @_;
518
519  if (not exists $self->{AVAIL_MERGE}{$branch->url_peg}) {
520    # Find out the revision of the upper delta at the last merge from $branch
521    # If no merge is found, use revision of common ancestor with $branch
522    my @last_merge = $self->last_merge_from ($branch);
523    my $rev        = $self->ancestor ($branch)->pegrev;
524    $rev           = $last_merge [1]->pegrev
525      if @last_merge and $last_merge [1]->pegrev > $rev;
526
527    # Get the "log" of the $branch down to $rev
528    my %log = $branch->svnlog (
529      REV          => [($branch->pegrev ? $branch->pegrev : 'HEAD'), $rev],
530      STOP_ON_COPY => $stop_on_copy,
531    );
532
533    # No need to include $rev itself, as it has already been merged
534    delete $log{$rev};
535
536    # No need to include the branch create revision
537    delete $log{$branch->create_rev}
538      if $branch->is_branch and exists $log{$branch->create_rev};
539
540    if (keys %log) {
541      # Check whether there is a latest merge from $self into $branch, if so,
542      # all revisions of $branch below that merge should become unavailable
543      my @last_merge_into = $branch->last_merge_from ($self);
544
545      if (@last_merge_into) {
546        for my $rev (keys %log) {
547          delete $log{$rev} if $rev < $last_merge_into [0]->pegrev;
548        }
549      }
550    }
551
552    # Available merges include all revisions above the branch creation revision
553    # or the revision of the last merge
554    $self->{AVAIL_MERGE}{$branch->url_peg} = [sort {$b <=> $a} keys %log];
555  }
556
557  return @{ $self->{AVAIL_MERGE}{$branch->url_peg} };
558}
559
560# ------------------------------------------------------------------------------
561# SYNOPSIS
562#   $lower = $cm_branch->base_of_merge_from ($branch);
563#
564# DESCRIPTION
565#   This method returns the lower delta (a Fcm::CmBranch object) for the next
566#   merge from $branch.
567# ------------------------------------------------------------------------------
568
569sub base_of_merge_from {
570  my ($self, $branch) = @_;
571
572  # Base is the ancestor if there is no merge between $self and $branch
573  my $return = $self->ancestor ($branch);
574
575  # Get configuration for the last merge from $branch to $self
576  my @merge_from = $self->last_merge_from ($branch);
577
578  # Use the upper delta of the last merge from $branch, as all revisions below
579  # that have already been merged into the $self
580  $return = $merge_from [1]
581    if @merge_from and $merge_from [1]->pegrev > $return->pegrev;
582
583  # Get configuration for the last merge from $self to $branch
584  my @merge_into = $branch->last_merge_from ($self);
585
586  # Use the upper delta of the last merge from $self, as the current revision
587  # of $branch already contains changes of $self up to the peg revision of the
588  # upper delta
589  $return = $merge_into [1]
590    if @merge_into and $merge_into [0]->pegrev > $return->pegrev;
591
592  return $return;
593}
594
595# ------------------------------------------------------------------------------
596# SYNOPSIS
597#   $flag = $cm_branch->allow_subdir_merge_from ($branch, $subdir);
598#
599# DESCRIPTION
600#   This method returns true if a merge from the sub-directory $subdir in
601#   $branch  is allowed - i.e. it does not result in losing changes made in
602#   $branch outside of $subdir.
603# ------------------------------------------------------------------------------
604
605sub allow_subdir_merge_from {
606  my ($self, $branch, $subdir) = @_;
607
608  # Get revision at last merge from $branch or ancestor
609  my @merge_from = $self->last_merge_from ($branch);
610  my $last       = @merge_from ? $merge_from [1] : $self->ancestor ($branch);
611  my $rev        = $last->pegrev;
612
613  my $return = 1;
614  if ($branch->pegrev > $rev) {
615    # Use "svn diff --summarize" to work out what's changed between last
616    # merge/ancestor and current revision
617    my $range = $branch->pegrev . ':' . $rev;
618    my @out = &run_command (
619      [qw/svn diff --summarize -r/, $range, $branch->url_peg], METHOD => 'qx', 
620    );
621
622    # Returns false if there are changes outside of $subdir
623    my $url = join ('/', $branch->url, $subdir);
624    for my $line (@out) {
625      chomp $line;
626      $line = substr ($line, 7); # file name begins at column 7
627      if ($line !~ m#^$url(?:/|$)#) {
628        $return = 0;
629        last;
630      }
631    }
632  }
633
634  return $return;
635}
636
637# ------------------------------------------------------------------------------
638# SYNOPSIS
639#   $cm_branch->create (
640#     SRC                  => $src,
641#     TYPE                 => $type,
642#     NAME                 => $name,
643#     [PASSWORD            => $password,]
644#     [REV_FLAG            => $rev_flag,]
645#     [TICKET              => \@tickets,]
646#     [REV                 => $rev,]
647#     [NON_INTERACTIVE     => 1,]
648#     [SVN_NON_INTERACTIVE => 1,]
649#   );
650#
651# DESCRIPTION
652#   This method creates a branch in a Subversion repository.
653#
654# OPTIONS
655#   SRC                 - reference to a Fcm::CmUrl object.
656#   TYPE                - Specify the branch type. See help in "fcm branch" for
657#                         further information.
658#   NAME                - specify the name of the branch.
659#   NON_INTERACTIVE     - Do no interactive prompting, set SVN_NON_INTERACTIVE
660#                         to true automatically.
661#   PASSWORD            - specify the password for commit access.
662#   REV                 - specify the operative revision of the source.
663#   REV_FLAG            - A flag to specify the behaviour of the prefix to the
664#                         branch name. See help in "fcm branch" for further
665#                         information.
666#   SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit,
667#                         etc. This option is implied by NON_INTERACTIVE.
668#   TICKET              - Specify one or more related tickets for the branch.
669# ------------------------------------------------------------------------------
670
671sub create {
672  my $self = shift;
673  my %args = @_;
674
675  # Options
676  # ----------------------------------------------------------------------------
677  # Compulsory options
678  my $src  = $args{SRC};
679  my $type = $args{TYPE};
680  my $name = $args{NAME};
681
682  # Other options
683  my $rev_flag        = $args{REV_FLAG}        ? $args{REV_FLAG}    : 'NORMAL';
684  my @tickets         = exists $args{TICKET}   ? @{ $args{TICKET} } : ();
685  my $password        = exists $args{PASSWORD} ? $args{PASSWORD}    : undef;
686  my $orev            = exists $args{REV}      ? $args{REV}         : 'HEAD';
687
688  my $non_interactive     = exists $args{NON_INTERACTIVE}
689                            ? $args{NON_INTERACTIVE} : 0;
690  my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE}
691                            ? $args{SVN_NON_INTERACTIVE} : 0;
692  $svn_non_interactive    = $non_interactive ? 1 : $svn_non_interactive;
693
694  # Analyse the source URL
695  # ----------------------------------------------------------------------------
696  # Create branch from the trunk by default
697  $src->branch ('trunk') if not $src->branch;
698
699  # Remove "sub-directory" part from source URL
700  $src->subdir ('')      if $src->subdir;
701
702  # Remove "peg revision" part because it does not work with "svn copy"
703  $src->pegrev ('')      if $src->pegrev;
704
705  # Find out the URL and the last changed revision of the specified URL at the
706  # specified operative revision
707  my $url = $src->svninfo (FLAG => 'URL', REV => $orev);
708  e_report $src->url, ': cannot determine the operative URL at revision ',
709           $orev, ', abort.' if not $url;
710
711  $src->url ($url) if $url ne $src->url;
712
713  my $rev = $src->svninfo (FLAG => 'Last Changed Rev', REV => $orev);
714  e_report $src->url, ': cannot determine the last changed rev at revision',
715           $orev, ', abort.' if not $rev;
716
717  # Warn user if last changed revision is not the specified revision
718  w_report 'Warning: branch will be created from revision ', $rev,
719           ', i.e. the last changed rev.'
720    unless $orev and $orev eq $rev;
721
722  # Determine the sub-directory names of the branch
723  # ----------------------------------------------------------------------------
724  my @branch_dirs = ('branches');
725
726  # Split branch type flags into a hash table
727  my %type_flags = ();
728  $type_flags{$_} = 1 for ((split /$Fcm::Config::DELIMITER/, $type));
729
730  # Branch sub-directory 1, development, test or package
731  for my $flag (qw/DEV TEST PKG/) {
732    if (exists $type_flags{$flag}) {
733      push @branch_dirs, lc ($flag);
734      last;
735    }
736  }
737
738  # Branch sub-directory 2, user, share, configuration or release
739  if (exists $type_flags{USER}) {
740    die 'Unable to determine your user ID, abort' unless $self->config->user_id;
741
742    push @branch_dirs, $self->config->user_id;
743
744  } else {
745    for my $flag (keys %Fcm::CmUrl::owner_keywords) {
746      if (exists $type_flags{uc ($flag)}) {
747        push @branch_dirs, $flag;
748        last;
749      }
750    }
751  }
752
753  # Branch sub-directory 3, branch name
754  # Prefix branch name with revision number/keyword if necessary
755  my $prefix = '';
756  if ($rev_flag ne 'NONE') {
757    $prefix = $rev;
758
759    # Attempt to replace revision number with a revision keyword if necessary
760    $prefix = &get_rev_keyword (
761      REV => $rev,
762      URL => $src->url_peg,
763    ) if $rev_flag eq 'NORMAL';
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 = &main::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
881sub 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 = &main::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
975sub 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
1127sub _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
12151;
1216
1217__END__
Note: See TracBrowser for help on using the repository browser.