3 Diffbl.pm: Perl/Tk UI for diffbl.pl
13 This Perl module encapsulates the Perl/Tk UI for diffbl.pl.
17 Andrew DeFaria <Andrew@ClearSCM.com>
21 Copyright (c) 2010 Andrew DeFaria <Andrew@ClearSCM.com>, ClearSCM, Inc.
54 $INTEGRATIONACTIVITIES,
55 $integrationActivitiesCheck
58 my ($msgWidget, $searchPattern);
68 my $TITLE = 'Compare Baselines: Use fields to select baselines then ';
69 $TITLE .= 'select Compare';
71 my $CCDBService = CCDBService->new;
80 $fromBaselineDropdown,
87 my (@pvobs, @streams, @fromBaselines, @toBaselines);
89 sub createButton ($$$) {
90 my ($parent, $label, $action) = @_;
94 -width => length $label,
105 sub createDropdown ($$$;$$) {
106 my ($parent, $label, $variable, $action, $list) = @_;
108 my $widget = $parent->BrowseEntry (
110 -font => 'Arial 8 bold',
111 -variable => $variable,
120 # Any of these cause the action to be invoked
121 $widget->configure (-browsecmd => \$action);
122 $widget->bind ('<FocusOut>' => \$action);
123 $widget->bind ('<Return>' => \$action);
126 $widget->configure (-listcmd => \$list)
129 my $listBox = $widget->Subwidget ('slistbox');
130 my $entry = $widget->Subwidget ('entry');
131 my $arrow = $widget->Subwidget ('arrow');
132 my $choices = $widget->Subwidget ('choices');
134 # Turn off bolding on the entry
135 $entry->configure (-font => 'Arial 8');
137 # Allow both widgets to have highlighted parts
138 $listBox->configure (-exportselection => 0);
139 $entry->configure (-exportselection => 0);
141 # Take the arrow out of the focus business - Works on Unix!
142 # Bug on Windows! :-(
143 $arrow->configure (-takefocus => 0);
145 # This gets the mouse wheel working - Works on Unix!
146 # Bug on Windows! :-(
147 $choices->bind ('<Button-4>', sub {$choices->yviewScroll (1,'units')});
148 $choices->bind ('<Button-5>', sub {$choices->yviewScroll (-1,'units')});
149 $choices->bind ('<Button-4>', sub {$choices->yview (1,'units')});
150 $choices->bind ('<Button-5>', sub {$choices->yview (-1,'units')});
159 $entry->bind ($_, [\&handleKeypress, $listBox]);
168 my $widget = $parent->Scrolled ('Listbox',
180 # Make this list resizeable
187 $widget->bind ('<ButtonPress-3>', [ \&popupCCActions, Ev('@') ]);
188 $widget->bind ('<Double-ButtonPress-1>', \&properties);
190 # This gets the mouse wheel working
191 $widget->bind ('<Button-4>', sub {$widget->yviewScroll (1,'units')});
192 $widget->bind ('<Button-5>', sub {$widget->yviewScroll (-1,'units')});
198 my ($list, @value) = @_;
200 $list->insert ('end', $_)
212 $list->delete ('0.0', 'end');
221 unless length $searchPattern;
223 my ($index, @matches);
225 # First filter @values including only matching entries
228 if /$searchPattern/i;
233 # Now determine the first qualifying entry. Note if index is already set then
234 # we do not need to recompute it. It was computed above via a Up or Down key.
235 foreach (0 .. $#matches) {
236 if ($matches[$_] =~ m/$searchPattern/i) {
237 push @values, $matches[$_];
238 $index = $_ unless defined $index;
242 return ($index, @values);
245 sub setDropdown ($$$) {
246 my ($listBox, $entry, $index) = @_;
248 # Set listBox widget. This is actually the dropdown list.
249 $listBox->see ($index);
250 $listBox->activate ($index);
252 # This should be the active entry to set into the entry widget
253 my $currentEntry = $listBox->get ($index);
255 # Set the entry widget. This is the line that the user is typing in
256 $entry->delete (0, 'end');
257 $entry->insert (0, $currentEntry);
259 # Set the selection highlight (if the searchPattern is found)
260 unless (length $searchPattern == 0) {
261 if ($currentEntry =~ /$searchPattern/i) {
262 $entry->selectionClear;
263 $entry->selectionRange ($-[0], $+[0]);
264 $entry->icursor ($+[0]);
272 my ($entry, $listBox) = @_;
274 my (@matches, $match, $index);
276 # This is ugly but works
277 my $browseEntry = $listBox->parent->parent;
279 my $key = $entry->XEvent->A;
280 my $keysym = $entry->XEvent->K;
282 debug "Entry: " . $entry->get;
283 debug "Key: '$key' ($keysym)";
285 # Map Cntl-n and Cntl-p to Down and Up
286 $keysym = 'Down' if ord ($key) == 14;
287 $keysym = 'Up' if ord ($key) == 16;
290 my $Last = $listBox->index ('end') - 1; # Make 0 relative
291 my $active = $listBox->index ('active');
295 if ($keysym eq 'BackSpace') {
296 $searchPattern = substr $searchPattern, 0, -1
297 if length $searchPattern > 0;
299 if (length $searchPattern == 0) {
301 $entry->delete (0, 'end');
303 } elsif ($keysym eq 'Down') {
304 if ($active < $Last) {
305 setDropdown ($listBox, $entry, ++$active);
307 debug "Beep - no more down";
312 } elsif ($keysym eq 'Up') {
314 setDropdown ($listBox, $entry, --$active);
316 debug "Beep - no more up";
321 } elsif ($keysym eq 'Tab') {
322 $entry->selectionClear;
326 return if (!isprint ($key) || !ord ($key));
328 $searchPattern .= $key;
331 debug "searchPattern: $searchPattern";
333 # Get values based on the $browseEntry widget
338 if ($browseEntry == $pvobDropdown) {
339 ($index, @values) = search sort @pvobs;
340 } elsif ($browseEntry == $streamDropdown) {
341 ($index, @values) = search sort @streams;
342 } elsif ($browseEntry == $fromBaselineDropdown) {
343 ($index, @values) = search sort @fromBaselines;
344 } elsif ($browseEntry == $toBaselineDropdown) {
345 ($index, @values) = search sort @toBaselines;
348 if (defined $index) {
349 debug "Index: $index";
350 $match = $values[$index];
352 debug "Index: <undefined>";
353 debug "Length of searchPatern " . length $searchPattern;
354 if (length $searchPattern == 0) {
355 debug "Setting match to blank";
359 debug "making searchPattern shorter";
360 $searchPattern = substr $searchPattern, 0, -1;
361 debug "Length of searchPatern now " . length $searchPattern;
364 } until $match or length $searchPattern == 0;
367 # Setting the listBox clears the active indicator so save it and reset it.
368 $active = $listBox->index ('active');
371 setList $listBox, sort @values;
373 $listBox->activate ($active);
375 if ($searchPattern) {
376 if ($match and $match =~ /$searchPattern/i) {
377 $entry->delete (0, 'end');
378 $entry->selectionClear;
379 $entry->insert (0, $match);
380 $entry->icursor ($+[0]);
381 $entry->selectionRange ($-[0], $+[0]);
383 debug "Beep - no matches";
389 # Now update the assocated listBox.
390 $listBox->selectionClear (0, 'end');
391 $listBox->selectionSet ($index, $index);
393 # Makes it so that the entry selected above is centered in the drop down list.
394 # So if you had say entries like 1, 2, 3, 4,... 10 and you hit '5', you'll see
395 # '5' in the listBox entry but you really want to also shift it so that if you
396 # hit the drop down arrow, 5, is the entry at the top of the drop down list.
397 $listBox->see ($index);
399 debug 'Entry: ' . $entry->get;
407 my $error = $main->DialogBox (
409 -buttons => [ 'OK' ],
412 my $text = $error->add (
423 $text->insert ('end', $msg);
431 my ($msg, $sleep) = @_;
434 $msgWidget->configure (-text => $msg);
444 $msgWidget->configure (-text => '');
452 my $msg = "Utility to select baselines and provide a simple list of "
453 . "activities or file/directory versions that differ between "
454 . "two baselines.\n\n"
455 . "Note you can save this list using the Save button or you can "
456 . "right click on a line and select Clearcase operations.\n\n"
457 . "Written by Andrew DeFaria <Andrew\@ClearSCM.com>";
459 my $about = $main->DialogBox (
460 -title => "About $FindBin::Script V$VERSION",
461 -buttons => [ 'OK' ],
464 my $text = $about->add (
472 # Stop about dialog from resizing
474 '<Configure>' => sub {
475 my $e = $about->XEvent;
477 $about->maxsize ($e->w, $e->h);
478 $about->minsize ($e->w, $e->h);
482 $text->insert ('end', $msg);
489 sub popupCCActions ($) {
490 my ($widget, $xy) = @_;
492 $widget->selectionClear (0, 'end');
494 my $index = $widget->index ($xy);
495 my $event = $widget->XEvent;
497 if (defined $index) {
498 $widget->selectionSet ($index);
500 if ($MODE eq 'versions') {
501 $versionsMenu->post ($widget->rootx + $event->x, $widget->rooty + $event->y);
503 $activitiesMenu->post ($widget->rootx + $event->x, $widget->rooty + $event->y);
511 $main->Busy (-recurse => 1);
525 $main->Busy (-recurse => 1);
527 my ($status, @output) = $Clearcase::CC->execute ('lsvob');
531 foreach (grep { /\(ucmvob/ } @output) {
534 my $pvob = $tokens[0] eq '*'
535 ? Clearcase::vobname ($tokens[1])
536 : Clearcase::vobname ($tokens[0]);
541 clearList $streamDropdown; $SELECTED{stream} = '';
542 $streamDropdown->update;
543 clearList $fromBaselineDropdown; $SELECTED{fromBaseline} = '';
544 $fromBaselineDropdown->update;
545 clearList $toBaselineDropdown; $SELECTED{toBaseline} = '';
546 $toBaselineDropdown->update;
549 clearList $pvobDropdown;
550 setList $pvobDropdown, sort @pvobs;
558 $main->Busy (-recurse => 1);
562 clearList $streamDropdown;
564 $SELECTED{stream} = 'Getting streams...';
566 $streamDropdown->update;
568 my $pvob = Clearcase::vobname ($SELECTED{pvob});
570 $CCDBService->connectToServer
571 or error "Unable to connect to CCDBService", 1;
573 my ($status, $streams) = $CCDBService->execute ("FindStream * $pvob");
575 $CCDBService->disconnectFromServer;
578 Tkerror "Unable to get streams (Status: $status)\n" . join ("\n", @$output);
582 # First empty @streams of the old contents
585 push @streams, $$_{name}
588 clearList $fromBaselineDropdown;
589 clearList $toBaselineDropdown;
591 $SELECTED{fromBaseline} = '';
592 $SELECTED{toBaseline} = '';
594 $fromBaselineDropdown->update;
595 $toBaselineDropdown->update;
599 $SELECTED{stream} = '';
601 setList $streamDropdown, sort @streams;
603 $streamDropdown->focus;
610 sub getBaselines () {
611 $main->Busy (-recurse => 1);
617 clearList $fromBaselineDropdown;
618 clearList $toBaselineDropdown;
620 $SELECTED{fromBaseline} = 'Getting baselines...';
621 $SELECTED{toBaseline} = 'Getting baselines...';
623 $fromBaselineDropdown->update;
624 $toBaselineDropdown->update;
626 ($status, @fromBaselines) = $Clearcase::CC->execute
627 ("lsbl -short -stream $SELECTED{stream}\@$Clearcase::VOBTAG_PREFIX$SELECTED{pvob}");
629 @toBaselines = @fromBaselines;
631 clearList $fromBaselineDropdown;
632 clearList $toBaselineDropdown;
634 $SELECTED{fromBaseline} = '';
635 $SELECTED{toBaseline} = '';
637 $fromBaselineDropdown->update;
638 $toBaselineDropdown->update;
642 setList $fromBaselineDropdown, sort @fromBaselines;
643 setList $toBaselineDropdown, sort @toBaselines;
652 ['Text Files', '.txt', 'TEXT'],
656 my $filename = $main->getSaveFile (
657 -filetype => \@types,
658 -initialfile => "$SELECTED{fromBaseline}.$SELECTED{toBaseline}.diffs",
659 -defaultextension => '.txt',
662 return unless $filename;
664 open my $file, '>', $filename
665 or Tkmsg "Unable to open $filename for writing - $!", -1
668 foreach ($output->get (0, 'end')) {
687 local $SIG{CLD} = \&childDeath;
688 local $SIG{CHLD} = \&childDeath;
691 my ($cmd, $parm1, $parm2) = @_;
694 my $selected = $output->curselection;
699 my $line = $output->get ($selected);
701 if ($MODE eq 'versions') {
702 # Need to add on the view tag prefix
703 $cmd .= " $Clearcase::VIEWTAG_PREFIX/" . $::view->tag . $line;
705 $cmd .= " activity:$line\@";
706 $cmd .= Clearcase::vobtag $SELECTED{pvob};
709 $cmd .= " $parm1 $parm2";
712 $main->Busy (-recurse => 1);
714 if ($ARCH eq 'windows' or $ARCH eq 'cygwin') {
715 $Clearcase::CC->execute ($cmd);
717 # Use fork/exec to allow CC processes to not cause us to block
719 $Clearcase::CC->execute ($cmd);
729 sub findVersion ($$) {
730 my ($element, $baseline) = @_;
732 my $cmd = 'find ' . substr ($element, 1) . ' -directory ';
733 $cmd .= "-version 'lbtype($baseline)' -print";
735 my ($status, @output) = $Clearcase::CC->execute ($cmd);
738 my $msg = "Unable to determine the version for $element ($baseline)";
740 Tkerror join ("\n", "$msg (Status: $status)", "\n", @output);
745 # Change these silly '\'s -> '/'s
746 $output[0] =~ s/\\/\//g;
750 if ($output[0] =~ /.*$Clearcase::SFX(.*)/) {
757 sub compareToPrev () {
758 my $selected = $output->curselection;
763 my $element = $output->get ($selected);
765 # Need to add on the view tag prefix
766 my $element1 = "$Clearcase::VIEWTAG_PREFIX/" . $::view->tag . $element;
767 my $element2 = "$Clearcase::VIEWTAG_PREFIX/" . $::view->tag . $element;
769 # Get into the view context
770 my $view_context = $Clearcase::VIEWTAG_PREFIX . '/' . $::view->tag;
773 # For my Cygwin environment - translate that path back into a Windows path
774 if ($ARCH eq 'cygwin') {
775 my @cwd = `cygpath -w $cwd`;
781 my ($status, @output) = $Clearcase::CC->execute ("cd \"$view_context\"");
783 Tkerror "Unable to set view context to $view_context (Status: $status)" .
789 # Determine from baseline version
790 $version = findVersion $element, $SELECTED{fromBaseline};
791 $element1 .= "$Clearcase::SFX$version";
793 # Determine to baseline version
794 $version = findVersion $element, $SELECTED{toBaseline};
795 $element2 .= "$Clearcase::SFX$version";
797 ccexec 'diff -g', $element1, $element2;
815 ccexec 'describe -g';
820 sub displayLines () {
823 my @lines = keys %LINES;
825 if ($MODE eq 'activities') {
826 @lines = grep {!/(deliver|rebase|tlmerge|integrate)/} @lines
827 unless $INTEGRATIONACTIVITIES;
830 setList $output, sort @lines;
832 my $msg = @lines > 0 ? @lines : 'No';
833 $msg .= $MODE eq 'versions' ? ' Element' : ' Activit';
835 if ($MODE eq 'versions') {
861 $main = MainWindow->new;
864 $main->iconimage ($main->Photo (-file => "$FindBin::Bin/diffbl.gif"))
865 if -f "$FindBin::Bin/diffbl.gif";
867 my $WIDTH = (length ($TITLE) + 1) * 10;
869 $main->geometry ("${WIDTH}x600");
870 $main->title ("$FindBin::Script V$VERSION");
874 for (my $i = 0; $i < 9; $i++) {
875 $frame[$i] = $main->Frame->pack;
878 # Create versions popup menu
879 $versionsMenu = $main->Menu (
885 -label => 'Compare to Prev',
886 -command => \&compareToPrev,
891 -command => \&history,
895 -label => 'Version Tree',
896 -command => \&versionTree,
900 -label => 'Properties',
901 -font => 'Arial 8 bold',
902 -command => \&properties,
905 # Create activities popup menu
906 $activitiesMenu = $main->Menu (
910 $activitiesMenu->add (
912 -label => 'Show Contributing Activities',
914 -command => [ \&Tkerror, "Unimplemented" ],
916 $activitiesMenu->add (
918 -label => 'Checkin All',
920 -command => [ \&Tkerror, "Unimplemented" ],
922 $activitiesMenu->add (
924 -label => 'Finish Activity',
926 -command => [ \&Tkerror, "Unimplemented" ],
928 $activitiesMenu->add (
930 -label => 'Properties',
931 -font => 'Arial 8 bold',
932 -command => \&properties,
936 -font => 'Arial 10 bold',
941 $pvobDropdown = createDropdown (
949 # Remove the Leave binding from $pvobDropDown
950 $pvobDropdown->bind ('<FocusOut>', undef);
952 $streamDropdown = createDropdown (
959 $streamDropdown->bind ('<FocusIn>', \&setFocus);
961 $fromBaselineDropdown = createDropdown (
964 \$SELECTED{fromBaseline},
967 $fromBaselineDropdown->bind ('<FocusIn>', \&setFocus);
969 $toBaselineDropdown = createDropdown (
972 \$SELECTED{toBaseline},
975 $toBaselineDropdown->bind ('<FocusIn>', \&setFocus);
979 -font => 'Arial 8 bold',
985 my $versionsToggle = $frame[5]->Radiobutton (
987 -value => 'versions',
989 -command => \&::compareBaselines,
995 my $activitiesToggle = $frame[5]->Radiobutton (
996 -text => 'Activities',
997 -value => 'activities',
999 -command => \&::compareBaselines,
1006 # Toggle on activities
1007 $activitiesToggle->select;
1009 $integrationActivitiesCheck = $frame[5]->Checkbutton (
1010 -text => 'Integration activities',
1011 -variable => \$INTEGRATIONACTIVITIES,
1012 -command => \&displayLines,
1019 $output = createList $frame[6];
1021 $msgWidget = $frame[7]->Label (
1022 -font => 'Arial 8 bold',
1025 createButton $frame[8], 'About', \&about;
1026 $compareButton = createButton $frame[8], 'Compare', \&::compareBaselines;
1027 createButton $frame[8], 'Save', \&saveList;
1028 createButton $frame[8], 'Exit', \&exit;
1030 # Now populate the streams