source: PATCHED/FCM_V1.2/bin/fcm_gui @ 2

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

creation de larborescence
File size: 34.1 KB
Line 
1#!/usr/bin/perl
2# ------------------------------------------------------------------------------
3# NAME
4#   fcm_gui
5#
6# SYNOPSIS
7#   fcm_gui [DIR]
8#
9# DESCRIPTION
10#   The fcm_gui command is a simple graphical user interface for some of the
11#   commands of the FCM system. The optional argument DIR modifies the initial
12#   working directory.
13#
14# COPYRIGHT
15#   (C) Crown copyright Met Office. All rights reserved.
16#   For further details please refer to the file COPYRIGHT.txt
17#   which you should have received as part of this distribution.
18# ------------------------------------------------------------------------------
19
20# Standard pragmas
21use warnings;
22use strict;
23
24# Standard modules
25use File::Basename;
26use File::Spec::Functions;
27use Cwd;
28use Tk;
29use Tk::ROText;
30
31# FCM component modules:
32use lib catfile (dirname (dirname ($0)), 'lib');
33use Fcm::Config;
34use Fcm::Util;
35use Fcm::Timer;
36
37# ------------------------------------------------------------------------------
38
39# Argument
40if (@ARGV) {
41  my $dir = shift @ARGV;
42  chdir $dir if -d $dir;
43}
44
45# Get configuration settings
46my $config = Fcm::Config->new ();
47$config->get_config ();
48
49# ------------------------------------------------------------------------------
50
51# FCM subcommands
52my @subcmds = qw/CHECKOUT BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT
53                 UPDATE SWITCH/;
54
55# Subcommands allowed when CWD is not a WC
56my @nwc_subcmds = qw/CHECKOUT BRANCH/;
57
58# Subcommands allowed, when CWD is a WC
59my @wc_subcmds = qw/STATUS BRANCH DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
60                    SWITCH/;
61
62# Subcommands that apply to WC only
63my @wco_subcmds = qw/BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
64                     SWITCH/;
65
66# Subcommands that apply to top level WC only
67my @wcto_subcmds = qw/BRANCH MERGE COMMIT UPDATE SWITCH/;
68
69# Selected subcommand
70my $selsubcmd = '';
71
72# Selected subcommand is running?
73my $cmdrunning = 0;
74
75# PID of running subcommand
76my $cmdpid = undef;
77
78# List of subcommand frames
79my %subcmd_f;
80
81# List of subcommand buttons
82my %subcmd_b;
83
84# List of subcommand button help strings
85my %subcmd_help = (
86  BRANCH    => 'list information about, create or delete a branch.',
87  CHECKOUT  => 'check out a working copy from a repository.',
88  STATUS    => 'print the status of working copy files and directories.',
89  DIFF      => 'display the differences in modified files.',
90  ADD       => 'put files and directories under version control.',
91  DELETE    => 'remove files and directories from version control.',
92  MERGE     => 'merge changes into your working copy.',
93  CONFLICTS => 'use "xxdiff" to resolve any conflicts within your working copy.',
94  COMMIT    => 'send changes from your working copy to the repository.',
95  UPDATE    => 'bring changes from the repository into your working copy.',
96  SWITCH    => 'update your working copy to a different URL.',
97);
98
99for (keys %subcmd_help) {
100  $subcmd_help{$_} = 'Select the "' . lc ($_) . '" sub-command - ' .
101                     $subcmd_help{$_};
102}
103
104# List of subcommand button bindings (key name and underline position)
105my %subcmd_bind = (
106  BRANCH    => {KEY => '<Alt-Key-b>', U => 0},
107  CHECKOUT  => {KEY => '<Alt-Key-o>', U => 5},
108  STATUS    => {KEY => '<Alt-Key-s>', U => 0},
109  DIFF      => {KEY => '<Alt-Key-d>', U => 0},
110  ADD       => {KEY => '<Alt-Key-a>', U => 0},
111  DELETE    => {KEY => '<Alt-Key-t>', U => 4},
112  MERGE     => {KEY => '<Alt-Key-m>', U => 0},
113  CONFLICTS => {KEY => '<Alt-Key-f>', U => 3},
114  COMMIT    => {KEY => '<Alt-Key-c>', U => 0},
115  UPDATE    => {KEY => '<Alt-Key-u>', U => 0},
116  SWITCH    => {KEY => '<Alt-Key-w>', U => 1},
117);
118
119# List of subcommand variables
120my %subcmdvar = (
121  CWD       => cwd (),
122  WCT       => '',
123  CWD_URL   => '',
124  WCT_URL   => '',
125
126  BRANCH    => {
127    OPT     => 'info',
128    URL     => '',
129    NAME    => '',
130    TYPE    => 'DEV',
131    REVFLAG => 'NORMAL',
132    REV     => '',
133    TICKET  => '',
134    SRCTYPE => 'trunk',
135    S_CHD   => 0,
136    S_SIB   => 0,
137    S_OTH   => 0,
138    VERBOSE => 0,
139    OTHER   => '',
140  },
141
142  CHECKOUT  => {
143    URL     => '',
144    REV     => 'HEAD',
145    PATH    => '',
146    OTHER   => '',
147  },
148
149  STATUS    => {
150    USEWCT  => 0,
151    UPDATE  => 0,
152    VERBOSE => 0,
153    OTHER   => '',
154  },
155
156  DIFF      => {
157    USEWCT  => 0,
158    GRAPHIC => 1,
159    BRANCH  => 0,
160    URL     => '',
161    OTHER   => '',
162  },
163
164  ADD       => {
165    USEWCT  => 0,
166    CHECK   => 1,
167    OTHER   => '',
168  },
169
170  DELETE    => {
171    USEWCT  => 0,
172    CHECK   => 1,
173    OTHER   => '',
174  },
175
176  MERGE     => {
177    USEWCT  => 1,
178    SRC     => '',
179    MODE    => 'automatic',
180    DRYRUN  => 0,
181    VERBOSE => 0,
182    REV     => '',
183    OTHER   => '',
184  },
185
186  CONFLICTS => {
187    USEWCT  => 0,
188    OTHER   => '',
189  },
190
191  COMMIT    => {
192    USEWCT  => 1,
193    DRYRUN  => 0,
194    OTHER   => '',
195  },
196
197  UPDATE    => {
198    USEWCT  => 1,
199    OTHER   => '',
200  },
201
202  SWITCH    => {
203    USEWCT  => 1,
204    URL     => '',
205    OTHER   => '',
206  },
207);
208
209# List of action buttons
210my %action_b;
211
212# List of action button help strings
213my %action_help = (
214  QUIT  => 'Quit fcm gui',
215  HELP  => 'Print help to the output text box for the selected sub-command',
216  CLEAR => 'Clear the output text box',
217  RUN   => 'Run the selected sub-command',
218);
219
220# List of action button bindings
221my %action_bind = (
222  QUIT  => {KEY => '<Control-Key-q>', U => undef},
223  HELP  => {KEY => '<F1>'           , U => undef},
224  CLEAR => {KEY => '<Alt-Key-l>'    , U => 1},
225  RUN   => {KEY => '<Alt-Key-r>'    , U => 0},
226);
227
228# List of branch subcommand options
229my %branch_opt = (
230  INFO   => undef,
231  CREATE => undef,
232  DELETE => undef,
233  LIST   => undef,
234);
235
236# List of branch create types
237my %branch_type = (
238  'DEV'         => undef,
239  'DEV::SHARE'  => undef,
240  'TEST'        => undef,
241  'TEST::SHARE' => undef,
242  'PKG'         => undef,
243  'PKG::SHARE'  => undef,
244  'PKG::CONFIG' => undef,
245  'PKG::REL'    => undef,
246);
247
248# List of branch create source type
249my %branch_srctype = (
250  TRUNK  => undef,
251  BRANCH => undef,
252);
253
254# List of branch create revision prefix option
255my %branch_revflag = (
256  NORMAL => undef,
257  NUMBER => undef,
258  NONE   => undef,
259);
260
261# List of branch info/delete options
262my %branch_info_opt = (
263  S_CHD   => 'Show children',
264  S_SIB   => 'Show siblings',
265  S_OTH   => 'Show other',
266  VERBOSE => 'Print extra information',
267);
268
269# Text in the status bar
270my $statustext = '';
271
272# ------------------------------------------------------------------------------
273
274my $mw = MainWindow->new ();
275
276my $mw_title = 'FCM GUI';
277$mw->title ($mw_title);
278
279# Frame containing subcommand selection buttons
280my $top_f = $mw->Frame ()->grid (
281  '-row'    => 0,
282  '-column' => 0,
283  '-sticky' => 'w',
284);
285
286# Frame containing subcommand options
287my $mid_f = $mw->Frame ()->grid (
288  '-row'    => 1,
289  '-column' => 0,
290  '-sticky' => 'ew',
291);
292
293# Frame containing action buttons
294my $bot_f = $mw->Frame ()->grid (
295  '-row'    => 2,
296  '-column' => 0,
297  '-sticky' => 'ew',
298);
299
300# Text box to display output
301my $out_t  = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid (
302  '-row'    => 3,
303  '-column' => 0,
304  '-sticky' => 'news',
305);
306
307# Text box - allow scroll with mouse wheel
308$out_t->bind (
309  '<4>' => sub {
310    $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif;
311  },
312);
313
314$out_t->bind (
315  '<5>' => sub {
316    $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif;
317  },
318);
319
320# Status bar
321$mw->Label (
322  '-textvariable' => \$statustext,
323  '-relief'       => 'groove',
324)->grid (
325  '-row'    => 4,
326  '-column' => 0,
327  '-sticky' => 'ews',
328);
329
330# Main window grid configure
331{
332  my ($cols, $rows) = $mw->gridSize ();
333  $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1);
334  $mw->gridRowconfigure    ( 3, '-weight' => 1);
335}
336
337# Frame grid configure
338{
339  my ($cols, $rows) = $mid_f->gridSize ();
340  $bot_f->gridColumnconfigure (3, '-weight' => 1);
341}
342
343$mid_f->gridRowconfigure    (0, '-weight' => 1);
344$mid_f->gridColumnconfigure (0, '-weight' => 1);
345
346# ------------------------------------------------------------------------------
347
348# Buttons to select subcommands
349{
350  my $col = 0;
351  for my $name (@subcmds) {
352    $subcmd_b{$name} = $top_f->Button (
353      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
354      '-command' => [\&button_clicked, $name],
355      '-width'   => 8,
356    )->grid (
357      '-row'    => 0,
358      '-column' => $col++,
359      '-sticky' => 'w',
360    );
361
362    $subcmd_b{$name}->bind ('<Enter>', sub {$statustext = $subcmd_help{$name}});
363    $subcmd_b{$name}->bind ('<Leave>', sub {$statustext = ''});
364
365    $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U})
366      if defined $subcmd_bind{$name}{U};
367
368    $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke});
369  }
370}
371
372# ------------------------------------------------------------------------------
373
374# Frames to contain subcommands options
375{
376  my %row = ();
377
378  for my $name (@subcmds) {
379    $subcmd_f{$name} = $mid_f->Frame ();
380    $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1);
381
382    $row{$name} = 0;
383
384    # Widgets common to all sub-commands
385    $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid (
386      '-row'    => $row{$name},
387      '-column' => 0,
388      '-sticky' => 'w',
389    );
390    $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid (
391      '-row'    => $row{$name}++,
392      '-column' => 1,
393      '-sticky' => 'w',
394    );
395  }
396
397  # Widgets common to all sub-commands that apply to working copies
398  for my $name (@wco_subcmds) {
399    my @labtxts = (
400      'Corresponding URL: ',
401      'Working copy top: ',
402      'Corresponding URL: ',
403    );
404    my @varrefs = \(
405      $subcmdvar{URL_CWD},
406      $subcmdvar{WCT},
407      $subcmdvar{URL_WCT},
408    );
409
410    for my $i (0 .. $#varrefs) {
411      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
412        '-row'    => $row{$name},
413        '-column' => 0,
414        '-sticky' => 'w',
415      );
416      $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid (
417        '-row'    => $row{$name}++,
418        '-column' => 1,
419        '-sticky' => 'w',
420      );
421    }
422
423    $subcmd_f{$name}->Checkbutton (
424      '-text'     => 'Apply sub-command to working copy top',
425      '-variable' => \($subcmdvar{$name}{USEWCT}),
426      '-state'    => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'),
427    )->grid (
428      '-row'        => $row{$name}++,
429      '-column'     => 0,
430      '-columnspan' => 2,
431      '-sticky'     => 'w',
432    );
433  }
434
435  # Widget for the Branch sub-command
436  {
437    my $name = 'BRANCH';
438
439    # Radio buttons to select the sub-option of the branch sub-command
440    my $opt_f = $subcmd_f{$name}->Frame ()->grid (
441      '-row'        => $row{$name}++,
442      '-column'     => 0,
443      '-columnspan' => 2,
444      '-sticky'     => 'w',
445    );
446
447    my $col = 0;
448    for my $key (sort keys %branch_opt) {
449      my $opt = lc $key;
450
451      $branch_opt{$key} = $opt_f->Radiobutton (
452        '-text'     => $opt,
453        '-value'    => $opt,
454        '-variable' => \($subcmdvar{$name}{OPT}),
455        '-state'    => 'normal',
456      )->grid (
457        '-row'      => 0,
458        '-column'   => $col++,
459        '-sticky'   => 'w',
460      );
461    }
462
463    # Label and entry box for specifying URL
464    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
465      '-row'    => $row{$name},
466      '-column' => 0,
467      '-sticky' => 'w',
468    );
469    $subcmd_f{$name}->Entry (
470      '-textvariable' => \($subcmdvar{$name}{URL}),
471    )->grid (
472      '-row'    => $row{$name}++,
473      '-column' => 1,
474      '-sticky' => 'ew',
475    );
476
477    # Label and entry box for specifying create branch name
478    $subcmd_f{$name}->Label (
479      '-text' => 'Branch name (create only): ',
480    )->grid (
481      '-row'    => $row{$name},
482      '-column' => 0,
483      '-sticky' => 'w',
484    );
485    $subcmd_f{$name}->Entry (
486      '-textvariable' => \($subcmdvar{$name}{NAME}),
487    )->grid (
488      '-row'    => $row{$name}++,
489      '-column' => 1,
490      '-sticky' => 'ew',
491    );
492
493    # Label and entry box for specifying create branch source revision
494    $subcmd_f{$name}->Label (
495      '-text' => 'Source revision (create/list only): ',
496    )->grid (
497      '-row'    => $row{$name},
498      '-column' => 0,
499      '-sticky' => 'w',
500    );
501    $subcmd_f{$name}->Entry (
502      '-textvariable' => \($subcmdvar{$name}{REV}),
503    )->grid (
504      '-row'    => $row{$name}++,
505      '-column' => 1,
506      '-sticky' => 'ew',
507    );
508
509    # Label and radio buttons box for specifying create branch type
510    $subcmd_f{$name}->Label (
511      '-text' => 'Branch type (create only): ',
512    )->grid (
513      '-row'    => $row{$name},
514      '-column' => 0,
515      '-sticky' => 'w',
516    );
517
518    {
519      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
520        '-row'    => $row{$name}++,
521        '-column' => 1,
522        '-sticky' => 'w',
523      );
524
525      my $col = 0;
526      for my $key (sort keys %branch_type) {
527        my $txt = lc $key;
528        my $opt = $key;
529
530        $branch_opt{$key} = $opt_f->Radiobutton (
531          '-text'     => $txt,
532          '-value'    => $opt,
533          '-variable' => \($subcmdvar{$name}{TYPE}),
534          '-state'    => 'normal',
535        )->grid (
536          '-row'      => 0,
537          '-column'   => $col++,
538          '-sticky'   => 'w',
539        );
540      }
541    }
542
543    # Label and radio buttons box for specifying create source type
544    $subcmd_f{$name}->Label (
545      '-text' => 'Source type (create only): ',
546    )->grid (
547      '-row'    => $row{$name},
548      '-column' => 0,
549      '-sticky' => 'w',
550    );
551
552    {
553      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
554        '-row'    => $row{$name}++,
555        '-column' => 1,
556        '-sticky' => 'w',
557      );
558
559      my $col = 0;
560      for my $key (sort keys %branch_srctype) {
561        my $txt = lc $key;
562        my $opt = lc $key;
563
564        $branch_opt{$key} = $opt_f->Radiobutton (
565          '-text'     => $txt,
566          '-value'    => $opt,
567          '-variable' => \($subcmdvar{$name}{SRCTYPE}),
568          '-state'    => 'normal',
569        )->grid (
570          '-row'      => 0,
571          '-column'   => $col++,
572          '-sticky'   => 'w',
573        );
574      }
575    }
576
577    # Label and radio buttons box for specifying create prefix option
578    $subcmd_f{$name}->Label (
579      '-text' => 'Prefix option (create only): ',
580    )->grid (
581      '-row'    => $row{$name},
582      '-column' => 0,
583      '-sticky' => 'w',
584    );
585
586    {
587      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
588        '-row'    => $row{$name}++,
589        '-column' => 1,
590        '-sticky' => 'w',
591      );
592
593      my $col = 0;
594      for my $key (sort keys %branch_revflag) {
595        my $txt = lc $key;
596        my $opt = $key;
597
598        $branch_opt{$key} = $opt_f->Radiobutton (
599          '-text'     => $txt,
600          '-value'    => $opt,
601          '-variable' => \($subcmdvar{$name}{REVFLAG}),
602          '-state'    => 'normal',
603        )->grid (
604          '-row'      => 0,
605          '-column'   => $col++,
606          '-sticky'   => 'w',
607        );
608      }
609    }
610
611    # Label and entry box for specifying ticket number
612    $subcmd_f{$name}->Label (
613      '-text' => 'Related Trac ticket(s) (create only): ',
614    )->grid (
615      '-row'    => $row{$name},
616      '-column' => 0,
617      '-sticky' => 'w',
618    );
619    $subcmd_f{$name}->Entry (
620      '-textvariable' => \($subcmdvar{$name}{TICKET}),
621    )->grid (
622      '-row'    => $row{$name}++,
623      '-column' => 1,
624      '-sticky' => 'ew',
625    );
626
627    # Check button for info/delete
628    # --show-children, --show-siblings, --show-other, --verbose
629    $subcmd_f{$name}->Label (
630      '-text' => 'Options for info/delete only: ',
631    )->grid (
632      '-row'    => $row{$name},
633      '-column' => 0,
634      '-sticky' => 'w',
635    );
636
637    {
638      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
639        '-row'    => $row{$name}++,
640        '-column' => 1,
641        '-sticky' => 'w',
642      );
643
644      my $col = 0;
645
646      for my $key (sort keys %branch_info_opt) {
647        $opt_f->Checkbutton (
648          '-text'     => $branch_info_opt{$key},
649          '-variable' => \($subcmdvar{$name}{$key}),
650        )->grid (
651          '-row'    => 0,
652          '-column' => $col++,
653          '-sticky' => 'w',
654        );
655      }
656    }
657  }
658
659  # Widget for the Checkout sub-command
660  {
661    my $name = 'CHECKOUT';
662
663    # Label and entry boxes for specifying URL and revision
664    my @labtxts = (
665      'URL: ',
666      'Revision: ',
667      'Path: ',
668    );
669    my @varrefs = \(
670      $subcmdvar{$name}{URL},
671      $subcmdvar{$name}{REV},
672      $subcmdvar{$name}{PATH},
673    );
674
675    for my $i (0 .. $#varrefs) {
676      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
677        '-row'    => $row{$name},
678        '-column' => 0,
679        '-sticky' => 'w',
680      );
681      $subcmd_f{$name}->Entry (
682        '-textvariable' => $varrefs[$i],
683      )->grid (
684        '-row'    => $row{$name}++,
685        '-column' => 1,
686        '-sticky' => 'ew',
687      );
688    }
689  }
690
691  # Widget for the Status sub-command
692  {
693    my $name = 'STATUS';
694
695    # Checkbuttons for various options
696    my @labtxts = (
697      'Display update information',
698      'Print extra information',
699    );
700    my @varrefs = \(
701      $subcmdvar{$name}{UPDATE},
702      $subcmdvar{$name}{VERBOSE},
703    );
704
705    for my $i (0 .. $#varrefs) {
706      $subcmd_f{$name}->Checkbutton (
707        '-text'     => $labtxts[$i],
708        '-variable' => $varrefs[$i],
709      )->grid (
710        '-row'        => $row{$name}++,
711        '-column'     => 0,
712        '-columnspan' => 2,
713        '-sticky'     => 'w',
714      );
715    }
716  }
717
718  # Widget for the Diff sub-command
719  {
720    my $name = 'DIFF';
721
722    # Checkbuttons for various options
723    $subcmd_f{$name}->Checkbutton (
724      '-text'     => 'Use xxdiff to display differences',
725      '-variable' => \($subcmdvar{$name}{GRAPHIC}),
726    )->grid (
727      '-row'        => $row{$name}++,
728      '-column'     => 0,
729      '-columnspan' => 2,
730      '-sticky'     => 'w',
731    );
732
733    my $entry;
734    $subcmd_f{$name}->Checkbutton (
735      '-text'     => 'Show differences relative to the base of the branch',
736      '-variable' => \($subcmdvar{$name}{BRANCH}),
737      '-command'  => sub {
738        $entry->configure (
739          '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
740        );
741      },
742    )->grid (
743      '-row'        => $row{$name}++,
744      '-column'     => 0,
745      '-columnspan' => 2,
746      '-sticky'     => 'w',
747    );
748
749    $subcmd_f{$name}->Label ('-text' => 'Branch URL')->grid (
750      '-row'    => $row{$name},
751      '-column' => 0,
752      '-sticky' => 'w',
753    );
754
755    $entry = $subcmd_f{$name}->Entry (
756      '-textvariable' => \($subcmdvar{$name}{URL}),
757      '-state'        => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
758    )->grid (
759      '-row'    => $row{$name}++,
760      '-column' => 1,
761      '-sticky' => 'ew',
762    );
763  }
764
765  # Widget for the Add/Delete sub-command
766  for my $name (qw/ADD DELETE/) {
767
768    # Checkbuttons for various options
769    $subcmd_f{$name}->Checkbutton (
770      '-text'     => 'Check for files or directories not under version control',
771      '-variable' => \($subcmdvar{$name}{CHECK}),
772    )->grid (
773      '-row'        => $row{$name}++,
774      '-column'     => 0,
775      '-columnspan' => 2,
776      '-sticky'     => 'w',
777    );
778  }
779
780  # Widget for the Merge sub-command
781  {
782    my $name = 'MERGE';
783
784    # Label and radio buttons box for specifying merge mode
785    $subcmd_f{$name}->Label (
786      '-text' => 'Mode: ',
787    )->grid (
788      '-row'    => $row{$name},
789      '-column' => 0,
790      '-sticky' => 'w',
791    );
792
793    {
794      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
795        '-row'    => $row{$name}++,
796        '-column' => 1,
797        '-sticky' => 'w',
798      );
799
800      my $col = 0;
801      for my $key (qw/automatic custom reverse/) {
802        my $txt = lc $key;
803        my $opt = $key;
804
805        $branch_opt{$key} = $opt_f->Radiobutton (
806          '-text'     => $txt,
807          '-value'    => $opt,
808          '-variable' => \($subcmdvar{$name}{MODE}),
809          '-state'    => 'normal',
810        )->grid (
811          '-row'      => 0,
812          '-column'   => $col++,
813          '-sticky'   => 'w',
814        );
815      }
816    }
817
818    # Check buttons for dry-run
819    $subcmd_f{$name}->Checkbutton (
820      '-text'     => 'Dry run',
821      '-variable' => \($subcmdvar{$name}{DRYRUN}),
822    )->grid (
823      '-row'        => $row{$name}++,
824      '-column'     => 0,
825      '-columnspan' => 2,
826      '-sticky'     => 'w',
827    );
828
829    # Check buttons for verbose mode
830    $subcmd_f{$name}->Checkbutton (
831      '-text'     => 'Print extra information',
832      '-variable' => \($subcmdvar{$name}{VERBOSE}),
833    )->grid (
834      '-row'        => $row{$name}++,
835      '-column'     => 0,
836      '-columnspan' => 2,
837      '-sticky'     => 'w',
838    );
839
840    # Label and entry boxes for specifying merge source
841    $subcmd_f{$name}->Label (
842      '-text' => 'Source (automatic/custom only): ',
843    )->grid (
844      '-row'    => $row{$name},
845      '-column' => 0,
846      '-sticky' => 'w',
847    );
848    $subcmd_f{$name}->Entry (
849      '-textvariable' => \($subcmdvar{$name}{SRC}),
850    )->grid (
851      '-row'    => $row{$name}++,
852      '-column' => 1,
853      '-sticky' => 'ew',
854    );
855
856    # Label and entry boxes for specifying merge revision (range)
857    $subcmd_f{$name}->Label (
858      '-text' => 'Revision (custom/reverse only): ',
859    )->grid (
860      '-row'    => $row{$name},
861      '-column' => 0,
862      '-sticky' => 'w',
863    );
864    $subcmd_f{$name}->Entry (
865      '-textvariable' => \($subcmdvar{$name}{REV}),
866    )->grid (
867      '-row'    => $row{$name}++,
868      '-column' => 1,
869      '-sticky' => 'ew',
870    );
871  }
872
873  # Widget for the Commit sub-command
874  {
875    my $name = 'COMMIT';
876
877    # Checkbuttons for various options
878    $subcmd_f{$name}->Checkbutton (
879      '-text'     => 'Dry run',
880      '-variable' => \($subcmdvar{$name}{DRYRUN}),
881    )->grid (
882      '-row'        => $row{$name}++,
883      '-column'     => 0,
884      '-columnspan' => 2,
885      '-sticky'     => 'w',
886    );
887  }
888
889  # Widget for the Switch sub-command
890  {
891    my $name = 'SWITCH';
892
893    # Label and entry boxes for specifying switch URL
894    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
895      '-row'    => $row{$name},
896      '-column' => 0,
897      '-sticky' => 'w',
898    );
899    $subcmd_f{$name}->Entry (
900      '-textvariable' => \($subcmdvar{$name}{URL}),
901    )->grid (
902      '-row'    => $row{$name}++,
903      '-column' => 1,
904      '-sticky' => 'ew',
905    );
906  }
907
908  # Widgets common to all sub-commands
909  for my $name (@subcmds) {
910    $subcmd_f{$name}->Label ('-text' => 'Other options: ')->grid (
911      '-row'    => $row{$name},
912      '-column' => 0,
913      '-sticky' => 'w',
914    );
915    $subcmd_f{$name}->Entry (
916      '-textvariable' => \($subcmdvar{$name}{OTHER}),
917    )->grid (
918      '-row'    => $row{$name}++,
919      '-column' => 1,
920      '-sticky' => 'ew',
921    );
922  }
923}
924
925# ------------------------------------------------------------------------------
926
927# Buttons to perform main actions
928{
929  my $col = 0;
930  for my $name (qw/QUIT HELP CLEAR RUN/) {
931    $action_b{$name} = $bot_f->Button (
932      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
933      '-command' => [\&button_clicked, $name],
934      '-width'   => 8,
935    )->grid (
936      '-row'    => 0,
937      '-column' => $col++,
938      '-sticky' => ($name eq 'RUN' ? 'ew' : 'w'),
939    );
940
941    $action_b{$name}->bind ('<Enter>', sub {$statustext = $action_help{$name}});
942    $action_b{$name}->bind ('<Leave>', sub {$statustext = ''});
943
944    $action_b{$name}->configure ('-underline' => $action_bind{$name}{U})
945      if defined $action_bind{$name}{U};
946
947    $mw->bind ($action_bind{$name}{KEY}, sub {$action_b{$name}->invoke});
948  }
949}
950
951&change_cwd ($subcmdvar{CWD});
952
953# ------------------------------------------------------------------------------
954
955# Handle the situation when the user attempts to quit the window while a
956# sub-command is running
957
958$mw->protocol ('WM_DELETE_WINDOW', sub {
959  if (defined $cmdpid) {
960    my $ans = $mw->messageBox (
961      '-title'   => $mw_title,
962      '-message' => $selsubcmd . ' is still running. Really quit?',
963      '-type'    => 'YesNo',
964      '-default' => 'No',
965    );
966
967    if ($ans eq 'Yes') {
968      kill 9, $cmdpid; # Need to kill the sub-process before quitting
969
970    } else {
971      return; # Do not quit
972    }
973  }
974
975  exit;
976});
977
978MainLoop;
979
980# ------------------------------------------------------------------------------
981# SYNOPSIS
982#   $cfg = &main::cfg ();
983#
984# DESCRIPTION
985#   Return the $config variable.
986# ------------------------------------------------------------------------------
987
988sub cfg {
989  return $config;
990}
991
992# ------------------------------------------------------------------------------
993# SYNOPSIS
994#   &change_cwd ($dir);
995#
996# DESCRIPTION
997#   Change current working directory to $dir
998# ------------------------------------------------------------------------------
999
1000sub change_cwd {
1001  my $dir = $_[0];
1002  my @allowed_subcmds = (&is_wc ($dir) ? @wc_subcmds : @nwc_subcmds);
1003
1004  for my $subcmd (@subcmds) {
1005    if (grep {$_ eq $subcmd} @allowed_subcmds) {
1006      $subcmd_b{$subcmd}->configure ('-state' => 'normal');
1007
1008    } else {
1009      $subcmd_b{$subcmd}->configure ('-state' => 'disabled');
1010    }
1011  }
1012
1013  &display_subcmd_frame ($allowed_subcmds[0])
1014    if not grep {$_ eq $selsubcmd} @allowed_subcmds;
1015
1016  chdir $dir;
1017  $subcmdvar{CWD} = $dir;
1018
1019  if (&is_wc ($dir)) {
1020    $subcmdvar{WCT}     = &get_wct ($dir);
1021    $subcmdvar{URL_CWD} = &get_url_of_wc ($dir);
1022    $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT});
1023
1024    $branch_opt{INFO}  ->configure ('-state' => 'normal');
1025    $branch_opt{DELETE}->configure ('-state' => 'normal');
1026    $subcmdvar{BRANCH}{OPT} = 'info';
1027
1028  } else {
1029    $branch_opt{INFO}  ->configure ('-state' => 'disabled');
1030    $branch_opt{DELETE}->configure ('-state' => 'disabled');
1031    $subcmdvar{BRANCH}{OPT} = 'create';
1032  }
1033
1034  return;
1035}
1036
1037# ------------------------------------------------------------------------------
1038# SYNOPSIS
1039#   &button_clicked ($name);
1040#
1041# DESCRIPTION
1042#   Call back function to handle a click on a command button named $name.
1043# ------------------------------------------------------------------------------
1044
1045sub button_clicked {
1046  my $name = $_[0];
1047
1048  if (grep {$_ eq $name} keys %subcmd_b) {
1049    &display_subcmd_frame ($name);
1050
1051  } elsif ($name eq 'CLEAR') {
1052    $out_t->delete ('1.0', 'end');
1053
1054  } elsif ($name eq 'QUIT') {
1055    exit;
1056
1057  } elsif ($name eq 'HELP') {
1058    &invoke_cmd ('help ' . lc ($selsubcmd));
1059
1060  } elsif ($name eq 'RUN') {
1061    &invoke_cmd (&setup_cmd ($selsubcmd));
1062
1063  } else {
1064    $out_t->insert ('end', $name . ': function to be implemented' . "\n");
1065    $out_t->yviewMoveto (1);
1066  }
1067
1068  return;
1069}
1070
1071# ------------------------------------------------------------------------------
1072# SYNOPSIS
1073#   &display_subcmd_frame ($name);
1074#
1075# DESCRIPTION
1076#   Change selected subcommand to $name, and display the frame containing the
1077#   widgets for configuring the options and arguments of that subcommand.
1078# ------------------------------------------------------------------------------
1079
1080sub display_subcmd_frame {
1081  my $name = $_[0];
1082
1083  if ($selsubcmd ne $name and not $cmdrunning) {
1084    $subcmd_b{$name     }->configure ('-relief' => 'sunken');
1085    $subcmd_b{$selsubcmd}->configure ('-relief' => 'raised') if $selsubcmd;
1086
1087    $subcmd_f{$name     }->grid ('-sticky' => 'new');
1088    $subcmd_f{$selsubcmd}->gridForget if $selsubcmd;
1089
1090    $selsubcmd = $name;
1091  }
1092
1093  return;
1094}
1095
1096# ------------------------------------------------------------------------------
1097# SYNOPSIS
1098#   $pos = &get_wm_pos ();
1099#
1100# DESCRIPTION
1101#   Returns the position part of the geometry string of the main window.
1102# ------------------------------------------------------------------------------
1103
1104sub get_wm_pos {
1105  my $geometry = $mw->geometry ();
1106  $geometry =~ /^=?(?:\d+x\d+)?([+-]\d+[+-]\d+)$/;
1107  return $1;
1108}
1109
1110# ------------------------------------------------------------------------------
1111# SYNOPSIS
1112#   $command = &setup_cmd ($name);
1113#
1114# DESCRIPTION
1115#   Setup the the system command for the sub-command $name.
1116# ------------------------------------------------------------------------------
1117
1118sub setup_cmd {
1119  my $name = $_[0];
1120  my $cmd  = '';
1121
1122  if ($name eq 'BRANCH') {
1123    $cmd .= lc ($name);
1124    if ($subcmdvar{$name}{OPT} eq 'create') {
1125      $cmd .= ' -c --svn-non-interactive';
1126      $cmd .= ' -n '     . $subcmdvar{$name}{NAME} if $subcmdvar{$name}{NAME};
1127      $cmd .= ' -t '     . $subcmdvar{$name}{TYPE};
1128      $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG};
1129      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1130      $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET};
1131      $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch';
1132
1133    } elsif ($subcmdvar{$name}{OPT} eq 'delete') {
1134      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1135      $cmd .= ' -d --svn-non-interactive';
1136
1137    } elsif ($subcmdvar{$name}{OPT} eq 'list') {
1138      $cmd .= ' -l';
1139      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1140
1141    } else {
1142      $cmd .= ' -i';
1143      $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD};
1144      $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB};
1145      $cmd .= ' --show-other'    if $subcmdvar{$name}{S_OTH};
1146      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1147    }
1148    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
1149    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1150
1151  } elsif ($name eq 'CHECKOUT') {
1152    $cmd .= lc ($name);
1153    $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1154    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1155    $cmd .= ' ' . $subcmdvar{$name}{URL};
1156    $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH};
1157
1158  } elsif ($name eq 'STATUS') {
1159    $cmd .= lc ($name);
1160    $cmd .= ' -u' if $subcmdvar{$name}{UPDATE};
1161    $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1162    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1163
1164  } elsif ($name eq 'DIFF') {
1165    $cmd .= lc ($name);
1166    $cmd .= ' -g' if $subcmdvar{$name}{GRAPHIC};
1167
1168    if ($subcmdvar{$name}{BRANCH}) {
1169      $cmd .= ' -b';
1170      $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
1171    }
1172
1173    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1174
1175  } elsif ($name eq 'ADD' or $name eq 'DELETE') {
1176    $cmd .= lc ($name);
1177    $cmd .= ' -c' if $subcmdvar{$name}{CHECK};
1178    $cmd .= ' --non-interactive'
1179      if $name eq 'DELETE' and not $subcmdvar{$name}{CHECK};
1180    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1181
1182  } elsif ($name eq 'MERGE') {
1183    $cmd .= lc ($name);
1184
1185    if ($subcmdvar{$name}{MODE} ne 'automatic') {
1186      $cmd .= ' --' . $subcmdvar{$name}{MODE};
1187      $cmd .= ' --revision ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1188    }
1189
1190    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
1191    $cmd .= ' -v'        if $subcmdvar{$name}{VERBOSE};
1192    $cmd .= ' ' . $subcmdvar{$name}{SRC}   if $subcmdvar{$name}{SRC};
1193    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1194
1195  } elsif ($name eq 'CONFLICTS') {
1196    $cmd .= lc ($name);
1197    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1198
1199  } elsif ($name eq 'COMMIT') {
1200    $cmd .= lc ($name);
1201    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
1202    $cmd .= ' --svn-non-interactive';
1203    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1204
1205  } elsif ($name eq 'SWITCH') {
1206    $cmd .= lc ($name);
1207    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
1208    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1209
1210  } elsif ($name eq 'UPDATE') {
1211    $cmd .= lc ($name);
1212    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1213
1214  }
1215
1216  return $cmd;
1217}
1218
1219# ------------------------------------------------------------------------------
1220# SYNOPSIS
1221#   &invoke_cmd ($cmd);
1222#
1223# DESCRIPTION
1224#   Invoke the command $cmd.
1225# ------------------------------------------------------------------------------
1226
1227sub invoke_cmd {
1228  my $cmd      = $_[0];
1229  return unless $cmd;
1230
1231  my $disp_cmd = 'fcm ' . $cmd;
1232  $cmd         = (index ($cmd, 'help ') == 0)
1233                 ? $disp_cmd
1234                 : ('fcm_gui_internal ' . &get_wm_pos () . ' ' . $cmd);
1235
1236  # Change directory to working copy top if necessary
1237  if ($subcmdvar{$selsubcmd}{USEWCT} and $subcmdvar{WCT} ne $subcmdvar{CWD}) {
1238    chdir $subcmdvar{WCT};
1239    $out_t->insert ('end', 'cd ' . $subcmdvar{WCT} . "\n");
1240    $out_t->yviewMoveto (1);
1241  }
1242
1243  # Report start of command
1244  $out_t->insert ('end', timestamp_command ($disp_cmd, 'Start'));
1245  $out_t->yviewMoveto (1);
1246
1247  # Open the command as a pipe
1248  if ($cmdpid = open CMD, '-|', $cmd . ' 2>&1') {
1249    # Disable all action buttons
1250    $action_b{$_}->configure ('-state' => 'disabled') for (keys %action_b);
1251    $cmdrunning = 1;
1252
1253    # Set up a file event to read output from the command
1254    $mw->fileevent (\*CMD, readable => sub {
1255      if (sysread CMD, my ($buf), 1024) {
1256        # Insert text into the output text box as it becomes available
1257        $out_t->insert ('end', $buf);
1258        $out_t->yviewMoveto (1);
1259
1260      } else {
1261        # Delete the file event and close the file when the command finishes
1262        $mw->fileevent(\*CMD, readable => '');
1263        close CMD;
1264        $cmdpid = undef;
1265
1266        # Check return status
1267        if ($?) {
1268          $out_t->insert (
1269            'end', '"' . $disp_cmd . '" failed (' . $? . ')' . "\n",
1270          );
1271          $out_t->yviewMoveto (1);
1272        }
1273
1274        # Report end of command
1275        $out_t->insert ('end', timestamp_command ($disp_cmd, 'End'));
1276        $out_t->yviewMoveto (1);
1277
1278        # Change back to CWD if necessary
1279        if ($subcmdvar{$selsubcmd}{USEWCT} and
1280            $subcmdvar{WCT} ne $subcmdvar{CWD}) {
1281          chdir $subcmdvar{CWD};
1282          $out_t->insert ('end', 'cd ' . $subcmdvar{CWD} . "\n");
1283          $out_t->yviewMoveto (1);
1284        }
1285
1286        # Enable all action buttons again
1287        $action_b{$_}->configure ('-state' => 'normal') for (keys %action_b);
1288        $cmdrunning = 0;
1289
1290        # If the command is "checkout", change directory to working copy
1291        if (lc ($selsubcmd) eq 'checkout') {
1292          my $url = expand_url_keyword (URL => $subcmdvar{CHECKOUT}{URL});
1293          my $dir = $subcmdvar{CHECKOUT}{PATH}
1294                  ? $subcmdvar{CHECKOUT}{PATH}
1295                  : basename $url;
1296          $dir    = File::Spec->rel2abs ($dir);
1297          &change_cwd ($dir);
1298
1299        # If the command is "switch", change URL
1300        } elsif (lc ($selsubcmd) eq 'switch') {
1301          $subcmdvar{URL_CWD} = &get_url_of_wc ($subcmdvar{CWD}, 1);
1302          $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}, 1);
1303        }
1304      }
1305      1;
1306    });
1307
1308  } else {
1309    $mw->messageBox (
1310      '-title'   => 'Error',
1311      '-message' => 'Error running "' . $cmd . '"',
1312      '-icon'    => 'error',
1313    );
1314  }
1315
1316  return;
1317}
1318
1319# ------------------------------------------------------------------------------
1320
1321__END__
Note: See TracBrowser for help on using the repository browser.