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

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

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