lib/BinMerge.pm

   1 #!/usr/bin/perl
   2 ################################################################################
   3 #
   4 # File:         $RCSfile: BinMerge.pm,v $
   5 # Revision:     $Revision: 1.4 $
   6 # Description:  This module will perform a merge checking for any merge
   7 #               conflicts and grouping them at the end. This allows the
   8 #               majority of a large merge to happen and the user can resolve
   9 #               the conflicts at a later time.
  10 #
  11 #               This module also assists in performing binary merges for the
  12 #               common case. With a binary merge one cannot easily merge the
  13 #               binary code. Most often it's a sitatution where the user will
  14 #               either accept the source or the destination binary file as
  15 #               a whole. In cases where there is only a 2 way merge, this
  16 #               script offers the user the choice to accept 1 binary file
  17 #               or the other or to abort this binary merge. Binary merges
  18 #               conflicts greater than 2 way are not handled.
  19 #
  20 #               This was made into a module so that it could be easily called
  21 #               from UCMCustom.pl. There is also a corresponding bin_merge
  22 #               script which essentially calls this module
  23 #
  24 # Dependencies: This module depends on PerlTk. As such it must be run
  25 #               from ccperl or a Perl that has the PerlTk module
  26 #               installed. Additionally it uses the Clearcase
  27 #               cleartool command which is assumed to be in PATH.
  28 # Author:       Andrew@ClearSCM.com
  29 # Created:      Thu Nov  3 10:55:51 PST 2005
  30 # Modified:     $Date: 2011/03/10 23:47:31 $
  31 # Language:     perl
  32 #
  33 # (c) Copyright 2005, ClearSCM, Inc. all rights reserved
  34 #
  35 ################################################################################
  36 package BinMerge;
  37
  38 use strict;
  39 use warnings;
  40
  41 use base 'Exporter';
  42 use File::Spec;
  43 use Tk;
  44 use Tk::Dialog;
  45 use OSDep;
  46
  47 our @EXPORT = qw (
  48   Merge
  49   Rebase
  50 );
  51
  52 our ($me);
  53
  54 BEGIN {
  55   # Extract relative path and basename from script name.
  56   $0 =~ /(.*)[\/\\](.*)/;
  57
  58   $me = (!defined $2) ? $0 : $2;
  59   $me =~ s/\.pl$//;
  60
  61   # Remove .pl for Perl scripts that have that extension
  62   $me         =~ s/\.pl$//;
  63 } # BEGIN
  64
  65   use Display;
  66   use Logger;
  67   use OSDep;
  68
  69   my $version = "1.0";
  70   my $user = $ENV {USERNAME};
  71
  72   my $main;
  73   my $selection_file = "$me.selection.$$";
  74
  75   sub ReadFile {
  76     my $filename = shift;
  77
  78     # Sometimes people foolishly undef $/
  79     local $/ = "\n";
  80
  81     open my $file, '<', $filename
  82       or error "Unable to open $filename ($!)", 1;
  83
  84     my @lines = <$file>;
  85
  86     close $file;
  87
  88     my @cleansed_lines;
  89
  90     foreach (@lines) {
  91       chomp;
  92       chop if /\r/;
  93       push @cleansed_lines, $_ if !/^#/; # Discard comment lines
  94     } # foreach
  95
  96     return @cleansed_lines;
  97   } # ReadFile
  98
  99   sub Error {
 100     my $msg = shift;
 101
 102     my $err = $main->Dialog (
 103       -title   => "Error",
 104       -text    => $msg,
 105       -buttons => [ "OK" ]
 106     );
 107
 108     $err->Show;
 109
 110     return;
 111   } # Error
 112
 113   sub CheckSelection {
 114     my $list = shift;
 115
 116     my @entries = $list->curselection;
 117
 118     if (scalar @entries == 0) {
 119       Error "Nothing selected!";
 120       return;
 121     } # if
 122
 123     my $selected = $list->get ($entries [0]);
 124
 125     # Write selection out to file and exit
 126     open my $file, '>', $selection_file
 127       or die "Unable to open $selection_file\n";
 128
 129     print $file "$selected\n";
 130
 131     close $file;
 132
 133     # Close prompt window
 134     $main->destroy;
 135
 136     return;
 137   } # CheckSelection
 138
 139   sub Help {
 140     my $text;
 141
 142     $text  = "A merge conflict has been detected between two binary files. ";
 143     $text .= "Please pick the version that you want to be the result of this ";
 144     $text .= "merge.\n\nNote you can pick any of these versions and the result ";
 145     $text .= "will be that that version will be considered the new version ";
 146     $text .= "overwriting the previous version.\n\nIf this is not what you want ";
 147     $text .= "then select the Cancel button and regenerate this binary file ";
 148     $text .= "so that it is the result of what you want for this merge.\n\n";
 149     $text .= "Copyright ? 2005 - All rights reserved\n";
 150     $text .= "Andrew DeFaria <Andrew\@ClearSCM.com>";
 151
 152     my $desc = $main->Dialog (
 153       -title   => "Help",
 154       -text    => $text,
 155       -buttons => [ "OK" ]
 156     );
 157
 158     $desc->Show;
 159
 160     return;
 161   } # Help
 162
 163   sub Cancel {
 164     $main->destroy;
 165
 166     return;
 167   } # Cancel
 168
 169   sub VersionTree {
 170     my $file = shift;
 171
 172     my $cmd =  "cleartool lsvtree -graphical $file";
 173
 174     if ($^O =~ /mswin|cygwin/i) {
 175       system "start /b $cmd";
 176     } else {
 177       my $pid = fork;
 178
 179       return if $pid;
 180
 181       system $cmd;
 182       exit;
 183     } # if
 184
 185     return;
 186   } # VersionTree
 187
 188   # Create a ListBox widget in $parent, dynamically sizing it to the length of
 189   # the longest entry in @list.
 190   sub CreateList {
 191     my ($parent, @list) = @_;
 192
 193     my $list = $parent->Scrolled ("Listbox",
 194       -scrollbars => "osoe",
 195       -width      => 70,
 196       -height     => 5,
 197     )->pack;
 198
 199     # Insert entries from @list into the new ListBox, $list
 200     foreach (@list) {
 201       $list->insert ("end", $_);
 202     } # foreach
 203
 204     $list->pack;
 205
 206     return $list;
 207   } # CreateList
 208
 209   sub CreateButtons {
 210     my ($parent, $list, $file) = @_;
 211     my $one   = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
 212     my $two   = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
 213     my $three = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
 214     my $four  = $parent->Frame->pack (-side => "left", -pady => 2, -padx => 2);
 215
 216     my $ok = $one->Button (
 217       -text    => "OK",
 218       -command => [ \&CheckSelection, $list ]
 219     )->pack;
 220
 221     my $cancel = $two->Button (
 222       -text    => "Cancel",
 223       -command => [ \&Cancel ]
 224     )->pack;
 225
 226     my $help = $three->Button (
 227       -text    => "Help",
 228       -command => \&Help
 229     )->pack;
 230
 231     my $vtree = $four->Button (
 232       -text    => "Version Tree",
 233       -command => [ \&VersionTree, $file ]
 234     )->pack;
 235
 236     return;
 237   } # CreateButtons
 238
 239   sub PromptUser {
 240     my ($element, @versions) = @_;
 241
 242     debug "ENTER: PromptUser";
 243
 244     # Create main window
 245     $main = MainWindow->new;
 246
 247     # Title window
 248     $main->title ("Resolve merge conflict for binary element");
 249
 250     # Create the main window using containers
 251     my $top     = $main->Frame->pack (-side => "top", -fill => "x");
 252     my $prompt  = $top->Frame->pack  (-side => "left", -pady => 5, -padx => 5);
 253     my $list    = $main->Frame->pack (-side => "left");
 254     my $buttons = $list->Frame->pack (-side => "bottom");
 255
 256     # Label it
 257     my $prompt_str = <<"END";
 258 A binary merge conflict has been detected between two versions of
 259
 260 $element
 261
 262 Please pick the version that you want to be the result of this merge. Note you
 263 can pick any of these versions and the result will be that that version will be
 264 considered the new version overwriting the previous version. If this is not what
 265 you want then select the Cancel button here and regenerate this binary file so
 266 that it is the result of what you want for this merge.
 267 END
 268
 269     $prompt->Message (-text => $prompt_str, -width => 500)->pack;
 270
 271     my $version_list = CreateList $list, @versions;
 272
 273     CreateButtons $buttons, $version_list, $element;
 274
 275     # Make sure the window pops to the top
 276     # Trying really hard... :-)
 277     $main->update;
 278     $main->deiconify;
 279     $main->update;
 280     $main->raise;
 281     $main->update;
 282     $main->focusForce;
 283     $main->update;
 284
 285     MainLoop;
 286
 287     open my $result, '<', $selection_file
 288       or return;
 289
 290     my @lines = <$result>;
 291
 292     close $result;
 293
 294     unlink $selection_file;
 295
 296     if (@lines) {
 297       chomp $lines[0];
 298       return $lines[0];
 299     } else {
 300       return;
 301     } # if
 302
 303     return;
 304   } # PromptUser
 305
 306   # The merging of directories could, in theory, unearth other elements inside
 307   # those directories thus causing further merging. Here we keep merging
 308   # directories until there are no directories to merge.
 309   sub MergeDirectories {
 310     my ($log, $path, $branch) = @_;
 311
 312     my $cmds = "$me.$$.cmds";
 313     my $cmd  = "cleartool findmerge $path -nc -type d -fversion $branch " .
 314       "-log $cmds -print > $NULL 2>&1";
 315
 316     debug "ENTER: MergeDirectories (<log>, $path, $branch)";
 317
 318     my @lines;
 319
 320     while () {
 321       $log->msg ("Searching for directories that need merging...");
 322
 323       debug "Performing: $cmd";
 324
 325       my $status = $log->logcmd ($cmd);
 326
 327       return $status if $status != 0;
 328
 329       @lines = ReadFile $cmds;
 330
 331       last if scalar @lines == 0;
 332
 333       $log->msg ("Performing directory merges...");
 334
 335       foreach (@lines) {
 336             $log->log ($_);
 337         debug "Performing: $_";
 338         $status = $log->logcmd ($_);
 339
 340         return $status if $status != 0;
 341       } # foreach
 342     } # while
 343
 344     $log->msg ("All directories merged.");
 345
 346     # Clean up
 347     unlink $cmds;
 348
 349     debug "EXIT: MergeDirectories (<log>, $path, $branch)";
 350
 351     return 0;
 352   } # MergeDirectories
 353
 354   # Here we'll attempt to merge file individually using -abort. This tells
 355   # cleartool findmerge to only merge that which is can automatically merge. For
 356   # every merge failure we'll push an entry onto @merge_conflicts.
 357   sub MergeFiles {
 358     my ($log, $path, $branch) = @_;
 359
 360     my $cmds = "$me.$$.cmds";
 361     my $cmd  = "cleartool findmerge $path -nc -type f -fversion $branch " .
 362       "-log $cmds -print > $NULL 2>&1";
 363
 364     debug "ENTER: MergeFiles (<log>, $path, $branch)";
 365
 366     $log->msg ("Merging files...");
 367
 368     $log->logcmd ($cmd);
 369
 370     my @lines = ReadFile $cmds;
 371     my @merge_conflicts;
 372
 373     foreach my $file_merge_cmd (@lines) {
 374       my %merge_conflict;
 375
 376       my $file_to_merge;
 377
 378       if ($file_merge_cmd =~ /cleartool findmerge (.*) -fver/) {
 379         $file_to_merge = $1;
 380       } # if
 381
 382       # Add -abort to this variable, which use for execution. We keep
 383       # the old variable to put in the return array.
 384       my $file_merge_cmd_abort = "$file_merge_cmd -abort 2>&1";
 385
 386       debug "Performing $file_merge_cmd_abort";
 387       $log->msg ($file_merge_cmd_abort);
 388
 389       # Capture the output from the merge and parse it. If there's
 390       # just a merge conflict then "*** No Automatic Decision
 391       # possible" and "merge: Warning: *** Aborting.." are present in
 392       # the output. If the merge fails because of binary files then
 393       # nothing is in the output. Either way, if Clearcase is unable
 394       # to merge the status returned is non zero. We can then
 395       # differentiate between resolvable merge conflicts and
 396       # unresolvable merge conflicts (binary files). Format
 397       # %merge_conflicts to indicate the type and push it on
 398       # @merge_conflicts to return to the caller.
 399       #
 400       # Also find merges that will not work because the element is
 401       # checked out reserved somewhere else.
 402       my @output = `$file_merge_cmd_abort`;
 403       my $status = $?;
 404
 405       # Put output in the logfile
 406       chomp @output;
 407       foreach (@output) {
 408         $log->log ($_);
 409       } # foreach
 410
 411       if ($status == 0) {
 412         # If $status eq 0 then the merge was successful! Next merge!
 413         $log->msg ("Auto merged $file_to_merge");
 414         next;
 415       } # if
 416
 417       # Check for errors
 418       my @errors = grep {/\*\*\* /} @output;
 419       my @reserved = grep {/is checked out reserved/} @output;
 420
 421       if (scalar @reserved > 0) {
 422         if ($reserved [0] =~ /view (\S+)\./) {
 423               $log->err ("Unable to merge $file_to_merge because it is checked out reserved in the view $1");
 424         } # if
 425
 426         next;
 427       } # if
 428
 429       $merge_conflict {cmd}  = $file_merge_cmd;
 430
 431       # Differentiate between binary merge conflicts and non binary
 432       # merge conflicts
 433       if (scalar @errors > 0) {
 434         $merge_conflict {type} = "regular";
 435         $log->msg ("Delaying regular conflicting merge for " . $file_to_merge);
 436       } else {
 437         $log->msg ("Delaying binary merge for " . $file_to_merge);
 438         $merge_conflict {type} = "binary";
 439       } # if
 440
 441       push @merge_conflicts, \%merge_conflict;
 442     } # foreach
 443
 444     my $nbr_conflicts = scalar @merge_conflicts;
 445
 446     if ($nbr_conflicts == 0) {
 447       $log->msg ("All files merged");
 448     } elsif ($nbr_conflicts == 1) {
 449       $log->msg ("$nbr_conflicts merge conflict found");
 450     } else {
 451       $log->msg ("$nbr_conflicts merge conflicts found");
 452     } # if
 453
 454     # Clean up
 455     unlink $cmds;
 456
 457     debug "EXIT: MergeFiles (<log>, $path, $branch)";
 458
 459     return @merge_conflicts;
 460   } # MergeFiles
 461
 462   sub GetRebaseDirs {
 463     my $log      = shift;
 464     my $baseline = shift;
 465
 466     $log->msg ("Finding directories that need rebasing...");
 467
 468     my $cmd = "cleartool rebase -long -preview ";
 469
 470     if (!defined $baseline) {
 471       $cmd .= "-recommended";
 472     } else {
 473       $cmd .= "-baseline $baseline";
 474     } # if
 475
 476     $log->msg ("Performing command: $cmd");
 477
 478     my @output = `$cmd`;
 479     chomp @output;
 480
 481     my %rebase_dirs;
 482
 483     return %rebase_dirs if $? != 0;
 484
 485     # Now parse the files to be merged collecting information
 486     foreach (@output) {
 487       if (/\s*(\S*)\@\@(\S*)/) {
 488             my $element = $1;
 489         my $ver     = $2;
 490
 491         # Directories only
 492         next if !-d $element;
 493
 494         $log->msg ("Directory Element: $element Version: $ver");
 495         $rebase_dirs {$element} = $ver;
 496       } # if
 497     } # foreach
 498
 499     return %rebase_dirs;
 500   } # GetRebaseDirs
 501
 502   sub GetRebaseFiles {
 503     my $log      = shift;
 504     my $baseline = shift;
 505
 506     $log->msg ("Finding files that need rebasing...");
 507
 508     my $cmd = "cleartool rebase -long -preview ";
 509
 510     if (!defined $baseline) {
 511       $cmd .= "-recommended";
 512     } else {
 513       $cmd .= "-baseline $baseline";
 514     } # if
 515
 516     $log->msg ("Performing command: $cmd");
 517
 518     my @output = `$cmd`;
 519
 520     return if $? != 0;
 521
 522     chomp @output;
 523
 524     my %rebase_files;
 525
 526     # Now parse the files to be merged collecting information
 527     foreach (@output) {
 528       if (/\s*(\S*)\@\@(\S*)/) {
 529         my $element = $1;
 530         my $ver     = $2;
 531
 532         # Files only
 533         next if !-f $element;
 534
 535         $log->msg ("Element: $element Version: $ver");
 536         $rebase_files {$element} = $ver;
 537       } # if
 538     } # foreach
 539
 540     return %rebase_files;
 541   } # GetRebaseFiles
 542
 543   sub RebaseDirectories {
 544     my $log      = shift;
 545     my $baseline = shift;;
 546
 547     debug "ENTER: RebaseDirectories";
 548
 549     $log->msg ("Rebasing directories");
 550
 551     my $rebase_status = 0;
 552     my %rebase_dirs;
 553
 554     # Keep rebasing directories until there are no more
 555     while (%rebase_dirs = GetRebaseDirs $log, $baseline) {
 556       foreach my $element (keys %rebase_dirs) {
 557         # First checkout file if necessary - ignore errors
 558         my @output = `cleartool checkout -nc $element > $NULL 2>&1`;
 559
 560         my $cmd = "cleartool merge -abort -to $element -version ${rebase_dirs {$element}} 2>&1";
 561
 562         @output = `$cmd`;
 563         my $status = $?;
 564
 565         # Put output in the logfile
 566         chomp @output;
 567
 568         foreach (@output) {
 569           $log->log ($_);
 570         } # foreach
 571
 572         if ($status == 0) {
 573           # If $status eq 0 then the merge was successful! Next merge!
 574           $log->msg ("Auto merged $element");
 575           next;
 576         } # if
 577
 578         # Check for errors
 579         my @errors = grep {/\*\*\* /} @output;
 580         my @reserved = grep {/is checked out reserved/} @output;
 581
 582         # TODO: This is broke!
 583         my $file_to_merge;
 584         if (scalar @reserved > 0) {
 585           if ($reserved [0] =~ /view (\S+)\./) {
 586             $log->err ("Unable to merge $file_to_merge because it is checked out reserved in the view $1");
 587             $rebase_status++;
 588           } # if
 589
 590           next;
 591         } # if
 592       } # foreach
 593     } # while
 594
 595     debug "Returning $rebase_status from RebaseDirectories";
 596     return $rebase_status;
 597   } # RebaseDirectories
 598
 599   sub RebaseFiles {
 600     my ($log, $baseline, %rebase_elements) = @_;
 601
 602     debug "ENTER: RebaseFiles";
 603
 604     # TODO: This is broke too
 605     my @merge_conflicts;
 606
 607     $log->msg ("Rebasing elements");
 608
 609     foreach my $element (keys %rebase_elements) {
 610       # First checkout file if necessary - ignore errors
 611       my @output = `cleartool checkout -nc $element > $NULL 2>&1`;
 612
 613       my $cmd = "cleartool merge -abort -to $element -version ${rebase_elements {$element}} 2>&1";
 614
 615       @output = `$cmd`;
 616       my $status = $?;
 617
 618       # Put output in the logfile
 619       chomp @output;
 620       foreach (@output) {
 621         $log->log ($_);
 622       } # foreach
 623
 624       if ($status == 0) {
 625         # If $status eq 0 then the merge was successful! Next merge!
 626         $log->msg ("Auto merged $element");
 627         next;
 628       } # if
 629
 630       # Check for errors
 631       my @errors = grep {/\*\*\* /} @output;
 632       my @reserved = grep {/is checked out reserved/} @output;
 633
 634       # TODO: This is broke too
 635       my ($file_to_merge, $merge_conflict, %merge_conflict, @merge_conflicts);
 636
 637       if (scalar @reserved > 0) {
 638         if ($reserved [0] =~ /view (\S+)\./) {
 639           $log->err ("Unable to merge $file_to_merge because it is checked out reserved in the view $1");
 640         } # if
 641
 642         next;
 643       } # if
 644
 645       # Differentiate between binary merge conflicts and non binary
 646       # merge conflicts
 647       if (scalar @errors > 0) {
 648         $merge_conflict {type} = "regular";
 649         $log->msg ("Delaying regular conflicting merge for " . $element);
 650       } else {
 651         $log->msg ("Delaying binary merge for " . $element);
 652         $merge_conflict {type} = "binary";
 653       } # if
 654
 655       push @merge_conflicts, \%merge_conflict;
 656     } # foreach
 657
 658     my $nbr_conflicts = scalar @merge_conflicts;
 659
 660     if ($nbr_conflicts == 0) {
 661       $log->msg ("All files merged");
 662     } elsif ($nbr_conflicts == 1) {
 663       $log->msg ("$nbr_conflicts merge conflict found");
 664     } else {
 665       $log->msg ("$nbr_conflicts merge conflicts found");
 666     } # if
 667
 668     debug "EXIT: RebaseFiles";
 669
 670     return @merge_conflicts;
 671   } # RebaseFiles
 672
 673   sub Rebase {
 674     my ($baseline, $verbose, $debug) = @_;
 675
 676     if ($verbose) {
 677       Display::set_verbose;
 678       Logger::set_verbose;
 679     } # if
 680
 681     set_debug if $debug;
 682
 683     my $log = Logger->new (
 684       name        => "$me.$$",
 685       disposition => "temp",
 686       path        => $ENV{TMP}
 687     );
 688
 689     $log->msg ("BinMerge (rebase) $version started at " . localtime);
 690
 691     if (!defined $baseline) {
 692       $log->msg ("Baseline: RECOMMENDED");
 693     } else {
 694       $log->msg ("Baseline: $baseline");
 695     } # if
 696
 697     my $rebase_status = RebaseDirectories $log, $baseline;
 698
 699     my @merge_conflicts = RebaseFiles $log, $baseline;
 700
 701     # more to come...
 702     return;
 703   } # Rebase
 704
 705   sub Merge {
 706     my ($branch, $path, $verbose, $debug) = @_;
 707
 708     if ($verbose) {
 709       Display::set_verbose;
 710       Logger::set_verbose;
 711     } # if
 712
 713     set_debug if $debug;
 714
 715     error "Must specify a branch" if !defined $branch;
 716     $path = "." if !defined $path;
 717
 718     my $log = Logger->new (
 719       name        => "$me.$$",
 720       disposition => "temp",
 721       path        => $ENV{TMP}
 722     );
 723
 724     $log->msg ("BinMerge $version started at " . localtime);
 725     my $merge_status = 0;
 726
 727     $merge_status = MergeDirectories $log, $path, $branch;
 728
 729     my @merge_conflicts = MergeFiles $log, $path, $branch;
 730
 731     my (@binary_merge_conflicts, @text_merge_conflicts);
 732     my $merge_conflict;
 733
 734     # Separate the bin merges from the text merges.
 735     while (@merge_conflicts) {
 736       my %merge_conflict = %{shift @merge_conflicts};
 737
 738       if ($merge_conflict {type} eq "binary") {
 739         # Since we can't merge binary files, change -merge to
 740         # -print. Later we'll use the -print output to present the
 741         # user options...
 742         $merge_conflict {cmd} =~ s/ -merge / -print /;
 743         push @binary_merge_conflicts, $merge_conflict {cmd};
 744       } else {
 745         # For text merges we can merge but we want to merge
 746         # graphically.
 747         $merge_conflict {cmd} =~ s/ -merge / -gmerge /;
 748         push @text_merge_conflicts, $merge_conflict {cmd};
 749       } # if
 750     } # while;
 751
 752     # Now process the text merges
 753     foreach my $merge_conflict (@text_merge_conflicts) {
 754       # Now try the merge so that diffmerge comes up allowing the user
 755       # to resolve the conflicts for this element.
 756       my $file_to_merge;
 757
 758       if ($merge_conflict =~ /cleartool findmerge (.*) -fver/) {
 759          $file_to_merge = $1;
 760       } # if
 761
 762       $file_to_merge =~ s/\\\\/\\/g;
 763
 764       debug "Performing $merge_conflict";
 765       my $status = $log->logcmd ("$merge_conflict 2>&1");
 766
 767       if ($status != 0) {
 768         $log->err ("$user did not resolve merge conflicts in $file_to_merge");
 769         $merge_status++;
 770       } else {
 771         $log->msg ("$user resolved conflicts in merge of $file_to_merge");
 772       } # if
 773     } # foreach
 774
 775     # Now process the binary ones...
 776     foreach my $merge_conflict (@binary_merge_conflicts) {
 777       # Now try to handle the binary merge conflicts. Best we can do
 778       # is to present the user the with the various versions that
 779       # could be taken as a whole along with an option to not
 780       # merge. If they select a specific version then we simply draw a
 781       # merge arrow.
 782
 783       my @selections;
 784
 785       # First let's do the merge command again capturing the output
 786       # which has a format like:
 787       #
 788       # Needs Merge "firefox.exe" [to \main\adefaria_Andrew\CHECKEDOUT
 789       # from \main\Andrew_Integration\2 base \main\adefaria_Andrew\1]
 790       #
 791       # From this we'll get the $from and $to to present to the user.
 792       my $file_to_merge;
 793
 794       if ($merge_conflict =~ /cleartool findmerge (.*) -fver/) {
 795         $file_to_merge = $1;
 796       } # if
 797
 798       debug "Performing $merge_conflict";
 799       my @output = `$merge_conflict 2>&1`;
 800
 801       my ($to, $from);
 802
 803       if ($output [0] =~ /to (\S*) from (\S*)/) {
 804         $to   = $1;
 805         $from = $2;
 806       } # if
 807
 808       push @selections, $from;
 809       push @selections, $to;
 810
 811       my $choice = PromptUser $file_to_merge, @selections;
 812
 813       if (!defined $choice) {
 814         $log->err ("$user aborted binary merge of $file_to_merge");
 815         next;
 816       } # if
 817
 818       chomp $choice;
 819       # I don't know why the above doesn't remove the trailing \n so let's
 820       # chop it off if it exists!
 821       chop $choice if $choice =~ /\n/;
 822
 823       my $cmd;
 824
 825       # At this point the merge process has checked out the file in
 826       # the current view but is unable to perform the merge because
 827       # this is a binary file. If the user chooses the $from version
 828       # then they are saying that the $from version should be brought
 829       # into the current view and a merge arrow drawn from $from ->
 830       # $to.
 831       #
 832       # If, however, they choose the CHECKEDOUT version then what we
 833       # want to do is to cancel the current checkout and draw a merge
 834       # arrow from the predecessor to $to.
 835       if ($choice eq $from) {
 836         # Need to copy the $from version to the checkedout version here.
 837         debug "Copying $file_to_merge\@\@$choice to current view";
 838         open my $from, '<', "$file_to_merge\@\@$choice"
 839           or error "Unable to open $file_to_merge\@\@$choice", 1;
 840         binmode $from;
 841
 842         open my $to, '>', "$file_to_merge"
 843           or error "Unable to open $file_to_merge\@\@$to", 2;
 844         binmode $to;
 845
 846         while (<$from>) {
 847           print $to $_;
 848         } # while
 849
 850         close $from;
 851         close $to;
 852
 853         $log->msg ("$user chose to link from $choice -> $file_to_merge" .
 854                " in the current view");
 855         $cmd = "cleartool merge -to \"$file_to_merge\"" .
 856                 " -ndata \"$file_to_merge\@\@$choice\"";
 857       } else {
 858         # Need to cancel the checkout then determine what version
 859         # Clearcase reverts to. WARNING: This might doesn't work
 860         # for a snapshot view.
 861         debug "Canceling checkout for $file_to_merge";
 862         @output = `cleartool unco -rm $file_to_merge 2>&1`;
 863
 864         error "Unable to cancel checkout of $file_to_merge", 3 if $? != 0;
 865
 866         @output = `cleartool ls -s $file_to_merge`;
 867
 868         chomp $output [0];
 869
 870         if ($output [0] =~ /\@\@(.*)/) {
 871           $choice = $1;
 872         } # if
 873
 874         debug "Drawing merge arrow from $file_to_merge\@\@$from -> $choice";
 875         $log->msg ("$user chose to link $file_to_merge from $from -> $choice");
 876             $cmd = "cleartool merge -to \"$file_to_merge\"\@\@$choice\" -ndata \"$file_to_merge\@\@$from\"";
 877       } # if
 878
 879       # Draw merge arrow
 880       my $status = $log->logcmd ($cmd);
 881
 882       error "Unable to draw merge arrow ($cmd)" if $status != 0;
 883
 884       $merge_status += $status;
 885     } # foreach
 886
 887     if ($merge_status > 0) {
 888       $log->err ("There were problems with the merge. Please review " .
 889         $log->fullname . " for more infomation");
 890     } # if
 891
 892     return $merge_status
 893   } # Merge
 894
 895 1;