source: codes/icosagcm/trunk/tools/FCM/lib/Fcm/Cm.pm @ 10

Last change on this file since 10 was 10, checked in by ymipsl, 12 years ago

dynamico tree creation

YM
File size: 68.3 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   Fcm::Cm
5#
6# DESCRIPTION
7#   This module contains the FCM code management functionalities and wrappers
8#   to Subversion commands.
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::Cm;
17
18# Standard pragma
19use warnings;
20use strict;
21
22# Standard modules
23our (@ISA, @EXPORT, @EXPORT_OK);
24use Getopt::Long;
25use File::Basename;
26use File::Path;
27use File::Spec;
28use File::Temp qw/tempfile/;
29use Cwd;
30
31# FCM component modules
32use Fcm::CmBranch;
33use Fcm::CmUrl;
34use Fcm::Util;
35
36sub cm_command;
37
38require Exporter;
39@ISA = qw(Exporter);
40@EXPORT = qw(
41  cm_command
42);
43
44# Function declaration:
45sub cm_add;
46sub cm_branch;
47sub cm_commit;
48sub cm_conflicts;
49sub cm_delete;
50sub cm_diff;
51sub cm_merge;
52sub cm_mkpatch;
53sub cm_svn;
54sub cm_switch;
55sub _construct_branch_url;
56
57# ------------------------------------------------------------------------------
58
59my @subcommand_url = qw/
60  branch    br
61  blame     praise annotate ann
62  cat
63  checkout  co
64  copy      cp
65  delete    del    remove   rm
66  diff      di
67  export
68  import
69  info
70  list      ls
71  lock
72  log
73  merge
74  mkdir
75  mkpatch
76  move      mv     rename   ren
77  propdel   pdel   pd
78  propedit  pedit  pe
79  propget   pget   pg
80  proplist  plist  pl
81  propset   pset   ps
82  switch    sw
83  unlock
84/; # List of subcommands that accept URL inputs
85
86my @subcommand_rev = qw/
87  blame     praise annotate ann
88  branch    br
89  cat
90  checkout  co
91  copy      cp
92  diff      di
93  export
94  info
95  list      ls
96  log
97  merge
98  mkpatch
99  move      mv     rename   ren
100  propdel   pdel   pd
101  propedit  pedit  pe
102  propget   pget   pg
103  proplist  plist  pl
104  propset   pset   ps
105  update    up
106/; # List of subcommands that accept revision inputs
107
108# ------------------------------------------------------------------------------
109# SYNOPSIS
110#   &cm_command ($function);
111#
112# DESCRIPTION
113#   This is the generic FCM code management wrapper. It calls the correct FCM
114#   code management function or a wrapper to a Subversion command based on the
115#   value of the argument $function.
116# ------------------------------------------------------------------------------
117
118sub cm_command {
119
120  my ($function) = shift @_;
121
122  # Expand URL keywords if necessary
123  if (grep {$_ eq $function} @subcommand_url) {
124    for my $arg (@ARGV) {
125      my $var = expand_url_keyword (URL => $arg);
126      $arg = $var if $arg ne $var;
127    }
128  }
129
130  # Expand revision keywords (for -r or --revision options) if necessary
131  if (grep {$_ eq $function} @subcommand_rev) {
132    my @new_argv = ();
133
134    while (defined (my $arg = shift @ARGV)) {
135      if ($arg eq '--revision') {
136        # Long --revision option, must be followed by a space before the
137        # revision argument
138        push @new_argv, $arg;
139
140      } elsif ($arg =~ s/^-r//) {
141        # Short -r option, may be followed by the revision argument with or
142        # without a space in between
143        push @new_argv, '--revision';
144        unshift @ARGV, $arg if $arg;
145
146      } else {
147        # Other option or argument
148        push @new_argv, $arg;
149        next;
150      }
151
152      # First revision number/keyword
153      my $rev1 = '';
154
155      # Get the next argument from the list
156      $arg = shift @ARGV;
157
158      if (index ($arg, '{') == 0) {
159        # A revision date argument may contain a space. Therefore, it may need
160        # the next argument(s) from the list
161        while (index ($arg, '}') == -1) {
162          my $shift = shift @ARGV;
163          last unless $shift;
164          $arg     .= ' ' . $shift;
165        }
166
167        $arg  =~ s/^(\{.+?\})//;
168        $rev1 = $1;
169
170      } else {
171        # Other revision argument
172        $arg  =~ s/^(\S+?)(?::|$)//;
173        $rev1 = $1;
174      }
175
176      # The rest of $arg is the second revision number/keyword
177      my $rev2 = $arg;
178      $rev2 =~ s/^:*//;
179
180      # A revision date argument may contain a space. Therefore, it may need
181      # the next argument(s) from the list
182      if (index ($rev2, '{') == 0) {
183        while (index ($rev2, '}') == -1) {
184          my $shift = shift @ARGV;
185          last unless $shift;
186          $rev2    .= ' ' . $shift;
187        }
188      }
189
190      # Expand revision keyword if necessary
191      if ($rev1 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i or
192          $rev2 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i) {
193        # Find out the associated URLs by inspecting the argument list
194        my $url1 = '';
195        my $url2 = '';
196
197        for (@new_argv, @ARGV) {
198          my $arg = Fcm::CmUrl->new (URL => $_);
199          next unless $arg->is_url;
200
201          if ($url1) {
202            $url2 = $arg->url_peg;
203            last;
204
205          } else {
206            $url1 = $arg->url_peg;
207          }
208        }
209
210        # Argument list does not contain a URL, try "svn info" on WC
211        $url1 = &get_url_of_wc () if not $url1;
212        $url2 = $url1 if not $url2;
213
214        # Expand 1st revision keyword if necessary
215        $rev1 = expand_rev_keyword (REV => $rev1, URL => $url1)
216          if $rev1 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i;
217
218        # Expand 2nd revision keyword if necessary
219        $rev2 = expand_rev_keyword (REV => $rev2, URL => $url2)
220          if $rev2 and $rev2 !~ /^(?:\d+|HEAD|BASE|COMMITTED|PREV|\{.+\})$/i;
221      }
222
223      # Append revision argument to argument list
224      push @new_argv, ($rev2 ? $rev1 . ':' . $rev2 : $rev1);
225    }
226
227    @ARGV = @new_argv;
228  }
229
230  # Expand revision keywords (for peg revision TARGET@REVSION) if necessary
231  for (@ARGV) {
232    if (m#^(\w+://\S+)@(\S+)$#) {
233      my $url = $1;
234      my $rev = $2;
235
236      my $new_rev = expand_rev_keyword (URL => $url, REV => $rev, HEAD => 1);
237
238      $_ = $url . '@' . $new_rev if $new_rev ne $rev;
239    }
240  }
241
242  # List of special sub-commands recognised by FCM
243  my %subcommand = (
244    ADD       => [qw/add/],
245    BRANCH    => [qw/branch br/],
246    COMMIT    => [qw/commit ci/],
247    CONFLICTS => [qw/conflicts cf/],
248    CHECKOUT  => [qw/checkout co/],
249    DELETE    => [qw/delete del remove rm/],
250    DIFF      => [qw/diff di/],
251    MERGE     => [qw/merge/],
252    MKPATCH   => [qw/mkpatch/],
253    SWITCH    => [qw/switch sw/],
254  );
255
256  if (grep {$_ eq $function} @{ $subcommand{ADD} }) {
257    cm_add;
258
259  } elsif (grep {$_ eq $function} @{ $subcommand{BRANCH} }) {
260    cm_branch;
261
262  } elsif (grep {$_ eq $function} @{ $subcommand{CHECKOUT} }) {
263    # Check whether the last argument is a PATH.
264    # If so, check whether it is a working copy.
265    # Otherwise, check whether the current directory is a working copy.
266    # If current working direcory (or PATH) is a working copy, fail the command.
267    if (@ARGV) {
268      my $arg  = Fcm::CmUrl->new (URL => $ARGV [-1]);
269      my $path = $arg->is_url ? cwd () : $ARGV [-1];
270
271      e_report $path, ': already a working copy, abort checkout.'
272        if &is_wc ($path);
273    }
274
275    # Invoke checkout
276    cm_svn ('checkout');
277
278  } elsif (grep {$_ eq $function} @{ $subcommand{COMMIT} }) {
279    cm_commit;
280
281  } elsif (grep {$_ eq $function} @{ $subcommand{CONFLICTS} }) {
282    cm_conflicts;
283
284  } elsif (grep {$_ eq $function} @{ $subcommand{DELETE} }) {
285    cm_delete;
286
287  } elsif (grep {$_ eq $function} @{ $subcommand{DIFF} }) {
288    cm_diff;
289
290  } elsif (grep {$_ eq $function} @{ $subcommand{MERGE} }) {
291    cm_merge;
292
293  } elsif (grep {$_ eq $function} @{ $subcommand{MKPATCH} }) {
294    cm_mkpatch;
295
296  } elsif (grep {$_ eq $function} @{ $subcommand{SWITCH} }) {
297    cm_switch;
298
299  } else {
300    cm_svn ($function);
301  }
302
303}
304
305# ------------------------------------------------------------------------------
306# SYNOPSIS
307#   &Fcm::Cm::cm_add ();
308#
309# DESCRIPTION
310#   This is a wrapper to "svn add". It adds an extra functionality to check
311#   for any files or directories reported by "svn status" as not under version
312#   control, and to prompt the user whether these files or directories should
313#   be added.
314# ------------------------------------------------------------------------------
315
316sub cm_add {
317
318  # Print usage message if requested
319  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
320    print <<EOF;
321usage: fcm add [options] [args]
322
323Valid options:
324  -c [--check]  : Check for any files or directories reported by svn status as
325                  not under version control and add them.
326  <SVN options> : Standard options to svn add as described below ...
327
328EOF
329
330    &run_command ([qw/svn add --help/], PRINT => 1, METHOD => 'exec');
331  }
332
333  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--check -c)) {
334    # The --check option is specified, add any new files
335    # Execute "svn status", print lines starting with a "?"
336    my $pat    = '^\?.{4}\s*';
337    my @status = grep /$pat.*/, &run_command ([qw/svn status/], METHOD => 'qx');
338    print @status if @status;
339
340    # Get list of "?" files
341    my @files  = map {chomp; s/$pat//; $_} @status;
342    my $reply  = '';
343
344    # Execute "add" command depending on user reply
345    for my $file (@files) {
346      # Get a user reply, unless previous reply is "a" for "all"
347      $reply = &main::get_input (
348        TITLE   => 'fcm add',
349        MESSAGE => "Add file '$file'?",
350        TYPE    => 'yna',
351        DEFAULT => 'n',
352      ) unless $reply eq "a";
353
354      # Add current $file if reply is "y" for "yes" or "a" for "all"
355      &run_command ([qw/svn add/, $file]) if $reply =~ /^[ya]$/;
356    }
357
358  } else {
359    # The --check option is not specified, just call "svn add"
360    cm_svn ("add");
361  }
362}
363
364# ------------------------------------------------------------------------------
365# SYNOPSIS
366#   &Fcm::Cm::cm_branch ();
367#
368# DESCRIPTION
369#   This is a FCM command to check information, create or delete a branch in
370#   a Subversion repository.
371# ------------------------------------------------------------------------------
372
373sub cm_branch {
374  my $usage = <<EOF;
375branch: Create, delete or display information of a branch
376usage: 1. fcm branch [--info] [OPTIONS] [TARGET]
377       2. fcm branch --delete [OPTIONS] [TARGET]
378       3. fcm branch --create [OPTIONS] [SOURCE]
379       4. fcm branch --list   [OPTIONS] [SOURCE]
380
381  1. Display information about a branch. This is the default option if --create,
382     --delete and --list are not specified.
383
384  2. Delete a branch.
385
386  3. Create a new branch from SOURCE. The --name option must be used to specify
387     a short name for the new branch.
388
389  4. List all the branches owned by the current user in SOURCE. If the --user
390     option is specified with a list of users, list all the branches owned by
391     these users instead of the current user.
392
393  TARGET (and SOURCE) can be an URL or a Subversion working copy. Otherwise,
394  the current working directory must be a working copy. For --info and
395  --delete, the specified URL (or the URL of the working copy) must be a URL
396  under a valid branch in a standard FCM project. For --create and --list, it
397  must be a URL under a standard FCM project.
398
399Valid options with --info and --delete:
400  -v [--verbose]        : Print extra information.
401  -a [--show-all]       : Set --show-children, --show-other and --show-siblings.
402  --show-children       : Report children of the current branch.
403  --show-other          : Report custom/ reverse merges into the current branch.
404  --show-siblings       : Report merges with siblings of the current branch.
405
406Valid options with --delete and --create:
407  --non-interactive     : Do no interactive prompting. This option implies
408                          --svn-non-interactive.
409  --password arg        : Specify a password for write access to the repository.
410  --svn-non-interactive : Do no interactive prompting at commit time. This
411                          option is implied by --non-interactive.
412
413Valid options with --create and --list:
414  -r [--revision] arg   : Specify the operative revision of the SOURCE for
415                          creating the branch.
416
417Valid options with --create:
418  --branch-of-branch    : If this option is specified and the SOURCE is a
419                          branch, it will create a new branch from the SOURCE
420                          branch. Otherwise, the branch is created from the
421                          trunk.
422  -k [--ticket] arg     : Specify one (or more) Trac ticket. If specified, the
423                          command will add to the commit log the line "Relates
424                          to ticket #<ticket>". Multiple tickets can be set by
425                          specifying this option multiple times, or by
426                          specifying the tickets in a comma-separated list.
427  -n [--name] arg       : Specify a short name for the branch, which should
428                          contain only word characters, i.e. [A-Za-z0-9_].
429  --rev-flag arg        : Specify a flag for determining the prefix of the
430                          branch name. The flag can be the the string "NORMAL",
431                          "NUMBER" or "NONE".  "NORMAL" is the default
432                          behaviour, in which the branch name will be prefixed
433                          with a Subversion revision number if the revision is
434                          not associated with a registered FCM revision
435                          keyword. If the revision is registered with a FCM
436                          revision keyword, the keyword will be used in place
437                          of the number. If "NUMBER" is specified, the branch
438                          name will always be prefixed with a Subversion
439                          revision number. If "NONE" is specified, the branch
440                          name will not be prefixed by a revision number or
441                          keyword.
442  -t [--type] arg       : Specify the type of the branch to be created. It must
443                          be one of the following:
444                            DEV::USER   - a development branch for the user
445                            DEV::SHARE  - a shared development branch
446                            DEV         - same as DEV::USER
447                            TEST::USER  - a test branch for the user
448                            TEST::SHARE - a shared test branch
449                            TEST        - same as TEST::USER
450                            PKG::USER   - a package branch for the user
451                            PKG::SHARE  - a shared package branch
452                            PKG::CONFIG - a configuration branch
453                            PKG::REL    - a release branch
454                            PKG         - same as PKG::USER
455                            CONFIG      - same as PKG::CONFIG
456                            REL         - same as PKG::REL
457                            SHARE       - same as DEV::SHARE
458                            USER        - same as DEV::USER
459                          If not specified, the default is to create a
460                          development branch for the current user, i.e.
461                          DEV::USER.
462
463Valid options with --list:
464  -u [--user] arg       : Specify a colon-separated list of users. List branches
465                          owned by these users instead of the current user.
466EOF
467
468  # Print usage message if requested
469  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
470    print $usage;
471    return 1;
472  }
473
474  # Process command line options
475  # ----------------------------------------------------------------------------
476  my (
477    $info,
478    $delete,
479    $create,
480    $list,
481    $branch_of_branch,
482    $name,
483    $non_interactive,
484    $password,
485    $rev,
486    $rev_flag,
487    $show_all,
488    $show_children,
489    $show_other,
490    $show_siblings,
491    $svn_non_interactive,
492    @tickets,
493    $type,
494    @userlist,
495    $verbose,
496  );
497  GetOptions (
498    'info|i'              => \$info,
499    'delete|d'            => \$delete,
500    'create|c'            => \$create,
501    'list|l'              => \$list,
502    'branch-of-branch'    => \$branch_of_branch,
503    'name|n=s'            => \$name,
504    'non-interactive'     => \$non_interactive,
505    'password=s'          => \$password,
506    'revision|r=s'        => \$rev,
507    'rev-flag=s'          => \$rev_flag,
508    'show-all|a'          => \$show_all,
509    'show-children'       => \$show_children,
510    'show-other'          => \$show_other,
511    'show-siblings'       => \$show_siblings,
512    'svn-non-interactive' => \$svn_non_interactive,
513    'ticket|k=s'          => \@tickets,
514    'type|t=s'            => \$type,
515    'user|u=s'            => \@userlist,
516    'verbose|v'           => \$verbose,
517  );
518
519  my $num_options = 0;
520  $num_options++ if defined $info;
521  $num_options++ if defined $delete;
522  $num_options++ if defined $create;
523  $num_options++ if defined $list;
524
525  # Report invalid usage
526  # ----------------------------------------------------------------------------
527  e_report $usage if $num_options > 1;
528
529  # Get URL of repository or branch
530  # ----------------------------------------------------------------------------
531  my $url;
532  if ($ARGV[0]) {
533    $url = Fcm::CmUrl->new (URL => $ARGV[0]);
534
535    if (not $url->is_url) {
536      # An argument is specified and is not a URL
537      # Assume that it is a path with a working copy
538      if (&is_wc ($ARGV[0])) {
539        $url = Fcm::CmUrl->new (URL => &get_url_of_wc ($ARGV[0]));
540
541      } else {
542        e_report $ARGV[0], ': is not a working copy, abort.';
543      }
544    }
545
546  } else {
547    # An argument is not specified
548    # Assume that the current directory is a working copy
549    if (&is_wc ()) {
550      $url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
551
552    } else {
553      e_report 'The current directory is not a working copy, please specify a ',
554               'URL or a path to a working copy, abort.';
555    }
556  }
557
558  # Ensure $url->url_peg is a URL of a standard FCM project
559  e_report $url->url_peg, ': not a URL of a standard FCM project, abort.'
560    if not $url->project_url;
561
562  if ($create) {
563    # The --create option is specified, create a branch
564    # --------------------------------------------------------------------------
565
566    # Check branch type flags
567    if ($type) {
568      $type = uc ($type);
569
570      if ($type =~ /^(USER|SHARE)$/) {
571        $type = 'DEV::' . $1;
572
573      } elsif ($type =~ /^(CONFIG|REL)$/) {
574        $type = 'PKG::' . $1;
575
576      } elsif ($type =~ /^(DEV|TEST|PKG)$/) {
577        $type = $1 . '::USER';
578
579      } elsif ($type !~ /^(?:DEV|TEST|PKG)::(?:USER|SHARE)$/ and
580               $type !~ /^PKG::(?:CONFIG|REL)/) {
581        e_report $type, ': is not a valid type flag, abort.';
582      }
583
584    } else {
585      $type = 'DEV::USER';
586    }
587
588    # Check branch name
589    e_report 'The option --name must be used to specify a branch name, abort.'
590      if not $name;
591
592    e_report $name, ': invalid characters in name, abort.' if $name !~ /^\w+$/;
593
594    # Check revision flag is valid
595    if ($rev_flag) {
596      $rev_flag = uc ($rev_flag);
597
598      e_report $rev_flag, ': invalid argument to the --rev-flag option, abort.'
599        if $rev_flag !~ /^(?:NORMAL|NUMBER|NONE)$/;
600
601    } else {
602      $rev_flag = 'NORMAL';
603    }
604
605    # Handle multiple tickets
606    @tickets = split (/,/, join (',', @tickets));
607    s/^#// for (@tickets);
608    @tickets = sort {$a <=> $b} @tickets;
609
610    # Determine whether to create a branch of a branch
611    $url->branch ('trunk') unless $branch_of_branch;
612
613    # Create the branch
614    my $branch = Fcm::CmBranch->new;
615    $branch->create (
616      SRC                 => $url,
617      TYPE                => $type,
618      NAME                => $name,
619      PASSWORD            => $password,
620      REV_FLAG            => $rev_flag,
621      TICKET              => \@tickets,
622      REV                 => $rev,
623      NON_INTERACTIVE     => $non_interactive,
624      SVN_NON_INTERACTIVE => $svn_non_interactive,
625    );
626
627  } elsif ($list) {
628    # The option --list is specified
629    # List branches owned by current or specified users
630    # --------------------------------------------------------------------------
631    # Get URL of the project "branches/" sub-directory
632    $url->subdir ('');
633    $url->branch ('');
634    my @list = map {$_, 1} $url->branch_list ($rev);
635
636    if (@userlist) {
637      # Sort list of users
638      @userlist = sort (split /:/, join (':', @userlist));
639
640    } else {
641      # No user specified, add currrent user to list
642      push @userlist, $ENV{LOGNAME} unless @userlist;
643    }
644
645    # Filter branches matching user list
646    my @branches;
647    for my $branch (@list) {
648      next unless $branch =~ m#/([^/]+)/[^/]+/*$#;
649
650      my $user = $1;
651
652      push @branches, $branch if grep {$user eq $_} @userlist;
653    }
654
655    # Output, number of branches found
656    print scalar (@branches), ' ',
657          (scalar (@branches) > 1 ? 'branches' : 'branch'), ' found for ',
658          join (', ', @userlist), ' in ', $url->project_url_peg,
659          ($rev ? (' at r', $rev) : ()), "\n";
660
661    if (@branches) {
662      # Output the URL of each branch
663      @branches = map {$_ . "\n"} sort @branches;
664      print @branches;
665
666    } else {
667      # No branch found, exit with an error code
668      exit 1;
669    }
670
671  } else {
672    # The option --info or --delete is specified
673    # Report branch information (and/or delete a branch)
674    # --------------------------------------------------------------------------
675    # Set verbose level
676    &main::cfg->verbose ($verbose ? 1 : 0);
677
678    # Set up the branch, report any error
679    my $branch = Fcm::CmBranch->new (URL => $url->url_peg);
680    e_report $branch->url_peg, ': not a branch, abort.' unless $branch->branch;
681
682    e_report $branch->url_peg, ': does not exist, abort.'
683      unless $branch->url_exists;
684
685    # Remove the sub-directory part of the URL
686    $branch->subdir ('');
687
688    # Report branch info
689    $branch->display_info (
690      SHOW_CHILDREN => ($show_all || $show_children),
691      SHOW_OTHER    => ($show_all || $show_other   ),
692      SHOW_SIBLINGS => ($show_all || $show_siblings),
693    );
694
695    # Delete branch if --delete is specified
696    $branch->del (
697      PASSWORD            => $password,
698      NON_INTERACTIVE     => $non_interactive,
699      SVN_NON_INTERACTIVE => $svn_non_interactive,
700    ) if $delete;
701  }
702
703}
704
705# ------------------------------------------------------------------------------
706# SYNOPSIS
707#   &Fcm::Cm::cm_commit ();
708#
709# DESCRIPTION
710#   This is a FCM wrapper to the "svn commit" command.
711# ------------------------------------------------------------------------------
712
713sub cm_commit {
714
715  # Print usage message if requested
716  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
717    print <<EOF;
718commit (ci): Send changes from your working copy to the repository.
719usage: fcm commit [PATH]
720
721  Invoke your favourite editor to prompt you for a commit log message. Send
722  changes from your working copy to the repository. Update your working copy
723  following the commit.
724
725Valid options:
726  --dry-run             : Allows you to add to the commit message without
727                          committing.
728  --svn-non-interactive : Do no interactive prompting at commit time.
729  --password arg        : Specify a password ARG.
730EOF
731    return 1;
732  }
733
734  my ($dry_run, $svn_non_interactive, $password);
735  GetOptions (
736    'dry-run'             => \$dry_run,
737    'svn-non-interactive' => \$svn_non_interactive,
738    'password'            => \$password,
739  );
740
741  # The remaining argument is the path to a working copy
742  my ($path) = @ARGV;
743
744  if ($path) {
745    # Check that specified path exists
746    e_report $path, ': does not exist, abort.' if not -e $path;
747
748  } else {
749    # No argument specified, use current working directory
750    $path = cwd ();
751  }
752
753  # Make sure we are in a working copy
754  e_report $path, ': not a working copy, abort.' if not &is_wc ($path);
755
756  # Make sure we are at the top level of the working copy
757  # (otherwise we might miss any template commit message)
758  my $dir = &get_wct ($path);
759
760  if ($dir ne cwd ()) {
761    chdir $dir or die 'Cannot change directory to: ', $dir;
762    print 'Committing changes from ', $dir, ' ...', "\n";
763  }
764
765  # Get update status of working copy
766  # Check working copy files are not in conflict, missing, or out of date
767  my @status = &run_command ([qw/svn status --show-updates/], METHOD => 'qx');
768  unless (defined $dry_run) {
769    my (@conflict, @missing, @outdate);
770
771    for (@status) {
772      if (/^C/) {
773        push @conflict, $_;
774        next;
775      }
776
777      if (/^!/) {
778        push @missing, $_;
779        next;
780      }
781
782      if (/^.{7}\*/) {
783        push @outdate, $_;
784        next;
785      }
786
787      # Check that all files which have been added have the svn:executable
788      # property set correctly (in case the developer adds a script before they
789      # remember to set the execute bit)
790      next unless /^A.{7} *\d+ +(.*)/;
791      my $file = $1;
792
793      next unless -f $file;
794      my @command = (-x $file)
795                    ? (qw/svn propset -q svn:executable */, $file)
796                    : (qw/svn propdel -q svn:executable/  , $file);
797      &run_command (\@command);
798    }
799
800    # Abort commit if files are in conflict, missing, or out of date
801    if (@conflict or @missing or @outdate) {
802      w_report 'File(s) in conflict:', "\n", @conflict if @conflict;
803      w_report 'File(s) missing:'    , "\n", @missing  if @missing;
804      w_report 'File(s) out of date:', "\n", @outdate  if @outdate;
805      e_report 'Abort commit.';
806    }
807  }
808
809  # Read in any existing message
810  my $ci_mesg = Fcm::CmCommitMessage->new ();
811  $ci_mesg->read_file;
812
813  # Execute "svn status" for a list of changed items
814  @status = grep !/^\?/, &run_command ([qw/svn status/], METHOD => 'qx');
815
816  # Abort if there is no change in the working copy
817  if (not @status) {
818    print 'No change in working copy, abort.', "\n";
819    return;
820  }
821
822  # Get associated URL of current working copy
823  my $url = Fcm::CmUrl->new (URL => &get_url_of_wc ());
824
825  # Include URL, or project, branch and sub-directory info in @status
826  unshift @status, "\n";
827
828  if ($url->project and $url->branch) {
829    unshift @status, (
830      '[Project: ' . $url->project                           . ']' . "\n",
831      '[Branch : ' . $url->branch                            . ']' . "\n",
832      '[Sub-dir: ' . ($url->subdir ? $url->subdir : '<top>') . ']' . "\n",
833    );
834
835  } else {
836    unshift @status, '[URL: ' . $url->url . ']' . "\n";
837  }
838
839  # Use a temporary file to store the final commit log message
840  $ci_mesg->ignore_mesg (@status);
841  my $logfile = $ci_mesg->edit_file (TEMP => 1);
842
843  # Check with the user to see if he/she wants to go ahead
844  my $reply = 'n';
845  if (not defined $dry_run) {
846    # Add extra warning for trunk commit
847    my $mesg = $url->is_trunk
848      ? "\n" .
849        '*** WARNING: YOU ARE COMMITTING TO THE TRUNK.' . "\n" .
850        '*** Please ensure that your change conforms to your project\'s ' .
851        'working practices.' . "\n\n"
852      : '';
853    $mesg   .= 'Would you like to commit this change?';
854
855    # Prompt the user
856    $reply = &main::get_input (
857      TITLE   => 'fcm commit',
858      MESSAGE => $mesg,
859      TYPE    => 'yn',
860      DEFAULT => 'n',
861    );
862  }
863
864  if ($reply eq 'y') {
865    # Commit the change if user replies "y" for "yes"
866    my @command = (
867      qw/svn commit -F/, $logfile,
868      ($svn_non_interactive  ? '--non-interactive'       : ()),
869      (defined $password     ? ('--password', $password) : ()),
870    );
871    my $rc;
872    &run_command (\@command, RC => \$rc, ERROR => 'warn');
873
874    if ($rc) {
875      # Commit failed
876      # Write temporary commit log content to commit log message file
877      $ci_mesg->write_file;
878
879      # Fail the command
880      e_report;
881    }
882
883    # Remove commit message file
884    unlink $ci_mesg->file;
885
886    # Update the working copy
887    print 'Performing update to make sure your working copy is at this new ',
888          'revision ...', "\n";
889    &run_command ([qw/svn update/]);
890
891  } else {
892    # Abort commit if dry run or user replies "n" for "no"
893    w_report 'Commit aborted by user.' unless $dry_run;
894
895    # Write temporary commit log content to commit log message file
896    $ci_mesg->write_file;
897  }
898
899  return;
900}
901
902# ------------------------------------------------------------------------------
903# SYNOPSIS
904#   &Fcm::Cm::cm_conflicts ();
905#
906# DESCRIPTION
907#   This is a FCM command for resolving conflicts within working copy using a
908#   graphical merge tool.
909# ------------------------------------------------------------------------------
910
911sub cm_conflicts {
912
913  # Print usage message if requested
914  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
915    print <<EOF;
916conflicts: Use graphical tool to resolve any conflicts within your working copy.
917usage: fcm conflicts [PATH]
918
919  Invoke the xxdiff graphical merge tool to help you resolve conflicts in your
920  working copy. It prompts you to run "svn resolved" each time you have
921  resolved the conflicts in a file.
922EOF
923    return 1;
924  }
925
926  # Path to the working copy
927  my $path = $ARGV[0];
928  $path    = cwd () if not $path;
929
930  # Check for any files with conflicts
931  my @status = grep /^C.{4} *(.*)/, &run_command (
932    [qw/svn st/, ($path eq cwd () ? () : $path)], METHOD => 'qx',
933  );
934  my @files  = map {m/^C.{4} *(.*)/; $1} @status;
935
936  # Save current working directory
937  my $topdir = cwd ();
938
939  for my $file (@files) {
940    # Print name of file in conflicts
941    print "Conflicts in file: $file\n";
942
943    # Determine directory and base name of file in conflicts
944    my $base = basename $file;
945    my $dir  = dirname $file;
946
947    # Change to container directory of file in conflicts
948    chdir File::Spec->catfile ($topdir, $dir) or die "Directory change to $dir failed";
949
950    # Use "svn info" to determine conflict marker files
951    my @info = &run_command ([qw/svn info/, $base], METHOD => 'qx');
952
953    # Ignore if $base is a binary file
954    if (-B $base) {
955      w_report $base,
956               ': ignoring binary file, please resolve conflicts manually.';
957      next;
958    }
959
960    # Get conflicts markers files
961    my ($older, $mine, $yours);
962
963    for (@info) {
964      $older = $1 if (/^Conflict Previous Base File: (.*)/);
965      $mine  = $1 if (/^Conflict Previous Working File: (.*)/);
966      $yours = $1 if (/^Conflict Current Base File: (.*)/);
967    }
968
969    if ((stat $base)[9] > (stat $mine)[9]) {
970      # If $base is newer, it may contain saved changes
971      my $reply = &main::get_input (
972        TITLE   => 'fcm conflicts',
973        MESSAGE => 'Existing changes in ' . $base . ' will be overwritten.' .
974                   "\n" . 'Do you wish to continue?',
975        TYPE    => 'yn',
976        DEFAULT => 'n',
977      );
978
979      next if $reply ne 'y';
980    }
981
982    # Launch "xxdiff" to allow user to perform graphical merging
983    my $xxdiffrc;
984    my @command  = (qw/xxdiff -m -M/, $base, qw/-O -X/, $mine, $older, $yours);
985    my ($decision) = &run_command (
986      \@command, METHOD => 'qx', RC => \$xxdiffrc, ERROR => 'ignore',
987    );
988    die &get_command_string (\@command), ' failed' if $xxdiffrc and ! $decision;
989    chomp $decision;
990
991    # Perform different actions depending on the user's decision
992    if ($decision eq "NODECISION") {
993      print "No decision taken\n";
994
995    } elsif ($decision eq "MERGED" and $xxdiffrc != 0) {
996      print "Merge conflicts were not all resolved\n";
997
998    } else {
999      # User has MERGED, ACCEPTED or REJECTED all changes
1000      if ($decision eq "MERGED") {
1001        print "All merge conflicts resolved\n";
1002
1003      } else {
1004        print "You have chosen to $decision all the changes\n";
1005      }
1006
1007      # Prompt user to run "svn resolved" on the file
1008      my $reply = &main::get_input (
1009        TITLE   => 'fcm conflicts',
1010        MESSAGE => 'Would you like to run "svn resolved"?',
1011        TYPE    => 'yn',
1012        DEFAULT => 'n',
1013      );
1014
1015      # If reply is "yes"...
1016      &run_command ([qw/svn resolved/, $base]) if $reply eq 'y';
1017    }
1018  }
1019}
1020
1021# ------------------------------------------------------------------------------
1022# SYNOPSIS
1023#   &Fcm::Cm::cm_delete ();
1024#
1025# DESCRIPTION
1026#   This is a wrapper to "svn delete". It adds an extra functionality to check
1027#   for any files or directories reported by "svn status" as missing, and to
1028#   prompt the user whether these files or directories should be deleted.
1029# ------------------------------------------------------------------------------
1030
1031sub cm_delete {
1032
1033  # Print usage message if requested
1034  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1035    print <<EOF;
1036usage: fcm delete [options] [args]
1037
1038Valid options:
1039  -c [--check]  : Check for any files or directories reported by svn status as
1040                  missing and delete them.
1041  <SVN options> : Standard options to svn delete as described below ...
1042
1043EOF
1044
1045    &run_command ([qw/svn delete --help/], PRINT => 1, METHOD => 'exec');
1046  }
1047
1048  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--check -c)) {
1049    # The --check option is specified, delete any missing files
1050    # Execute "svn status", print lines starting with a "!"
1051    my $pat    = '^!.{4}\s*';
1052    my @status = grep /$pat.*/, &run_command ([qw/svn status/], METHOD => 'qx');
1053    print @status if @status;
1054
1055    # Get list of "!" files
1056    my @files  = map {chomp; s/$pat//; $_} @status;
1057    my $reply  = '';
1058
1059    # Execute "delete" command depending on user reply
1060    for my $file (@files) {
1061      # Get a user reply, unless previous reply is "a" for "all"
1062      $reply = &main::get_input (
1063        TITLE   => 'fcm delete',
1064        MESSAGE => "Delete file '$file'?",
1065        TYPE    => 'yna',
1066        DEFAULT => 'n',
1067      ) unless $reply eq "a";
1068
1069      # Delete current $file if reply is "y" for "yes" or "a" for "all"
1070      &run_command ([qw/svn delete/, $file]) if $reply =~ /^[ya]$/;
1071    }
1072
1073  } else {
1074    # The --check option is not specified, just call "svn delete"
1075    cm_svn ("delete");
1076  }
1077}
1078
1079# ------------------------------------------------------------------------------
1080# SYNOPSIS
1081#   &Fcm::Cm::cm_diff ();
1082#
1083# DESCRIPTION
1084#   This is a wrapper to "svn diff". It adds two extra functionalities. The
1085#   first one allows the command to show differences relative to the base of
1086#   the branch. The second one allows differences to be displayed via a
1087#   graphical tool.
1088# ------------------------------------------------------------------------------
1089
1090sub cm_diff {
1091
1092  # Print usage message if requested
1093  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1094    print <<EOF;
1095usage: fcm diff [options] [args]
1096
1097Valid options:
1098  -g [--graphical]    : Use xxdiff to display the differences.
1099  -b [--branch] [URL] : Show differences relative to the base of the branch.
1100  <SVN options>       : Standard options to svn diff as described below ...
1101
1102EOF
1103
1104    &run_command ([qw/svn diff --help/], PRINT => 1, METHOD => 'exec');
1105  }
1106
1107  # Check for the --branch options
1108  # ----------------------------------------------------------------------------
1109  my $branch = grep {$_ eq '-b' or $_ eq '--branch'} @ARGV;
1110
1111  if (not $branch) {
1112    # The --branch option not specified, just call "svn diff"
1113    # Convert the --graphical to qw/--diff-cmd fcm_xxdiff_wrapper/
1114    @ARGV = map {
1115      ($_ eq '-g' or $_ eq '--graphical')
1116      ? (qw/--diff-cmd fcm_xxdiff_wrapper/)
1117      : $_
1118    } @ARGV;
1119
1120    # Execute the command
1121    cm_svn ('diff');
1122  }
1123
1124  # The --branch option is specified
1125  # ----------------------------------------------------------------------------
1126
1127  # Determine whether the --graphical option is specified,
1128  # if so set the appropriate command
1129  # ----------------------------------------------------------------------------
1130  my $graphical;
1131  GetOptions ('b|branch' => \$branch, 'g|graphical' => \$graphical);
1132
1133  my @diff_cmd = $graphical ? (qw/--diff-cmd fcm_xxdiff_wrapper/) : ();
1134
1135  # The remaining argument should either be a URL or a PATH
1136  my ($url_arg, $path);
1137
1138  if (@ARGV) {
1139    my $arg = Fcm::CmUrl->new (URL => $ARGV[0]);
1140
1141    if ($arg->is_url) {
1142      $url_arg = $ARGV[0];
1143
1144    } else {
1145      $path = $ARGV[0];
1146    }
1147  }
1148
1149  # Get repository and branch information
1150  # ----------------------------------------------------------------------------
1151  my $url;
1152  if (defined $url_arg) {
1153    # If a URL is specified, get repository and branch information from it
1154    $url = Fcm::CmBranch->new (URL => $url_arg);
1155
1156  } else {
1157    # Get repository and branch information from the specified path or the
1158    # current directory if it is a working copy
1159    $path = cwd () if not $path;
1160    $url  = Fcm::CmBranch->new (URL => &get_url_of_wc ($path));
1161  }
1162
1163  # Check that URL is a standard FCM branch
1164  e_report $url->url_peg, ': not a standard FCM branch, abort.'
1165    unless $url->is_branch;
1166
1167  # Save and remove sub-directory part of the URL
1168  my $subdir = $url->subdir ();
1169  $url->subdir ('');
1170
1171  # Check that $url exists
1172  e_report $url->url_peg, ': not a valid URL, abort.' unless $url->url_exists;
1173
1174  # Compare current branch with its parent
1175  # ----------------------------------------------------------------------------
1176  my $parent = Fcm::CmBranch->new (URL => $url->parent->url);
1177  $parent->pegrev ($url->pegrev) if $url->pegrev;
1178
1179  e_report $parent->url, ': branch parent no longer exists',
1180           ($parent->pegrev ? ' at ' . $parent->pegrev : ''), ', abort.'
1181    unless $parent->url_exists;
1182
1183  my $base = $parent->base_of_merge_from ($url);
1184
1185  # Execute the "diff" command
1186  # ----------------------------------------------------------------------------
1187  $url->subdir ($subdir);
1188  $base->subdir ($subdir);
1189  print 'Comparing against ', $base->path_peg, "\n";
1190  my @command = (
1191    qw/svn diff/, @diff_cmd,
1192    '--old', $base->url_peg,
1193    '--new', ($url_arg ? $url->url_peg : $path),
1194  );
1195  &run_command (\@command);
1196}
1197
1198# ------------------------------------------------------------------------------
1199# SYNOPSIS
1200#   &Fcm::Cm::cm_merge ();
1201#
1202# DESCRIPTION
1203#   This is a wrapper to "svn merge".
1204# ------------------------------------------------------------------------------
1205
1206sub cm_merge {
1207
1208  # Print usage message if requested
1209  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1210    print <<EOF;
1211merge: Merge changes from a source into your working copy.
1212usage: 1. fcm merge SOURCE
1213       2. fcm merge --custom  --revision N[:M] SOURCE
1214          fcm merge --custom  URL[\@REV1] URL[\@REV2]
1215       3. fcm merge --reverse --revision [M:]N
1216
1217  1. If neither --custom nor --reverse is specified, the command merges changes
1218     automatically from SOURCE into your working copy. SOURCE must be a valid
1219     URL[\@REV] of a branch in a standard FCM project. The base of the merge
1220     will be calculated automatically based on the common ancestor and latest
1221     merge information between the SOURCE and the branch of the working copy.
1222
1223  2. If --custom is specified, the command can be used in two forms.
1224 
1225     In the first form, it performs a custom merge from the specified
1226     changeset(s) of SOURCE into your working copy. SOURCE must be a valid
1227     URL[\@REV] of a branch in a standard FCM project. If a single revision is
1228     specified, the merge delta is (N - 1):N of SOURCE. Otherwise, the merge
1229     delta, is N:M of SOURCE, where N < M.
1230     
1231     In the second form, it performs a custom merge using the delta between the
1232     two specified branch URLs. For each URL, if a peg revision is not
1233     specified, the command will peg the URL with its last changed revision.
1234
1235  3. If --reverse is specified, the command performs a reverse merge of the
1236     changeset(s) specified by the --revision option. If a single revision is
1237     specified, the merge delta is N:(N - 1). Otherwise, the merge delta is
1238     M:N, where M > N. Note that you do not have to specify a SOURCE for a
1239     reverse merge, because the SOURCE should always be the branch your working
1240     copy is pointing to.
1241 
1242  The command provide a commit log message template following the merge.
1243
1244Valid options:
1245  --dry-run          : Try operation but make no changes.
1246  --non-interactive  : Do no interactive prompting.
1247  -r [--revision] arg: Specify a (range of) revision number(s).
1248  --verbose          : Print extra information.
1249EOF
1250    return 1;
1251  }
1252
1253  # Options
1254  # ----------------------------------------------------------------------------
1255  my ($custom, $dry_run, $non_interactive, $reverse, $rev, $verbose);
1256  GetOptions (
1257    'custom'          => \$custom,
1258    'dry-run'         => \$dry_run,
1259    'non-interactive' => \$non_interactive,
1260    'reverse'         => \$reverse,
1261    'revision|r=s'    => \$rev,
1262    'verbose|v'       => \$verbose,
1263  );
1264
1265  # Find out the URL of the working copy
1266  # ----------------------------------------------------------------------------
1267  my ($target, $wct);
1268  if (&is_wc ()) {
1269    $wct = &get_wct ();
1270
1271    if ($wct ne cwd ()) {
1272      print 'Change directory to top of working copy: ', $wct, "\n";
1273      chdir $wct or die 'Cannot change directory to: ', $wct;
1274    }
1275
1276    $target = Fcm::CmBranch->new (URL => &get_url_of_wc ($wct));
1277
1278  } else {
1279    e_report 'The current directory is not a working copy, abort.';
1280  }
1281
1282  e_report 'Your working copy URL does not exist at the HEAD revision, abort.'
1283    unless $target->url_exists;
1284
1285  # The target must be at the top of a branch
1286  # $subdir will be used later to determine whether the merge is allowed or not
1287  my $subdir = $target->subdir;
1288  $target->subdir ('') if $subdir;
1289
1290  # Check for any local modifications
1291  # ----------------------------------------------------------------------------
1292  return
1293    if ! ($dry_run or $non_interactive) and &_abort_modified_wc ('fcm merge');
1294
1295  # Determine the SOURCE URL
1296  # ----------------------------------------------------------------------------
1297  my $source;
1298
1299  if ($reverse) {
1300    # Reverse merge, the SOURCE is the the working copy URL
1301    $source = Fcm::CmBranch->new (URL => $target->url);
1302
1303  } else {
1304    # Automatic/custom merge, argument 1 is the SOURCE of the merge
1305    my $source_url = shift (@ARGV);
1306    e_report 'Error: argument 1 must be the URL/name of a source branch in ',
1307             'automatic/custom mode, abort.'
1308      if not $source_url;
1309
1310    $source = &_construct_branch_url ($source_url, $target);
1311  }
1312
1313  # Parse the revision option
1314  # ----------------------------------------------------------------------------
1315  my @revs;
1316  if ($reverse or $custom) {
1317    if ($reverse and not $rev) {
1318      e_report 'Error: a revision (range) must be specified with ',
1319               '--revision in reverse mode, abort.'
1320    }
1321
1322    @revs = split (/:/, $rev) if $rev;
1323  }
1324
1325  # Determine the merge delta and the commit log message
1326  # ----------------------------------------------------------------------------
1327  my (@delta, $mesg);
1328  my $separator = '-' x 80 . "\n";
1329
1330  if ($reverse) {
1331    # Reverse merge
1332    # --------------------------------------------------------------------------
1333    if (@revs == 1) {
1334      $revs[1] = ($revs[0] - 1);
1335
1336    } else {
1337      @revs = sort {$b <=> $a} @revs;
1338    }
1339
1340    $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
1341      unless $source->pegrev;
1342    $source->subdir ($subdir);
1343
1344    # "Delta" of the "svn merge" command
1345    @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
1346
1347    # Template message
1348    $mesg = 'Reversed r' . $revs[0] .
1349            (($revs[1] < $revs[0] - 1) ? ':' . $revs[1] : '') . ' of ' .
1350            $source->path . "\n";
1351
1352  } elsif ($custom) {
1353    # Custom merge
1354    # --------------------------------------------------------------------------
1355    if (@revs) {
1356      # Revision specified
1357      # ------------------------------------------------------------------------
1358      # Only one revision N specified, use (N - 1):N as the delta
1359      unshift @revs, ($revs[0] - 1) if @revs == 1;
1360
1361      $source->pegrev ($source->svninfo (FLAG => 'Last Changed Rev'))
1362        unless $source->pegrev;
1363      $source->subdir ($subdir);
1364      $target->subdir ($subdir);
1365
1366      # "Delta" of the "svn merge" command
1367      @delta = ('-r' . $revs[0] . ':' . $revs[1], $source->url_peg);
1368
1369      # Template message
1370      $mesg = 'Custom merge into ' . $target->path . ': r' . $revs[1] .
1371              ' cf. r' . $revs[0] . ' of ' . $source->path_peg . "\n";
1372
1373    } else {
1374      # Revision not specified
1375      # ------------------------------------------------------------------------
1376      # Get second source URL
1377      my $source2_url = shift (@ARGV);
1378      e_report 'Error: argument 2 must be the URL/name of a source branch in ',
1379               'custom mode when --revision is not specified, abort.'
1380        if not $source2_url;
1381
1382      my $source2 = &_construct_branch_url ($source2_url, $target);
1383
1384      $source->pegrev  ($source->svninfo  (FLAG => 'Last Changed Rev'))
1385        unless $source->pegrev;
1386      $source2->pegrev ($source2->svninfo (FLAG => 'Last Changed Rev'))
1387        unless $source2->pegrev;
1388      $source->subdir  ($subdir);
1389      $source2->subdir ($subdir);
1390      $target->subdir  ($subdir);
1391
1392      # "Delta" of the "svn merge" command
1393      @delta = ($source->url_peg, $source2->url_peg);
1394
1395      # Template message
1396      $mesg = 'Custom merge into ' . $target->path . ': ' . $source->path_peg .
1397              ' cf. ' . $source2->path_peg . "\n";
1398    }
1399
1400  } else {
1401    # Automatic merge
1402    # --------------------------------------------------------------------------
1403
1404    # Only allow the merge if the source and target are "directly related"
1405    # --------------------------------------------------------------------------
1406    my $anc = $target->ancestor ($source);
1407    e_report 'Error: source and target are not directly related' unless
1408      ($anc->url eq $target->url and $anc->url_peg eq $source->parent->url_peg)
1409      or
1410      ($anc->url eq $source->url and $anc->url_peg eq $target->parent->url_peg)
1411      or
1412      ($anc->url eq $source->parent->url and $anc->url eq $target->parent->url);
1413
1414    # Check for available merges from the source
1415    # --------------------------------------------------------------------------
1416    my @revs = $target->avail_merge_from ($source, 1);
1417
1418    if (@revs) {
1419      print 'Available Merge', (@revs > 1 ? 's' : ''), ' From ',
1420            $source->path_peg, ':';
1421
1422      if ($verbose) {
1423        # Verbose mode, print log messages of available merges
1424        print "\n";
1425
1426        for (@revs) {
1427          print $separator, $source->display_svnlog ($_);
1428        }
1429
1430        print $separator;
1431
1432      } else {
1433        # Normal mode, list revisions of available merges
1434        print ' ', join (' ', @revs), "\n";
1435      }
1436
1437    } else {
1438      w_report 'No merge available from ', $source->path_peg, ', abort.';
1439      return;
1440    }
1441
1442    # If more than one merge available, prompt user to enter a revision number
1443    # to merge from, default to $revs [0]
1444    # --------------------------------------------------------------------------
1445    my $reply = ($non_interactive or @revs == 1) ? $revs[0] : &main::get_input (
1446      TITLE   => 'fcm merge',
1447      MESSAGE => 'Please enter the revision you wish to merge from',
1448      DEFAULT => $revs [0],
1449    );
1450
1451    if (not defined ($reply)) {
1452      w_report 'Merge aborted by user.';
1453      return;
1454    }
1455
1456    # Expand revision keyword if necessary
1457    if ($reply) {
1458      $reply = expand_rev_keyword (REV => $reply, URL => $target->project_url);
1459    }
1460
1461    # Check that the reply is a number in the available merges list
1462    e_report $reply, ': not a revision in the list of available merges.'
1463      unless (grep {$_ == $reply} @revs);
1464
1465    $source->pegrev ($1) if ($reply =~ /^(\d+)/);
1466
1467    # If the working copy top is pointing to a sub-directory of a branch,
1468    # we need to check whether the merge will result in losing changes made in
1469    # other sub-directories of the source.
1470    if ($subdir and not $target->allow_subdir_merge_from ($source, $subdir)) {
1471      e_report 'SOURCE contains changes outside the current sub-directory.', "\n",
1472               'Please use a full tree for the merge, abort.';
1473    }
1474
1475    # Calculate the base of the merge
1476    my $base = $target->base_of_merge_from ($source);
1477
1478    # $source and $base must take into account the sub-directory
1479    my $s = Fcm::CmBranch->new (URL => $source->url_peg);
1480    my $b = Fcm::CmBranch->new (URL => $base->url_peg);
1481
1482    $s->subdir ($subdir) if $subdir;
1483    $b->subdir ($subdir) if $subdir;
1484
1485    # Diagnostic
1486    print 'About to merge in changes from ', $s->path_peg, ' compared with ',
1487          $b->path_peg, "\n";
1488
1489    # Delta of the "svn merge" command
1490    @delta = ($b->url_peg, $s->url_peg);
1491
1492    # Template message
1493    $mesg = 'Merged into ' . $target->path . ': ' . $source->path_peg .
1494            ' cf. ' . $base->path_peg . "\n";
1495  }
1496
1497  # Run "svn merge" in "--dry-run" mode to see the result
1498  # ----------------------------------------------------------------------------
1499  my @out   = &run_command (
1500    [qw/svn merge --dry-run/, @delta],
1501    METHOD => 'qx', PRINT => ($dry_run and $verbose),
1502  );
1503
1504  # Abort merge if it will result in no change
1505  if (not @out) {
1506    print 'This merge will not result in any change, abort.', "\n";
1507    return;
1508  }
1509
1510  # Report result of "svn merge --dry-run"
1511  if (not $non_interactive) {
1512    print 'This merge will result in the following change',
1513          (@out > 1 ? 's' : ''), ':', "\n";
1514    print $separator, @out, $separator;
1515  }
1516
1517  return if $dry_run;
1518
1519  # Prompt the user to see if (s)he would like to go ahead
1520  # ----------------------------------------------------------------------------
1521  my $reply = $non_interactive ? 'y' : &main::get_input (
1522    TITLE   => 'fcm merge',
1523    MESSAGE => 'Would you like to go ahead with the merge?',
1524    TYPE    => 'yn',
1525    DEFAULT => 'n',
1526  );
1527
1528  # Go ahead with merge only if user replies "y"
1529  if ($reply eq "y") {
1530    print "Performing merge ...\n";
1531    &run_command ([qw/svn merge/, @delta], PRINT => $verbose);
1532
1533  } else {
1534    w_report 'Merge aborted by user.';
1535    return;
1536  }
1537
1538  # Prepare the commit log
1539  # ----------------------------------------------------------------------------
1540  # Read in any existing message
1541  my $ci_mesg = Fcm::CmCommitMessage->new;
1542  $ci_mesg->read_file;
1543  $ci_mesg->auto_mesg ($mesg, ($ci_mesg->auto_mesg));
1544  $ci_mesg->write_file;
1545
1546  if ($verbose) {
1547    print <<EOF;
1548${separator}The following line has been added to your commit message file:
1549$mesg
1550EOF
1551  }
1552
1553  return;
1554}
1555
1556# ------------------------------------------------------------------------------
1557# SYNOPSIS
1558#   &Fcm::Cm::cm_mkpatch ();
1559#
1560# DESCRIPTION
1561#   This is a FCM command to create a patching script from particular revisions
1562#   of a URL.
1563# ------------------------------------------------------------------------------
1564
1565sub cm_mkpatch {
1566  my $usage = <<EOF;
1567mkpatch: Create patches from specified revisions of a URL
1568usage: fcm mkpatch [OPTIONS] URL [OUTDIR]
1569
1570  URL must be the URL of a branch in a FCM project. If the URL is a
1571  sub-directory of a branch, it will use the root of the branch.
1572
1573  Create patches from specified revisions of the specified URL. If OUTDIR is
1574  specified, the output is sent to OUTDIR. Otherwise, the output will be sent
1575  to a default location in the current directory (\$PWD/fcm-mkpatch-out). The
1576  output directory will contain the patch for each revision as well as a script
1577  for importing the patch.
1578
1579  If a revision is specified with the --revision option, it will attempt to
1580  create a patch based on the changes at that revision. If a revision is not
1581  specified, it will attempt to create a patch based on the changes at the HEAD
1582  revision. If a revision range is specified, it will attempt to create a patch
1583  for each revision in that range (including the change in the lower range)
1584  where changes have taken place in the URL. No output will be written if there
1585  is no change in the given revision (range).
1586
1587  The --exclude option can be used to exclude a path in the URL. The specified
1588  path must be a relative path of the URL. Glob patterns such as * and ? are
1589  acceptable. Changes in an excluded path will not be considered in the patch.
1590  A changeset containing changes only in the excluded path will not be
1591  considered at all.
1592
1593  The --organisation option can be used to specify the name of your
1594  organisation. The command will attempt to parse the commit log message for
1595  each revision in the patch. It will remove all merge templates, replace links
1596  to Trac tickets with a simple string, and add information about the original
1597  changeset. If you specify the name of your organisation, it will replace Trac
1598  ticket links such as "ticket:123" to "Original \$organisation ticket 123",
1599  and report the orginal changeset with a message such as "Original
1600  \$organisation changeset 1000". Otherwise, it will report without the
1601  organisation name, e.g. "Original ticket 123" and "Original  changeset 1000".
1602
1603Valid options:
1604  --exclude       arg : Exclude a path in the URL. Multiple paths can be
1605                        specified by using a colon-separated list of paths, or
1606                        by specifying this option multiple times.
1607  --organisation  arg : Specify the name of your organisation.
1608  -r [--revision] arg : Specify a revision number or a revision number range.
1609EOF
1610
1611  # Print usage message if requested
1612  if (defined ($ARGV[0]) and grep {$_ eq $ARGV[0]} qw(--help -h)) {
1613    print $usage;
1614    return 1;
1615  }
1616
1617  # Process command line options and arguments
1618  # ----------------------------------------------------------------------------
1619  my (@exclude, $organisation, $revision);
1620  GetOptions (
1621    'exclude=s'      => \@exclude,
1622    'organisation=s' => \$organisation,
1623    'r|revision=s'   => \$revision,
1624  );
1625
1626  # Excluded paths, convert glob into regular patterns
1627  @exclude = split (/:/, join (':', @exclude));
1628  for (@exclude) {
1629    s#\*#[^/]*#; # match any number of non-slash character
1630    s#\?#[^/]#;  # match a non-slash character
1631    s#/*$##;     # remove trailing slash
1632  }
1633
1634  # Organisation prefix
1635  $organisation = $organisation ? $organisation : 'original';
1636
1637  # Make sure revision option is set correctly
1638  my @revs = $revision ? split (/:/, $revision) : ();
1639  @revs    = @revs [0, 1] if @revs > 2;
1640
1641  # Arguments
1642  my ($u, $outdir) = @ARGV;
1643
1644  if (not $u) {
1645    print $usage;
1646    return 1;
1647  }
1648
1649  my $url = Fcm::CmUrl->new (URL => $u);
1650  e_report $u, ': URL is not a URL, abort.' if not $url->is_url;
1651  e_report $u, ': URL does not exist, abort.' if not $url->url_exists;
1652  e_report $u, ': URL is not a valid branch in a FCM project, abort.'
1653    if not $url->branch;
1654
1655  $url->subdir ('');
1656
1657  if (@revs) {
1658    # If HEAD revision is given, convert it into a number
1659    # --------------------------------------------------------------------------
1660    for my $rev (@revs) {
1661      $rev = $url->svninfo (FLAG => 'Revision') if uc ($rev) eq 'HEAD';
1662    }
1663
1664  } else {
1665    # If no revision is given, use the HEAD
1666    # --------------------------------------------------------------------------
1667    $revs[0] = $url->svninfo (FLAG => 'Revision');
1668  }
1669
1670  $revs[1] = $revs[0] if @revs == 1;
1671
1672  # Check that output directory is set
1673  # ----------------------------------------------------------------------------
1674  $outdir = File::Spec->catfile (cwd (), 'fcm-mkpatch-out') if not $outdir;
1675
1676  if (-e $outdir) {
1677    # Ask user to confirm removal of old output directory if it exists
1678    my $reply = &main::get_input (
1679      TITLE   => 'fcm mkpatch',
1680      MESSAGE => 'Output location ' . $outdir . ' exists. OK to overwrite?',
1681      TYPE    => 'yn',
1682      DEFAULT => 'n',
1683    );
1684
1685    if ($reply ne 'y') {
1686      w_report 'fcm mkpatch: command aborted by user.';
1687      return 1;
1688    }
1689
1690    rmtree $outdir or die $outdir, ': cannot remove';
1691  }
1692
1693  # (Re-)create output directory
1694  mkpath $outdir or die $outdir, ': cannot create';
1695  print 'Output directory: ', $outdir, "\n";
1696
1697  # Get and process log of URL
1698  # ----------------------------------------------------------------------------
1699  my @script     = (); # output script, from the log
1700  my %log        = $url->svnlog (REV => \@revs);
1701  my $url_path   = $url->path;
1702  my $file_count = 0;
1703
1704  for my $rev (sort {$a <=> $b} keys %log) {
1705    # Look at the changed paths for each revision
1706    my @paths;
1707
1708    # Skip excluded paths if necessary
1709    PATH: for my $path (sort keys %{ $log{$rev}{paths} }) {
1710      for my $exclude (@exclude) {
1711        (my $file = $path) =~ s#^$url_path/*##;
1712
1713        next PATH if $file =~ m#^$exclude(?:/*|$)#;
1714      }
1715
1716      push @paths, $path;
1717    }
1718
1719    next unless @paths;
1720
1721    # Parse commit log message
1722    my @msg = split /\n/, $log{$rev}{msg};
1723    for (@msg) {
1724      # Re-instate line break
1725      $_ .= "\n";
1726
1727      # Remove line if it matches a merge template
1728      $_ = '' if /^Reversed r\d+(?::\d+)? of \S+$/;
1729      $_ = '' if /^Custom merge into \S+:.+$/;
1730      $_ = '' if /^Merged into \S+: \S+ cf\. \S+$/;
1731
1732      # Modify Trac ticket link
1733      s/(?:#|ticket:)(\d+)/[$organisation ticket $1]/g;
1734
1735      # Modify Trac changeset link
1736      s/(?:r|changeset:)(\d+)/[$organisation changeset $1]/g;
1737      s/\[(\d+)\]/[$organisation changeset $1]/g;
1738    }
1739
1740    push @msg, '[' . $organisation . ' changeset ' . $rev . ']' . "\n";
1741
1742    # Write commit log message in a file
1743    my $f_revlog = File::Spec->catfile ($outdir, $rev . '-log');
1744    open FILE, '>', $f_revlog or die $f_revlog, ': cannot open (', $!, ')';
1745    print FILE @msg;
1746    close FILE or die $f_revlog, ': cannot close (', $!, ')';
1747
1748    # Create a directory for this revision in the output directory
1749    my $outdir_rev = File::Spec->catfile ($outdir, $rev);
1750    mkpath $outdir_rev or die $outdir_rev, ': cannot create';
1751
1752    # Handle modified/copy/new path, export the path, + script to copy/add it
1753    for my $path (@paths) {
1754      next unless $log{$rev}{paths}{$path}{action} =~ /^[AMR]$/;
1755
1756      (my $file = $path) =~ s#^$url_path/*##;
1757
1758      # Download the file using "svn export"
1759      my $patch    = File::Spec->catfile ($outdir_rev, $file_count++);
1760      my $url_file = $url->url . '/' . $file . '@' . $rev;
1761      &run_command ([qw/svn export -q -r/, $rev, $url_file, $patch]);
1762
1763      (my $patch_path = $patch) =~ s#^$outdir/*##;
1764
1765      # Script to copy the file, if required
1766      my $is_newfile = 0;
1767      if ($log{$rev}{paths}{$path}{action} eq 'A') {
1768        if (exists $log{$rev}{paths}{$path}{'copyfrom-path'}) {
1769          # History exists for this file
1770          my $copyfrom_path = $log{$rev}{paths}{$path}{'copyfrom-path'};
1771          my $copyfrom_rev  = $log{$rev}{paths}{$path}{'copyfrom-rev'};
1772
1773          # Check whether file is copied from a file under the specified URL
1774          # It is likely to be a new file if it is copied from outside of the
1775          # specified URL.
1776          $is_newfile = not ($copyfrom_path =~ s#^$url_path/*##);
1777
1778          if ($is_newfile) {
1779            # File copied from outside of the specified URL
1780            # If it is copied from a branch, follow its history, stop on copy
1781            my $cp_url = Fcm::CmUrl->new (
1782              URL => $url->root . $copyfrom_path . '@' . $copyfrom_rev,
1783            );
1784
1785            # Log of the copied file
1786            my %cp_log = $cp_url->svnlog (STOP_ON_COPY => 1);
1787
1788            # "First" revision of the copied file
1789            my $cp_rev = (sort {$a <=> $b} keys %cp_log) [0];
1790            my %attrib = %{ $cp_log{$cp_rev}{paths}{$cp_url->path} };
1791
1792            # Check whether the "first" revision is copied from elsewhere.
1793            if (exists $attrib{'copyfrom-path'}) {
1794              # Check whether source exists in the current branch
1795              my $cp_cp_url = Fcm::CmUrl->new (
1796                URL => $url->root . $attrib{'copyfrom-path'} . '@' .
1797                       $attrib{'copyfrom-rev'},
1798              );
1799
1800              $cp_cp_url->branch ($url->branch);
1801
1802              # If source exists in current branch, set up copy from the source
1803              if ($cp_cp_url->url_exists ($rev - 1)) {
1804                $is_newfile     = 0;
1805                (my $cp_cp_path = $cp_cp_url->path) =~ s#^$url_path/*##;
1806
1807                push @script, 'svn copy ' . $cp_cp_path .  ' ' . $file;
1808              }
1809            }
1810
1811          } else {
1812            # File copied from a location under the specified URL
1813            # Script to copy file
1814            push @script, 'svn copy ' . $copyfrom_path .  ' ' . $file;
1815          }
1816
1817        } else {
1818          # History does not exist, must be a new file
1819          $is_newfile = 1;
1820        }
1821      }
1822
1823      # Copy the "patch" into the file
1824      push @script, 'cp -r ${fcm_patch_dir}/' . $patch_path . ' ' . $file;
1825
1826      # Script to add the file, if required
1827      push @script, 'svn add ' . $file
1828        if $log{$rev}{paths}{$path}{action} eq 'A' and $is_newfile;
1829    }
1830
1831    # Handle deleted path, script to delete it
1832    for my $path (@paths) {
1833      next unless $log{$rev}{paths}{$path}{action} eq 'D';
1834
1835      (my $file = $path) =~ s#^$url_path/*##;
1836
1837      push @script, 'svn delete ' . $file;
1838    }
1839
1840    # Script to commit the change
1841    push @script, 'svn commit -F ${fcm_patch_dir}/' . $rev . '-log';
1842    push @script, '';
1843  }
1844
1845  # Write the script if necessary. Otherwise remove output directory
1846  # ----------------------------------------------------------------------------
1847  if (@script) {
1848    # Add line break to each line in @script
1849    @script = map {($_ ? $_ . ' || exit 1' . "\n" : "\n")} @script;
1850
1851    # Write script to output
1852    my $out = File::Spec->catfile ($outdir, 'fcm-import-patch');
1853    open FILE, '>', $out or die $out, ': cannot open (', $!, ')';
1854
1855    # Script header
1856    print FILE <<EOF;
1857#!/bin/sh
1858# ------------------------------------------------------------------------------
1859# NAME
1860#   fcm-import-patch
1861#
1862# SYNOPSIS
1863#   fcm-import-patch TARGET
1864#
1865# DESCRIPTION
1866#   This script is generated automatically by the "fcm mkpatch" command,
1867#   together with the revision "patches" it creates. The script imports the
1868#   patches into TARGET, which must either be a URL or a working copy of a
1869#   valid project tree that can accept the import of the patches.
1870#
1871#   Patch created from $organisation URL: $u
1872# ------------------------------------------------------------------------------
1873
1874this=`basename \$0`
1875
1876# Check argument
1877target=\$1
1878
1879# First argument must be a URL or working copy
1880if [[ -z \$target ]]; then
1881  echo "\$this: the first argument must be a URL or a working copy, abort." >&2
1882  exit 1
1883fi
1884
1885if [[ \$target == svn://*  || \$target == svn+ssh://* || \\
1886      \$target == http://* || \$target == https://*   || \\
1887      \$target == file://* ]]; then
1888  # A URL, checkout a working copy in a temporary location
1889  fcm_tmp_dir=`mktemp -d \$TMPDIR/\$0.XXXXXX`
1890  fcm_working_copy=\$fcm_tmp_dir
1891  svn checkout -q \$target \$fcm_working_copy || exit 1
1892
1893else
1894  # A working copy, check that it does not have local changes
1895  status=`svn status \$target`
1896
1897  if [[ -n \$status ]]; then
1898    echo "\$target: working copy contains changes, abort." >&2
1899    exit 1
1900  fi
1901
1902  fcm_working_copy=\$target
1903fi
1904
1905# Location of the patches, base on the location of this script
1906cd `dirname \$0` || exit 1
1907fcm_patch_dir=\$PWD
1908
1909# Change directory to the working copy
1910cd \$fcm_working_copy || exit 1
1911
1912# Commands to apply patches
1913EOF
1914
1915    # Script content
1916    print FILE @script;
1917
1918    # Script footer
1919    print FILE <<EOF;
1920# Remove temporary working copy, if necessary
1921if [[ -d \$fcm_tmp_dir && -w \$fcm_tmp_dir ]]; then
1922  rm -rf \$fcm_tmp_dir
1923fi
1924
1925echo "\$this: finished normally."
1926#EOF
1927EOF
1928
1929    close FILE or die $out, ': cannot close (', $!, ')';
1930
1931    # Add executable permission
1932    chmod 0755, $out;
1933
1934    # Diagnostic
1935    print $outdir, ': patch generated.', "\n";
1936
1937  } else {
1938    # Remove output directory
1939    rmtree $outdir or die $outdir, ': cannot remove';
1940
1941    # Diagnostic
1942    w_report 'No patch is required, abort.';
1943  }
1944
1945  return 1;
1946}
1947
1948# ------------------------------------------------------------------------------
1949# SYNOPSIS
1950#   &Fcm::Cm::cm_svn ();
1951#
1952# DESCRIPTION
1953#   This is a generic wrapper for all "other" Subversion commands.
1954# ------------------------------------------------------------------------------
1955
1956sub cm_svn {
1957  &run_command (
1958    ['svn', @_, @ARGV],
1959    PRINT => ($_[0] ne 'cat' and not grep {$_ eq '--xml'} @ARGV),
1960    METHOD => 'exec',
1961  );
1962}
1963
1964# ------------------------------------------------------------------------------
1965# SYNOPSIS
1966#   &Fcm::Cm::cm_switch ();
1967#
1968# DESCRIPTION
1969#   This is a wrapper for the Subversion "switch" command.
1970# ------------------------------------------------------------------------------
1971
1972sub cm_switch {
1973  if (grep {$_ eq '-h' or $_ eq '--help'} @ARGV or not @ARGV) {
1974    # Print usage message if requested
1975    print <<EOF;
1976usage: 1. switch URL [PATH]
1977       2. switch --relocate FROM TO [PATH...]
1978
1979Note: if --relocate is not specified, "fcm switch" will only support the
1980      options --non-interactive, -r [--revision] and -q [--quiet].
1981
1982EOF
1983
1984    &run_command ([qw/svn switch --help/], PRINT => 1, METHOD => 'exec');
1985
1986  } elsif (grep {$_ eq '--relocate'} @ARGV) {
1987    # If "--relocate" is specified, call the command "as is"
1988    cm_svn ('switch');
1989  }
1990
1991  # "--help" and "--relocate" not specified, implement custom switch command
1992
1993  # Get command line options
1994  my ($non_interactive, $rev, $quiet);
1995  GetOptions (
1996    'non-interactive' => \$non_interactive,
1997    'revision|r=s'    => \$rev,
1998    'quiet|q'         => \$quiet,
1999  );
2000
2001  # The remaining arguments
2002  $rev = 'HEAD' if not $rev;
2003
2004  # The remaining arguments
2005  my ($newurl_arg, $path) = @ARGV;
2006
2007  # Make sure we are in a working copy
2008  if ($path) {
2009    e_report $path, ': does not exist, abort.' if not -e $path;
2010
2011  } else {
2012    $path = cwd ();
2013  }
2014
2015  e_report $path, ': not a working copy, abort.' if not &is_wc ($path);
2016
2017  # Make sure we are at the top level of the working copy
2018  my $dir = &get_wct ($path);
2019
2020  # Check for merge template in the commit log file in the working copy
2021  my $ci_mesg = Fcm::CmCommitMessage->new (DIR => $dir);
2022  $ci_mesg->read_file;
2023  e_report (
2024    (($path eq $dir) ? $ci_mesg->base : $ci_mesg->file),
2025    ': merge template exists, please remove it before running switch, abort.',
2026  ) if $ci_mesg->auto_mesg;
2027
2028  # Check for any local modifications
2029  return if ! $non_interactive and &_abort_modified_wc ('fcm switch', $dir);
2030
2031  # Get current URL information associated with the working copy
2032  my $oldurl = Fcm::CmBranch->new (URL => &get_url_of_wc ($dir));
2033
2034  # Analyse new URL
2035  my $newurl = &_construct_branch_url ($newurl_arg, $oldurl);
2036
2037  # Construct the switch command
2038  my @command = (
2039    qw/svn switch/,
2040    ($non_interactive ? '--non-interactive' : ()),
2041    ($rev             ? ('-r', $rev)        : ()),
2042    ($quiet           ? '--quiet'           : ()),
2043    $newurl->url,
2044    ($dir eq cwd () ? () : $dir),
2045  );
2046
2047  # Execute the command
2048  &run_command (\@command, METHOD => 'exec', PRINT => 1);
2049}
2050
2051# ------------------------------------------------------------------------------
2052# SYNOPSIS
2053#   $source = &_construct_branch_url ($src_url, $target);
2054#
2055# DESCRIPTION
2056#   The function takes a string $src_url, which is normally the SOURCE URL
2057#   argument for "merge" and "switch", and a target, which is an instance of a
2058#   Fcm::CmBranch object with a valid URL of a standard FCM branch. It returns
2059#   an instance of a Fcm::CmBranch object that represents a valid URL for
2060#   $src_url.
2061# ------------------------------------------------------------------------------
2062
2063sub _construct_branch_url {
2064  my ($src_url, $target) = @_;
2065
2066  my $source = Fcm::CmBranch->new (URL => $src_url);
2067
2068  if (not $source->is_url) {
2069    # Not a full URL, construct full URL based on current URL
2070    $source->url_peg ($target->url_peg);
2071
2072    my $path    = '';
2073    my $project = $target->project;
2074
2075    # Construct the branch URL
2076    if ($src_url =~ m#^/*$project/(?:trunk|branches|tags)$#) {
2077      # Argument contains the full path under the repository root
2078      $path = $src_url;
2079
2080    } elsif ($src_url =~ m#^/*trunk/*(?:@\d+)?$# or
2081             $src_url =~ m#^/*(?:trunk|branches|tags)/+#) {
2082      # Argument contains the full branch name
2083      $src_url =~ s#^/*##;
2084      $path    = $target->project_path . '/' . $src_url;
2085
2086    } else {
2087      # Argument contains the shorter branch name
2088      $src_url =~ s#^/*##;
2089      $path    = $target->project_path . '/branches/' . $src_url;
2090    }
2091
2092    $source->path_peg ($path);
2093  }
2094
2095  # Replace source sub-directory with the target sub-directory
2096  $source->subdir ($target->subdir);
2097
2098  # Ensure that the branch name exists
2099  e_report $src_url, ': not a valid URL, abort.'
2100    if not $source->url_exists;
2101
2102  # Ensure that the branch name is valid
2103  e_report $src_url, ': not a standard branch in a FCM project, abort.'
2104    if not $source->branch;
2105
2106  # Ensure that the source and target URLs are in the same project
2107  e_report 'Source and target URLs are in different projects, abort.'
2108    if $source->project_url ne $target->project_url;
2109
2110  return $source;
2111}
2112
2113# ------------------------------------------------------------------------------
2114# SYNOPSIS
2115#   &_abort_modified_wc ($title, [$wc]);
2116#
2117# DESCRIPTION
2118#   The function checks for any local modifications in a working copy and
2119#   prompts the user whether he/she wants to continue with the command. $title
2120#   is the title of the current command. If $wc is specified, it must be the
2121#   path to a working copy. Otherwise, the current working directory is used.
2122# ------------------------------------------------------------------------------
2123
2124sub _abort_modified_wc {
2125  my ($title, $wc) = @_;
2126
2127  my @status = &run_command ([qw/svn status/, ($wc ? $wc : ())], METHOD => 'qx');
2128
2129  if (@status) {
2130    print 'You have local modifications:', "\n", @status;
2131    my $reply = &main::get_input (
2132      TITLE   => $title,
2133      MESSAGE => 'Are you sure you want to continue?',
2134      TYPE    => 'yn',
2135      DEFAULT => 'n',
2136    );
2137
2138    # Abort if user gives any reply other than "y"
2139    if ($reply ne 'y') {
2140      w_report $title, ': command aborted by user.';
2141      return 1;
2142    }
2143  }
2144}
2145
2146# ------------------------------------------------------------------------------
2147
21481;
2149
2150__END__
Note: See TracBrowser for help on using the repository browser.