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