source: LMDZ6/branches/IPSL-CM6A-MR/tools/fcm/lib/Fcm/CmBranch.pm @ 5407

Last change on this file since 5407 was 1578, checked in by jghattas, 13 years ago
  • Add fcm in LMDZ5/tools directory

It is no longer needed to have fcm in your environement PATH variable.
Now makelmdz_fcm takes by default this fcm. It is still possible to use
another fcm, using -fcm_path argument in makelmdz_fcm.
File size: 39.8 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::Util qw/run_command e_report w_report get_rev_keyword svn_date/;
31
32my @properties = (
33  'CREATE_REV',  # revision at which the branch is created
34  'DELETE_REV',  # revision at which the branch is deleted
35  'PARENT',      # reference to parent branch Fcm::CmBranch
36  'ANCESTOR',    # list of common ancestors with other branches
37                 # key = URL, value = ancestor Fcm::CmBranch
38  'LAST_MERGE',  # list of last merges from branches
39                 # key = URL@REV, value = [TARGET, UPPER, LOWER]
40  'AVAIL_MERGE', # list of available revisions for merging
41                 # key = URL@REV, value = [REV ...]
42  'CHILDREN',    # list of children of this branch
43  'SIBLINGS',    # list of siblings of this branch
44);
45
46# ------------------------------------------------------------------------------
47# SYNOPSIS
48#   $cm_branch = Fcm::CmBranch->new (
49#     CONFIG  => $config,
50#     URL     => $url,
51#   );
52#
53# DESCRIPTION
54#   This method constructs a new instance of the Fcm::CmBranch class.
55#
56# ARGUMENTS
57#   CONFIG - reference to a Fcm::Config instance
58#   URL    - URL of a branch
59# ------------------------------------------------------------------------------
60
61sub new {
62  my $this  = shift;
63  my %args  = @_;
64  my $class = ref $this || $this;
65
66  my $self = Fcm::CmUrl->new (%args);
67
68  $self->{$_} = undef for (@properties);
69
70  bless $self, $class;
71  return $self;
72}
73
74# ------------------------------------------------------------------------------
75# SYNOPSIS
76#   $url = $cm_branch->url_peg;
77#   $cm_branch->url_peg ($url);
78#
79# DESCRIPTION
80#   This method returns/sets the current URL.
81# ------------------------------------------------------------------------------
82
83sub url_peg {
84  my $self = shift;
85
86  if (@_) {
87    if (! $self->{URL} or $_[0] ne $self->{URL}) {
88      # Re-set URL and other essential variables in the SUPER-class
89      $self->SUPER::url_peg (@_);
90
91      # Re-set essential variables
92      $self->{$_} = undef for (@properties);
93    }
94  }
95
96  return $self->{URL};
97}
98
99# ------------------------------------------------------------------------------
100# SYNOPSIS
101#   $rev = $cm_branch->create_rev;
102#
103# DESCRIPTION
104#   This method returns the revision at which the branch was created.
105# ------------------------------------------------------------------------------
106
107sub create_rev {
108  my $self = shift;
109
110  if (not $self->{CREATE_REV}) {
111    return unless $self->url_exists ($self->pegrev);
112
113    # Use "svn log" to find out the first revision of the branch
114    my %log = $self->svnlog (STOP_ON_COPY => 1);
115
116    # Look at log in ascending order
117    my $rev   = (sort {$a <=> $b} keys %log) [0];
118    my $paths = $log{$rev}{paths};
119
120    # Get revision when URL is first added to the repository
121    if (exists $paths->{$self->branch_path}) {
122      $self->{CREATE_REV} = $rev if $paths->{$self->branch_path}{action} eq 'A';
123    }
124  }
125
126  return $self->{CREATE_REV};
127}
128
129# ------------------------------------------------------------------------------
130# SYNOPSIS
131#   $parent = $cm_branch->parent;
132#
133# DESCRIPTION
134#   This method returns the parent (a Fcm::CmBranch object) of the current
135#   branch.
136# ------------------------------------------------------------------------------
137
138sub parent {
139  my $self = shift;
140
141  if (not $self->{PARENT}) {
142    # Use the log to find out the parent revision
143    my %log = $self->svnlog (REV => $self->create_rev);
144
145    if (exists $log{paths}{$self->branch_path}) {
146      my $path = $log{paths}{$self->branch_path};
147
148      if ($path->{action} eq 'A') {
149        if (exists $path->{'copyfrom-path'}) {
150          # Current branch is copied from somewhere, set the source as the parent
151          my $url = $self->root .  $path->{'copyfrom-path'};
152          my $rev = $path->{'copyfrom-rev'};
153          $self->{PARENT} = Fcm::CmBranch->new (URL => $url . '@' . $rev);
154
155        } else {
156          # Current branch is not copied from somewhere
157          $self->{PARENT} = $self;
158        }
159      }
160    }
161  }
162
163  return $self->{PARENT};
164}
165
166# ------------------------------------------------------------------------------
167# SYNOPSIS
168#   $rev = $cm_branch->delete_rev;
169#
170# DESCRIPTION
171#   This method returns the revision at which the branch was deleted.
172# ------------------------------------------------------------------------------
173
174sub delete_rev {
175  my $self = shift;
176
177  if (not $self->{DELETE_REV}) {
178    return if $self->url_exists ('HEAD');
179
180    # Container of the current URL
181    (my $dir_url = $self->branch_url) =~ s#/+[^/]+/*$##;
182
183    # Use "svn log" on the container between a revision where the branch exists
184    # and the HEAD
185    my $dir = Fcm::CmUrl->new (URL => $dir_url);
186    my %log = $dir->svnlog (
187      REV => ['HEAD', ($self->pegrev ? $self->pegrev : $self->create_rev)],
188    );
189
190    # Go through the log to see when branch no longer exists
191    for my $rev (sort {$a <=> $b} keys %log) {
192      next unless exists $log{$rev}{paths}{$self->branch_path} and
193                  $log{$rev}{paths}{$self->branch_path}{action} eq 'D';
194
195      $self->{DELETE_REV} = $rev;
196      last;
197    }
198  }
199
200  return $self->{DELETE_REV};
201}
202
203# ------------------------------------------------------------------------------
204# SYNOPSIS
205#   $flag = $cm_branch->is_child_of ($branch);
206#
207# DESCRIPTION
208#   This method returns true if the current branch is a child of $branch.
209# ------------------------------------------------------------------------------
210
211sub is_child_of {
212  my ($self, $branch) = @_;
213
214  # The trunk cannot be a child branch
215  return if $self->is_trunk;
216
217  # If $branch is a branch, use name of $self to see when it is created
218  if ($branch->is_branch and $self->url =~ m#/r(\d+)_[^/]+/*$#) {
219    my $rev = $1;
220
221    # $self can only be a child if it is copied from a revision > the create
222    # revision of $branch
223    return if $rev < $branch->create_rev;
224  }
225
226  return if $self->parent->url ne $branch->url;
227
228  # If $branch is a branch, ensure that it is created before $self
229  return if $branch->is_branch and $self->create_rev <= $branch->create_rev;
230
231  return 1;
232}
233
234# ------------------------------------------------------------------------------
235# SYNOPSIS
236#   $flag = $cm_branch->is_sibling_of ($branch);
237#
238# DESCRIPTION
239#   This method returns true if the current branch is a sibling of $branch.
240# ------------------------------------------------------------------------------
241
242sub is_sibling_of {
243  my ($self, $branch) = @_;
244
245  # The trunk cannot be a sibling branch
246  return if $branch->is_trunk;
247
248  return if $self->parent->url ne $branch->parent->url;
249
250  # If the parent is a branch, ensure they are actually the same branch
251  return if $branch->parent->is_branch and
252            $self->parent->create_rev != $branch->parent->create_rev;
253
254  return 1;
255}
256
257# ------------------------------------------------------------------------------
258# SYNOPSIS
259#   $self->_get_relatives ($relation);
260#
261# DESCRIPTION
262#   This method sets the $self->{$relation} variable by inspecting the list of
263#   branches at the current revision of the current branch. $relation can be
264#   either "CHILDREN" or "SIBLINGS".
265# ------------------------------------------------------------------------------
266
267sub _get_relatives {
268  my ($self, $relation) = @_;
269
270  my @branch_list = $self->branch_list;
271
272  $self->{$relation} = [];
273
274  # If we are searching for CHILDREN, get list of SIBLINGS, and vice versa
275  my $other = ($relation eq 'CHILDREN' ? 'SIBLINGS' : 'CHILDREN');
276  my %other_list;
277  if ($self->{$other}) {
278    %other_list = map {$_->url, 1} @{ $self->{$other} };
279  }
280
281  for my $u (@branch_list) {
282    # Ignore URL of current branch and its parent
283    next if $u eq $self->url;
284    next if $self->is_branch and $u eq $self->parent->url;
285
286    # Ignore if URL is a branch detected to be another type of relative
287    next if exists $other_list{$u};
288
289    # Construct new Fcm::CmBranch object from branch URL
290    my $url = $u . ($self->pegrev ? '@' . $self->pegrev : '');
291    my $branch = Fcm::CmBranch->new (URL => $url);
292
293    # Test whether $branch is a relative we are looking for
294    if ($relation eq 'CHILDREN') {
295      push @{ $self->{$relation} }, $branch if $branch->is_child_of ($self);
296
297    } else {
298      push @{ $self->{$relation} }, $branch if $branch->is_sibling_of ($self);
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 (Fcm::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 (Fcm::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 Fcm::CmBranch object) of a
345#   specified $branch and the current branch. The argument $branch must be a
346#   Fcm::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 Fcm::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 Fcm::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          Fcm::CmBranch->new (URL => $cr->url . '@' . $rev), # target
496          Fcm::CmBranch->new (URL => $self->root . $u_path), # delta upper
497          Fcm::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 Fcm::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  if ($branch->pegrev > $rev) {
617    # Inspect log from revision at last merge/ancestor to current revision
618    my %log = $branch->svnlog (REV => [$branch->pegrev, $rev + 1]);
619    my $br  = $branch;
620
621    # Check whether there are changes outside of $subdir
622    for my $rev (sort {$b <=> $a} keys %log) {
623      $br = $br->parent if $br->is_branch and $rev < $br->create_rev;
624
625      for my $path (keys %{ $log{$rev}{paths} }) {
626        next if $path eq $br->branch_path; # Ignore branch creation
627
628        my $p_subdir = substr ($path, length ($br->branch_path) + 1);
629
630        return if $p_subdir !~ m#^$subdir(?:/|$)#;
631      }
632    }
633  }
634
635  return 1;
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
672sub 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 /::/, $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    my $userid = getlogin;
742    $userid    = $ENV{LOGNAME} unless $userid;
743    $userid    = $ENV{USER}    unless $userid;
744    die 'Unable to determine your user ID, abort' unless $userid;
745
746    push @branch_dirs, $userid;
747
748  } else {
749    for my $flag (qw/SHARE CONFIG REL/) {
750      if (exists $type_flags{$flag}) {
751        push @branch_dirs, uc (substr $flag, 0, 1) . lc (substr $flag, 1);
752        last;
753      }
754    }
755  }
756
757  # Branch sub-directory 3, branch name
758  # Prefix branch name with revision number/keyword if necessary
759  my $prefix = '';
760  if ($rev_flag ne 'NONE') {
761    $prefix = $rev;
762
763    # Attempt to replace revision number with a revision keyword if necessary
764    $prefix = &get_rev_keyword (
765      REV => $rev,
766      URL => $src->url_peg,
767    ) if $rev_flag eq 'NORMAL';
768
769    # $prefix is still a revision number, add "r" in front of it
770    $prefix = 'r' . $prefix if $prefix eq $rev;
771
772    # Add an underscore before the branch name
773    $prefix.= '_';
774  }
775
776  # Branch name
777  push @branch_dirs, $prefix . $name;
778
779  # Check whether the branch already exists, fail if so
780  # ----------------------------------------------------------------------------
781  # Construct the URL of the branch
782  $self->project_url ($src->project_url);
783  $self->branch  (join ('/', @branch_dirs));
784
785  # Check that branch does not already exists
786  e_report $self->url, ': branch already exists, abort.' if $self->url_exists;
787
788  # Message for the commit log
789  # ----------------------------------------------------------------------------
790  my @message = ('Created ' . $self->branch_path .  ' from ' .
791                 $src->branch_path . '@' . $rev . '.' . "\n");
792
793  # Add related Trac ticket links to commit log if set
794  if (@tickets) {
795    my $ticket_mesg = 'Relates to ticket' . (@tickets > 1 ? 's' : '');
796
797    while (my $ticket = shift @tickets) {
798      $ticket_mesg .= ' #' . $ticket;
799      $ticket_mesg .= (@tickets > 1 ? ',' : ' and') if @tickets >= 1;
800    }
801
802    push @message, $ticket_mesg . ".\n";
803  }
804
805  # Create a temporary file for the commit log message
806  my $ci_mesg = Fcm::CmCommitMessage->new;
807  $ci_mesg->auto_mesg (@message);
808  $ci_mesg->ignore_mesg ('A' . ' ' x 4 . $self->url . "\n");
809  my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive);
810
811  # Check with the user to see if he/she wants to go ahead
812  # ----------------------------------------------------------------------------
813  if (not $non_interactive) {
814    my $reply = &main::get_input (
815      TITLE   => 'fcm branch',
816      MESSAGE => 'Would you like to go ahead and create this branch?',
817      TYPE    => 'yn',
818      DEFAULT => 'n',
819    );
820
821    return unless $reply eq 'y';
822  }
823
824  # Ensure existence of container sub-directories of the branch
825  # ----------------------------------------------------------------------------
826  for my $i (0 .. $#branch_dirs - 1) {
827    my $subdir     = join ('/', @branch_dirs[0 .. $i]);
828    my $subdir_url = Fcm::CmUrl->new (URL => $src->project_url . '/' . $subdir);
829
830    # Check whether each sub-directory of the branch already exists,
831    # if sub-directory does not exist, create it
832    next if $subdir_url->url_exists;
833
834    print 'Creating sub-directory: ', $subdir, "\n";
835
836    my @command = (
837      qw/svn mkdir/,
838      '-m', 'Created ' . $subdir . ' directory.',
839      ($svn_non_interactive  ? '--non-interactive'       : ()),
840      (defined $password     ? ('--password', $password) : ()),
841
842      $subdir_url->url,
843    );
844    &run_command (\@command);
845  }
846
847  # Create the branch
848  # ----------------------------------------------------------------------------
849  {
850    print 'Creating branch ', $self->url, ' ...', "\n";
851    my @command = (
852      qw/svn copy/,
853      '-r', $rev,
854      '-F', $logfile,
855      ($svn_non_interactive  ? '--non-interactive'       : ()),
856      (defined $password     ? ('--password', $password) : ()),
857
858      $src->url, $self->url,
859    );
860    &run_command (\@command);
861  }
862
863  return;
864}
865
866# ------------------------------------------------------------------------------
867# SYNOPSIS
868#   $cm_branch->delete (
869#     [NON_INTERACTIVE     => 1,]
870#     [PASSWORD            => $password,]
871#     [SVN_NON_INTERACTIVE => 1,]
872#   );
873#
874# DESCRIPTION
875#   This method deletes the current branch from the Subversion repository.
876#
877# OPTIONS
878#   NON_INTERACTIVE     - Do no interactive prompting, set SVN_NON_INTERACTIVE
879#                         to true automatically.
880#   PASSWORD            - specify the password for commit access.
881#   SVN_NON_INTERACTIVE - Do no interactive prompting when running svn commit,
882#                         etc. This option is implied by NON_INTERACTIVE.
883# ------------------------------------------------------------------------------
884
885sub del {
886  my $self = shift;
887  my %args = @_;
888
889  # Options
890  # ----------------------------------------------------------------------------
891  my $password            = exists $args{PASSWORD} ? $args{PASSWORD} : undef;
892  my $non_interactive     = exists $args{NON_INTERACTIVE}
893                            ? $args{NON_INTERACTIVE} : 0;
894  my $svn_non_interactive = exists $args{SVN_NON_INTERACTIVE}
895                            ? $args{SVN_NON_INTERACTIVE} : 0;
896  $svn_non_interactive    = $non_interactive ? 1 : $svn_non_interactive;
897
898  # Ensure URL is a branch
899  # ----------------------------------------------------------------------------
900  e_report $self->url_peg, ': not a branch, abort.' if not $self->is_branch;
901
902  # Message for the commit log
903  # ----------------------------------------------------------------------------
904  my @message = ('Deleted ' . $self->branch_path . '.' . "\n");
905
906  # Create a temporary file for the commit log message
907  my $ci_mesg = Fcm::CmCommitMessage->new ();
908  $ci_mesg->auto_mesg (@message);
909  $ci_mesg->ignore_mesg ('D' . ' ' x 4 . $self->url . "\n");
910  my $logfile = $ci_mesg->edit_file (TEMP => 1, BATCH => $non_interactive);
911
912  # Check with the user to see if he/she wants to go ahead
913  # ----------------------------------------------------------------------------
914  if (not $non_interactive) {
915    my $reply = &main::get_input (
916      TITLE   => 'fcm branch',
917      MESSAGE => 'Would you like to go ahead and delete this branch?',
918      TYPE    => 'yn',
919      DEFAULT => 'n',
920    );
921
922    return unless $reply eq 'y';
923  }
924
925  # Delete branch if answer is "y" for "yes"
926  # ----------------------------------------------------------------------------
927  print 'Deleting branch ', $self->url, ' ...', "\n";
928  my @command = (
929    qw/svn delete/,
930    '-F', $logfile,
931    (defined $password    ? ('--password', $password) : ()),
932    ($svn_non_interactive ? '--non-interactive'       : ()),
933
934    $self->url,
935  );
936  &run_command (\@command);
937
938  return;
939}
940
941# ------------------------------------------------------------------------------
942# SYNOPSIS
943#   $cm_branch->display_info (
944#     [SHOW_CHILDREN => 1],
945#     [SHOW_OTHER    => 1]
946#     [SHOW_SIBLINGS => 1]
947#   );
948#
949# DESCRIPTION
950#   This method displays information of the current branch. If SHOW_CHILDREN is
951#   set, it shows information of all current children branches of the current
952#   branch. If SHOW_SIBLINGS is set, it shows information of siblings that have
953#   been merged recently with the current branch. If SHOW_OTHER is set, it shows
954#   information of custom/reverse merges.
955# ------------------------------------------------------------------------------
956
957sub display_info {
958  my $self = shift;
959  my %args = @_;
960
961  # Arguments
962  # ----------------------------------------------------------------------------
963  my $show_children = exists $args{SHOW_CHILDREN} ? $args{SHOW_CHILDREN} : 0;
964  my $show_other    = exists $args{SHOW_OTHER   } ? $args{SHOW_OTHER}    : 0;
965  my $show_siblings = exists $args{SHOW_SIBLINGS} ? $args{SHOW_SIBLINGS} : 0;
966
967  # Useful variables
968  # ----------------------------------------------------------------------------
969  my $separator  = '-' x 80 . "\n";
970  my $separator2 = '  ' . '-' x 78 . "\n";
971
972  # Print "info" as returned by "svn info"
973  # ----------------------------------------------------------------------------
974  for my $key ('URL', 'Repository Root', 'Revision', 'Last Changed Author',
975               'Last Changed Rev', 'Last Changed Date') {
976    print $key, ': ', $self->svninfo (FLAG => $key), "\n"
977      if $self->svninfo (FLAG => $key);
978  }
979
980  if ($self->config->verbose) {
981    # Verbose mode, print log message at last changed revision
982    my %log = $self->svnlog (REV => $self->svninfo (FLAG => 'Last Changed Rev'));
983    my @log = split /\n/, $log{msg};
984    print 'Last Changed Log:', "\n\n", map ({'  ' . $_ . "\n"} @log), "\n";
985  }
986
987  if ($self->is_branch) {
988    # Print create information
989    # --------------------------------------------------------------------------
990    my %log = $self->svnlog (REV => $self->create_rev);
991
992    print $separator;
993    print 'Branch Create Author: ', $log{author}, "\n" if $log{author};
994    print 'Branch Create Rev: ', $self->create_rev, "\n";
995    print 'Branch Create Date: ', &svn_date ($log{date}), "\n";
996
997    if ($self->config->verbose) {
998      # Verbose mode, print log message at last create revision
999      my @log = split /\n/, $log{msg};
1000      print 'Branch Create Log:', "\n\n", map ({'  ' . $_ . "\n"} @log), "\n";
1001    }
1002
1003    # Print delete information if branch no longer exists
1004    # --------------------------------------------------------------------------
1005    print 'Branch Delete Rev: ', $self->delete_rev, "\n" if $self->delete_rev;
1006
1007    # Report merges into/from the parent
1008    # --------------------------------------------------------------------------
1009    # Print the URL@REV of the parent branch
1010    print $separator, 'Branch Parent: ', $self->parent->url_peg, "\n";
1011
1012    # Set up a new object for the parent at the current revision
1013    # --------------------------------------------------------------------------
1014    my $p_url  = $self->parent->url;
1015    $p_url    .= '@' . $self->pegrev if $self->pegrev;
1016    my $parent = Fcm::CmBranch->new (URL => $p_url);
1017
1018    if (not $parent->url_exists) {
1019      print 'Branch parent deleted.', "\n";
1020      return;
1021    }
1022
1023    # Report merges into/from the parent
1024    # --------------------------------------------------------------------------
1025    print $self->_report_merges ($parent, 'Parent');
1026  }
1027
1028  # Report merges with siblings
1029  # ----------------------------------------------------------------------------
1030  if ($show_siblings) {
1031    # Report number of sibling branches found
1032    print $separator, 'Seaching for siblings ... ';
1033    my @siblings = $self->siblings;
1034    print scalar (@siblings), ' ', (@siblings> 1 ? 'siblings' : 'sibling'),
1035          ' found.', "\n";
1036
1037    # Report branch name and merge information only if there are recent merges
1038    my $out = '';
1039    for my $sibling (@siblings) {
1040      my $string = $self->_report_merges ($sibling, 'Sibling');
1041
1042      $out .= $separator2 . '  ' . $sibling->url . "\n" . $string if $string;
1043    }
1044
1045    if (@siblings) {
1046      if ($out) {
1047        print 'Merges with existing siblings:', "\n", $out;
1048
1049      } else {
1050        print 'No merges with existing siblings.', "\n";
1051      }
1052    }
1053  }
1054
1055  # Report children
1056  # ----------------------------------------------------------------------------
1057  if ($show_children) {
1058    # Report number of child branches found
1059    print $separator, 'Seaching for children ... ';
1060    my @children = $self->children;
1061    print scalar (@children), ' ', (@children > 1 ? 'children' : 'child'),
1062          ' found.', "\n";
1063
1064    # Report children if they exist
1065    print 'Current children:', "\n" if @children;
1066
1067    for my $child (@children) {
1068      print $separator2, '  ', $child->url, "\n";
1069      print '  Child Create Rev: ', $child->create_rev, "\n";
1070      print $self->_report_merges ($child, 'Child');
1071    }
1072  }
1073
1074  # Report custom/reverse merges into the branch
1075  # ----------------------------------------------------------------------------
1076  if ($show_other) {
1077    my %log = $self->svnlog (STOP_ON_COPY => 1);
1078    my @out;
1079
1080    # Go down the revision log, checking for merge template messages
1081    REV: for my $rev (sort {$b <=> $a} keys %log) {
1082      # Loop each line of the log message at each revision
1083      my @msg = split /\n/, $log{$rev}{msg};
1084
1085      for (@msg) {
1086        # Ignore unless log message matches a merge template
1087        if (/^Reversed r\d+(:\d+)? of \S+$/ or
1088            s/^(Custom merge) into \S+(:.+)$/$1$2/) {
1089          push @out, ('r' . $rev . ': ' . $_) . "\n";
1090        }
1091      }
1092    }
1093
1094    print $separator, 'Other merges:', "\n", @out if @out;
1095  }
1096
1097  return;
1098}
1099
1100# ------------------------------------------------------------------------------
1101# SYNOPSIS
1102#   $string = $self->_report_merges ($branch, $relation);
1103#
1104# DESCRIPTION
1105#   This method returns a string for displaying merge information with a
1106#   branch, the $relation of which can be a Parent, a Sibling or a Child.
1107# ------------------------------------------------------------------------------
1108
1109sub _report_merges {
1110  my ($self, $branch, $relation) = @_;
1111
1112  my $indent    = ($relation eq 'Parent') ? '' : '  ';
1113  my $separator = ($relation eq 'Parent') ? ('-' x 80) : ('  ' . '-' x 78);
1114  $separator   .= "\n";
1115
1116  my $return = '';
1117
1118  # Report last merges into/from the $branch
1119  # ----------------------------------------------------------------------------
1120  my %merge  = (
1121    'Last Merge From ' . $relation . ':'
1122    => [$self->last_merge_from ($branch, 1)],
1123    'Last Merge Into ' . $relation . ':'
1124    => [$branch->last_merge_from ($self, 1)],
1125  );
1126
1127  if ($self->config->verbose) {
1128    # Verbose mode, print the log of the merge
1129    for my $key (keys %merge) {
1130      next if not @{ $merge{$key} };
1131
1132      # From: target (0) is self, upper delta (1) is $branch
1133      # Into: target (0) is $branch, upper delta (1) is self
1134      my $t = ($key =~ /From/) ? $self : $branch;
1135
1136      $return .= $indent . $key . "\n";
1137      $return .= $separator . $t->display_svnlog ($merge{$key}[0]->pegrev);
1138    }
1139
1140  } else {
1141    # Normal mode, print in simplified form (rREV Parent@REV)
1142    for my $key (keys %merge) {
1143      next if not @{ $merge{$key} };
1144
1145      # From: target (0) is self, upper delta (1) is $branch
1146      # Into: target (0) is $branch, upper delta (1) is self
1147      $return .= $indent . $key . ' r' . $merge{$key}[0]->pegrev . ' ' .
1148                 $merge{$key}[1]->path_peg . ' cf. ' .
1149                 $merge{$key}[2]->path_peg . "\n";
1150    }
1151  }
1152
1153  if ($relation eq 'Sibling') {
1154    # For sibling, do not report further if there is no recent merge
1155    my @values = values %merge;
1156
1157    return $return unless (@{ $values[0] } or @{ $values[1] });
1158  }
1159
1160  # Report available merges into/from the $branch
1161  # ----------------------------------------------------------------------------
1162  my %avail = (
1163    'Merges Avail From ' . $relation . ':'
1164    => ($self->delete_rev ? [] : [$self->avail_merge_from ($branch, 1)]),
1165    'Merges Avail Into ' . $relation . ':'
1166    => [$branch->avail_merge_from ($self, 1)],
1167  );
1168
1169  if ($self->config->verbose) {
1170    # Verbose mode, print the log of each revision
1171    for my $key (keys %avail) {
1172      next unless @{ $avail{$key} };
1173
1174      $return .= $indent . $key . "\n";
1175
1176      my $s = ($key =~ /From/) ? $branch: $self;
1177
1178      for my $rev (@{ $avail{$key} }) {
1179        $return .= $separator . $s->display_svnlog ($rev);
1180      }
1181    }
1182
1183  } else {
1184    # Normal mode, print only the revisions
1185    for my $key (keys %avail) {
1186      next unless @{ $avail{$key} };
1187
1188      $return .= $indent . $key . ' ' . join (' ', @{ $avail{$key} }) . "\n";
1189    }
1190  }
1191
1192  return $return;
1193}
1194
1195# ------------------------------------------------------------------------------
1196
11971;
1198
1199__END__
Note: See TracBrowser for help on using the repository browser.