source: LMDZ6/branches/IPSL-CM6A-MR/tools/fcm/lib/Fcm/Cm.pm

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