source: OFFICIAL/FCM_V1.3/bin/fcm_gui @ 7

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

creation de larborescence
File size: 34.9 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 a graphical tool to resolve conflicts in 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    TOOL    => 'graphical',
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# List of diff display options
270my %diff_display_opt = (
271  default   => 'Default mode',
272  graphical => 'Graphical tool',
273  trac      => 'Trac (only for diff relative to the base of the branch)',
274);
275
276# Text in the status bar
277my $statustext = '';
278
279# ------------------------------------------------------------------------------
280
281my $mw = MainWindow->new ();
282
283my $mw_title = 'FCM GUI';
284$mw->title ($mw_title);
285
286# Frame containing subcommand selection buttons
287my $top_f = $mw->Frame ()->grid (
288  '-row'    => 0,
289  '-column' => 0,
290  '-sticky' => 'w',
291);
292
293# Frame containing subcommand options
294my $mid_f = $mw->Frame ()->grid (
295  '-row'    => 1,
296  '-column' => 0,
297  '-sticky' => 'ew',
298);
299
300# Frame containing action buttons
301my $bot_f = $mw->Frame ()->grid (
302  '-row'    => 2,
303  '-column' => 0,
304  '-sticky' => 'ew',
305);
306
307# Text box to display output
308my $out_t  = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid (
309  '-row'    => 3,
310  '-column' => 0,
311  '-sticky' => 'news',
312);
313
314# Text box - allow scroll with mouse wheel
315$out_t->bind (
316  '<4>' => sub {
317    $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif;
318  },
319);
320
321$out_t->bind (
322  '<5>' => sub {
323    $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif;
324  },
325);
326
327# Status bar
328$mw->Label (
329  '-textvariable' => \$statustext,
330  '-relief'       => 'groove',
331)->grid (
332  '-row'    => 4,
333  '-column' => 0,
334  '-sticky' => 'ews',
335);
336
337# Main window grid configure
338{
339  my ($cols, $rows) = $mw->gridSize ();
340  $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1);
341  $mw->gridRowconfigure    ( 3, '-weight' => 1);
342}
343
344# Frame grid configure
345{
346  my ($cols, $rows) = $mid_f->gridSize ();
347  $bot_f->gridColumnconfigure (3, '-weight' => 1);
348}
349
350$mid_f->gridRowconfigure    (0, '-weight' => 1);
351$mid_f->gridColumnconfigure (0, '-weight' => 1);
352
353# ------------------------------------------------------------------------------
354
355# Buttons to select subcommands
356{
357  my $col = 0;
358  for my $name (@subcmds) {
359    $subcmd_b{$name} = $top_f->Button (
360      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
361      '-command' => [\&button_clicked, $name],
362      '-width'   => 8,
363    )->grid (
364      '-row'    => 0,
365      '-column' => $col++,
366      '-sticky' => 'w',
367    );
368
369    $subcmd_b{$name}->bind ('<Enter>', sub {$statustext = $subcmd_help{$name}});
370    $subcmd_b{$name}->bind ('<Leave>', sub {$statustext = ''});
371
372    $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U})
373      if defined $subcmd_bind{$name}{U};
374
375    $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke});
376  }
377}
378
379# ------------------------------------------------------------------------------
380
381# Frames to contain subcommands options
382{
383  my %row = ();
384
385  for my $name (@subcmds) {
386    $subcmd_f{$name} = $mid_f->Frame ();
387    $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1);
388
389    $row{$name} = 0;
390
391    # Widgets common to all sub-commands
392    $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid (
393      '-row'    => $row{$name},
394      '-column' => 0,
395      '-sticky' => 'w',
396    );
397    $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid (
398      '-row'    => $row{$name}++,
399      '-column' => 1,
400      '-sticky' => 'w',
401    );
402  }
403
404  # Widgets common to all sub-commands that apply to working copies
405  for my $name (@wco_subcmds) {
406    my @labtxts = (
407      'Corresponding URL: ',
408      'Working copy top: ',
409      'Corresponding URL: ',
410    );
411    my @varrefs = \(
412      $subcmdvar{URL_CWD},
413      $subcmdvar{WCT},
414      $subcmdvar{URL_WCT},
415    );
416
417    for my $i (0 .. $#varrefs) {
418      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
419        '-row'    => $row{$name},
420        '-column' => 0,
421        '-sticky' => 'w',
422      );
423      $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid (
424        '-row'    => $row{$name}++,
425        '-column' => 1,
426        '-sticky' => 'w',
427      );
428    }
429
430    $subcmd_f{$name}->Checkbutton (
431      '-text'     => 'Apply sub-command to working copy top',
432      '-variable' => \($subcmdvar{$name}{USEWCT}),
433      '-state'    => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'),
434    )->grid (
435      '-row'        => $row{$name}++,
436      '-column'     => 0,
437      '-columnspan' => 2,
438      '-sticky'     => 'w',
439    );
440  }
441
442  # Widget for the Branch sub-command
443  {
444    my $name = 'BRANCH';
445
446    # Radio buttons to select the sub-option of the branch sub-command
447    my $opt_f = $subcmd_f{$name}->Frame ()->grid (
448      '-row'        => $row{$name}++,
449      '-column'     => 0,
450      '-columnspan' => 2,
451      '-sticky'     => 'w',
452    );
453
454    my $col = 0;
455    for my $key (sort keys %branch_opt) {
456      my $opt = lc $key;
457
458      $branch_opt{$key} = $opt_f->Radiobutton (
459        '-text'     => $opt,
460        '-value'    => $opt,
461        '-variable' => \($subcmdvar{$name}{OPT}),
462        '-state'    => 'normal',
463      )->grid (
464        '-row'      => 0,
465        '-column'   => $col++,
466        '-sticky'   => 'w',
467      );
468    }
469
470    # Label and entry box for specifying URL
471    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
472      '-row'    => $row{$name},
473      '-column' => 0,
474      '-sticky' => 'w',
475    );
476    $subcmd_f{$name}->Entry (
477      '-textvariable' => \($subcmdvar{$name}{URL}),
478    )->grid (
479      '-row'    => $row{$name}++,
480      '-column' => 1,
481      '-sticky' => 'ew',
482    );
483
484    # Label and entry box for specifying create branch name
485    $subcmd_f{$name}->Label (
486      '-text' => 'Branch name (create only): ',
487    )->grid (
488      '-row'    => $row{$name},
489      '-column' => 0,
490      '-sticky' => 'w',
491    );
492    $subcmd_f{$name}->Entry (
493      '-textvariable' => \($subcmdvar{$name}{NAME}),
494    )->grid (
495      '-row'    => $row{$name}++,
496      '-column' => 1,
497      '-sticky' => 'ew',
498    );
499
500    # Label and entry box for specifying create branch source revision
501    $subcmd_f{$name}->Label (
502      '-text' => 'Source revision (create/list only): ',
503    )->grid (
504      '-row'    => $row{$name},
505      '-column' => 0,
506      '-sticky' => 'w',
507    );
508    $subcmd_f{$name}->Entry (
509      '-textvariable' => \($subcmdvar{$name}{REV}),
510    )->grid (
511      '-row'    => $row{$name}++,
512      '-column' => 1,
513      '-sticky' => 'ew',
514    );
515
516    # Label and radio buttons box for specifying create branch type
517    $subcmd_f{$name}->Label (
518      '-text' => 'Branch type (create only): ',
519    )->grid (
520      '-row'    => $row{$name},
521      '-column' => 0,
522      '-sticky' => 'w',
523    );
524
525    {
526      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
527        '-row'    => $row{$name}++,
528        '-column' => 1,
529        '-sticky' => 'w',
530      );
531
532      my $col = 0;
533      for my $key (sort keys %branch_type) {
534        my $txt = lc $key;
535        my $opt = $key;
536
537        $branch_opt{$key} = $opt_f->Radiobutton (
538          '-text'     => $txt,
539          '-value'    => $opt,
540          '-variable' => \($subcmdvar{$name}{TYPE}),
541          '-state'    => 'normal',
542        )->grid (
543          '-row'      => 0,
544          '-column'   => $col++,
545          '-sticky'   => 'w',
546        );
547      }
548    }
549
550    # Label and radio buttons box for specifying create source type
551    $subcmd_f{$name}->Label (
552      '-text' => 'Source type (create only): ',
553    )->grid (
554      '-row'    => $row{$name},
555      '-column' => 0,
556      '-sticky' => 'w',
557    );
558
559    {
560      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
561        '-row'    => $row{$name}++,
562        '-column' => 1,
563        '-sticky' => 'w',
564      );
565
566      my $col = 0;
567      for my $key (sort keys %branch_srctype) {
568        my $txt = lc $key;
569        my $opt = lc $key;
570
571        $branch_opt{$key} = $opt_f->Radiobutton (
572          '-text'     => $txt,
573          '-value'    => $opt,
574          '-variable' => \($subcmdvar{$name}{SRCTYPE}),
575          '-state'    => 'normal',
576        )->grid (
577          '-row'      => 0,
578          '-column'   => $col++,
579          '-sticky'   => 'w',
580        );
581      }
582    }
583
584    # Label and radio buttons box for specifying create prefix option
585    $subcmd_f{$name}->Label (
586      '-text' => 'Prefix option (create only): ',
587    )->grid (
588      '-row'    => $row{$name},
589      '-column' => 0,
590      '-sticky' => 'w',
591    );
592
593    {
594      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
595        '-row'    => $row{$name}++,
596        '-column' => 1,
597        '-sticky' => 'w',
598      );
599
600      my $col = 0;
601      for my $key (sort keys %branch_revflag) {
602        my $txt = lc $key;
603        my $opt = $key;
604
605        $branch_opt{$key} = $opt_f->Radiobutton (
606          '-text'     => $txt,
607          '-value'    => $opt,
608          '-variable' => \($subcmdvar{$name}{REVFLAG}),
609          '-state'    => 'normal',
610        )->grid (
611          '-row'      => 0,
612          '-column'   => $col++,
613          '-sticky'   => 'w',
614        );
615      }
616    }
617
618    # Label and entry box for specifying ticket number
619    $subcmd_f{$name}->Label (
620      '-text' => 'Related Trac ticket(s) (create only): ',
621    )->grid (
622      '-row'    => $row{$name},
623      '-column' => 0,
624      '-sticky' => 'w',
625    );
626    $subcmd_f{$name}->Entry (
627      '-textvariable' => \($subcmdvar{$name}{TICKET}),
628    )->grid (
629      '-row'    => $row{$name}++,
630      '-column' => 1,
631      '-sticky' => 'ew',
632    );
633
634    # Check button for info/delete
635    # --show-children, --show-siblings, --show-other, --verbose
636    $subcmd_f{$name}->Label (
637      '-text' => 'Options for info/delete only: ',
638    )->grid (
639      '-row'    => $row{$name},
640      '-column' => 0,
641      '-sticky' => 'w',
642    );
643
644    {
645      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
646        '-row'    => $row{$name}++,
647        '-column' => 1,
648        '-sticky' => 'w',
649      );
650
651      my $col = 0;
652
653      for my $key (sort keys %branch_info_opt) {
654        $opt_f->Checkbutton (
655          '-text'     => $branch_info_opt{$key},
656          '-variable' => \($subcmdvar{$name}{$key}),
657        )->grid (
658          '-row'    => 0,
659          '-column' => $col++,
660          '-sticky' => 'w',
661        );
662      }
663    }
664  }
665
666  # Widget for the Checkout sub-command
667  {
668    my $name = 'CHECKOUT';
669
670    # Label and entry boxes for specifying URL and revision
671    my @labtxts = (
672      'URL: ',
673      'Revision: ',
674      'Path: ',
675    );
676    my @varrefs = \(
677      $subcmdvar{$name}{URL},
678      $subcmdvar{$name}{REV},
679      $subcmdvar{$name}{PATH},
680    );
681
682    for my $i (0 .. $#varrefs) {
683      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
684        '-row'    => $row{$name},
685        '-column' => 0,
686        '-sticky' => 'w',
687      );
688      $subcmd_f{$name}->Entry (
689        '-textvariable' => $varrefs[$i],
690      )->grid (
691        '-row'    => $row{$name}++,
692        '-column' => 1,
693        '-sticky' => 'ew',
694      );
695    }
696  }
697
698  # Widget for the Status sub-command
699  {
700    my $name = 'STATUS';
701
702    # Checkbuttons for various options
703    my @labtxts = (
704      'Display update information',
705      'Print extra information',
706    );
707    my @varrefs = \(
708      $subcmdvar{$name}{UPDATE},
709      $subcmdvar{$name}{VERBOSE},
710    );
711
712    for my $i (0 .. $#varrefs) {
713      $subcmd_f{$name}->Checkbutton (
714        '-text'     => $labtxts[$i],
715        '-variable' => $varrefs[$i],
716      )->grid (
717        '-row'        => $row{$name}++,
718        '-column'     => 0,
719        '-columnspan' => 2,
720        '-sticky'     => 'w',
721      );
722    }
723  }
724
725  # Widget for the Diff sub-command
726  {
727    my $name = 'DIFF';
728
729    my $entry;
730    $subcmd_f{$name}->Checkbutton (
731      '-text'     => 'Show differences relative to the base of the branch',
732      '-variable' => \($subcmdvar{$name}{BRANCH}),
733      '-command'  => sub {
734        $entry->configure (
735          '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
736        );
737      },
738    )->grid (
739      '-row'        => $row{$name}++,
740      '-column'     => 0,
741      '-columnspan' => 2,
742      '-sticky'     => 'w',
743    );
744
745    # Label and radio buttons box for specifying tool
746    $subcmd_f{$name}->Label (
747      '-text' => 'Display diff in: ',
748    )->grid (
749      '-row'    => $row{$name},
750      '-column' => 0,
751      '-sticky' => 'w',
752    );
753
754    {
755      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
756        '-row'    => $row{$name}++,
757        '-column' => 1,
758        '-sticky' => 'w',
759      );
760
761      my $col = 0;
762      for my $key (qw/default graphical trac/) {
763        my $txt = $diff_display_opt{$key};
764        my $opt = $key;
765
766        $branch_opt{$key} = $opt_f->Radiobutton (
767          '-text'     => $txt,
768          '-value'    => $opt,
769          '-variable' => \($subcmdvar{$name}{TOOL}),
770          '-state'    => 'normal',
771        )->grid (
772          '-row'      => 0,
773          '-column'   => $col++,
774          '-sticky'   => 'w',
775        );
776      }
777    }
778
779    $subcmd_f{$name}->Label ('-text' => 'Branch URL')->grid (
780      '-row'    => $row{$name},
781      '-column' => 0,
782      '-sticky' => 'w',
783    );
784
785    $entry = $subcmd_f{$name}->Entry (
786      '-textvariable' => \($subcmdvar{$name}{URL}),
787      '-state'        => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
788    )->grid (
789      '-row'    => $row{$name}++,
790      '-column' => 1,
791      '-sticky' => 'ew',
792    );
793  }
794
795  # Widget for the Add/Delete sub-command
796  for my $name (qw/ADD DELETE/) {
797
798    # Checkbuttons for various options
799    $subcmd_f{$name}->Checkbutton (
800      '-text'     => 'Check for files or directories not under version control',
801      '-variable' => \($subcmdvar{$name}{CHECK}),
802    )->grid (
803      '-row'        => $row{$name}++,
804      '-column'     => 0,
805      '-columnspan' => 2,
806      '-sticky'     => 'w',
807    );
808  }
809
810  # Widget for the Merge sub-command
811  {
812    my $name = 'MERGE';
813
814    # Label and radio buttons box for specifying merge mode
815    $subcmd_f{$name}->Label (
816      '-text' => 'Mode: ',
817    )->grid (
818      '-row'    => $row{$name},
819      '-column' => 0,
820      '-sticky' => 'w',
821    );
822
823    {
824      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
825        '-row'    => $row{$name}++,
826        '-column' => 1,
827        '-sticky' => 'w',
828      );
829
830      my $col = 0;
831      for my $key (qw/automatic custom reverse/) {
832        my $txt = lc $key;
833        my $opt = $key;
834
835        $branch_opt{$key} = $opt_f->Radiobutton (
836          '-text'     => $txt,
837          '-value'    => $opt,
838          '-variable' => \($subcmdvar{$name}{MODE}),
839          '-state'    => 'normal',
840        )->grid (
841          '-row'      => 0,
842          '-column'   => $col++,
843          '-sticky'   => 'w',
844        );
845      }
846    }
847
848    # Check buttons for dry-run
849    $subcmd_f{$name}->Checkbutton (
850      '-text'     => 'Dry run',
851      '-variable' => \($subcmdvar{$name}{DRYRUN}),
852    )->grid (
853      '-row'        => $row{$name}++,
854      '-column'     => 0,
855      '-columnspan' => 2,
856      '-sticky'     => 'w',
857    );
858
859    # Check buttons for verbose mode
860    $subcmd_f{$name}->Checkbutton (
861      '-text'     => 'Print extra information',
862      '-variable' => \($subcmdvar{$name}{VERBOSE}),
863    )->grid (
864      '-row'        => $row{$name}++,
865      '-column'     => 0,
866      '-columnspan' => 2,
867      '-sticky'     => 'w',
868    );
869
870    # Label and entry boxes for specifying merge source
871    $subcmd_f{$name}->Label (
872      '-text' => 'Source (automatic/custom only): ',
873    )->grid (
874      '-row'    => $row{$name},
875      '-column' => 0,
876      '-sticky' => 'w',
877    );
878    $subcmd_f{$name}->Entry (
879      '-textvariable' => \($subcmdvar{$name}{SRC}),
880    )->grid (
881      '-row'    => $row{$name}++,
882      '-column' => 1,
883      '-sticky' => 'ew',
884    );
885
886    # Label and entry boxes for specifying merge revision (range)
887    $subcmd_f{$name}->Label (
888      '-text' => 'Revision (custom/reverse only): ',
889    )->grid (
890      '-row'    => $row{$name},
891      '-column' => 0,
892      '-sticky' => 'w',
893    );
894    $subcmd_f{$name}->Entry (
895      '-textvariable' => \($subcmdvar{$name}{REV}),
896    )->grid (
897      '-row'    => $row{$name}++,
898      '-column' => 1,
899      '-sticky' => 'ew',
900    );
901  }
902
903  # Widget for the Commit sub-command
904  {
905    my $name = 'COMMIT';
906
907    # Checkbuttons for various options
908    $subcmd_f{$name}->Checkbutton (
909      '-text'     => 'Dry run',
910      '-variable' => \($subcmdvar{$name}{DRYRUN}),
911    )->grid (
912      '-row'        => $row{$name}++,
913      '-column'     => 0,
914      '-columnspan' => 2,
915      '-sticky'     => 'w',
916    );
917  }
918
919  # Widget for the Switch sub-command
920  {
921    my $name = 'SWITCH';
922
923    # Label and entry boxes for specifying switch URL
924    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
925      '-row'    => $row{$name},
926      '-column' => 0,
927      '-sticky' => 'w',
928    );
929    $subcmd_f{$name}->Entry (
930      '-textvariable' => \($subcmdvar{$name}{URL}),
931    )->grid (
932      '-row'    => $row{$name}++,
933      '-column' => 1,
934      '-sticky' => 'ew',
935    );
936  }
937
938  # Widgets common to all sub-commands
939  for my $name (@subcmds) {
940    $subcmd_f{$name}->Label ('-text' => 'Other options: ')->grid (
941      '-row'    => $row{$name},
942      '-column' => 0,
943      '-sticky' => 'w',
944    );
945    $subcmd_f{$name}->Entry (
946      '-textvariable' => \($subcmdvar{$name}{OTHER}),
947    )->grid (
948      '-row'    => $row{$name}++,
949      '-column' => 1,
950      '-sticky' => 'ew',
951    );
952  }
953}
954
955# ------------------------------------------------------------------------------
956
957# Buttons to perform main actions
958{
959  my $col = 0;
960  for my $name (qw/QUIT HELP CLEAR RUN/) {
961    $action_b{$name} = $bot_f->Button (
962      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
963      '-command' => [\&button_clicked, $name],
964      '-width'   => 8,
965    )->grid (
966      '-row'    => 0,
967      '-column' => $col++,
968      '-sticky' => ($name eq 'RUN' ? 'ew' : 'w'),
969    );
970
971    $action_b{$name}->bind ('<Enter>', sub {$statustext = $action_help{$name}});
972    $action_b{$name}->bind ('<Leave>', sub {$statustext = ''});
973
974    $action_b{$name}->configure ('-underline' => $action_bind{$name}{U})
975      if defined $action_bind{$name}{U};
976
977    $mw->bind ($action_bind{$name}{KEY}, sub {$action_b{$name}->invoke});
978  }
979}
980
981&change_cwd ($subcmdvar{CWD});
982
983# ------------------------------------------------------------------------------
984
985# Handle the situation when the user attempts to quit the window while a
986# sub-command is running
987
988$mw->protocol ('WM_DELETE_WINDOW', sub {
989  if (defined $cmdpid) {
990    my $ans = $mw->messageBox (
991      '-title'   => $mw_title,
992      '-message' => $selsubcmd . ' is still running. Really quit?',
993      '-type'    => 'YesNo',
994      '-default' => 'No',
995    );
996
997    if ($ans eq 'Yes') {
998      kill 9, $cmdpid; # Need to kill the sub-process before quitting
999
1000    } else {
1001      return; # Do not quit
1002    }
1003  }
1004
1005  exit;
1006});
1007
1008MainLoop;
1009
1010# ------------------------------------------------------------------------------
1011# SYNOPSIS
1012#   $cfg = &main::cfg ();
1013#
1014# DESCRIPTION
1015#   Return the $config variable.
1016# ------------------------------------------------------------------------------
1017
1018sub cfg {
1019  return $config;
1020}
1021
1022# ------------------------------------------------------------------------------
1023# SYNOPSIS
1024#   &change_cwd ($dir);
1025#
1026# DESCRIPTION
1027#   Change current working directory to $dir
1028# ------------------------------------------------------------------------------
1029
1030sub change_cwd {
1031  my $dir = $_[0];
1032  my @allowed_subcmds = (&is_wc ($dir) ? @wc_subcmds : @nwc_subcmds);
1033
1034  for my $subcmd (@subcmds) {
1035    if (grep {$_ eq $subcmd} @allowed_subcmds) {
1036      $subcmd_b{$subcmd}->configure ('-state' => 'normal');
1037
1038    } else {
1039      $subcmd_b{$subcmd}->configure ('-state' => 'disabled');
1040    }
1041  }
1042
1043  &display_subcmd_frame ($allowed_subcmds[0])
1044    if not grep {$_ eq $selsubcmd} @allowed_subcmds;
1045
1046  chdir $dir;
1047  $subcmdvar{CWD} = $dir;
1048
1049  if (&is_wc ($dir)) {
1050    $subcmdvar{WCT}     = &get_wct ($dir);
1051    $subcmdvar{URL_CWD} = &get_url_of_wc ($dir);
1052    $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT});
1053
1054    $branch_opt{INFO}  ->configure ('-state' => 'normal');
1055    $branch_opt{DELETE}->configure ('-state' => 'normal');
1056    $subcmdvar{BRANCH}{OPT} = 'info';
1057
1058  } else {
1059    $branch_opt{INFO}  ->configure ('-state' => 'disabled');
1060    $branch_opt{DELETE}->configure ('-state' => 'disabled');
1061    $subcmdvar{BRANCH}{OPT} = 'create';
1062  }
1063
1064  return;
1065}
1066
1067# ------------------------------------------------------------------------------
1068# SYNOPSIS
1069#   &button_clicked ($name);
1070#
1071# DESCRIPTION
1072#   Call back function to handle a click on a command button named $name.
1073# ------------------------------------------------------------------------------
1074
1075sub button_clicked {
1076  my $name = $_[0];
1077
1078  if (grep {$_ eq $name} keys %subcmd_b) {
1079    &display_subcmd_frame ($name);
1080
1081  } elsif ($name eq 'CLEAR') {
1082    $out_t->delete ('1.0', 'end');
1083
1084  } elsif ($name eq 'QUIT') {
1085    exit;
1086
1087  } elsif ($name eq 'HELP') {
1088    &invoke_cmd ('help ' . lc ($selsubcmd));
1089
1090  } elsif ($name eq 'RUN') {
1091    &invoke_cmd (&setup_cmd ($selsubcmd));
1092
1093  } else {
1094    $out_t->insert ('end', $name . ': function to be implemented' . "\n");
1095    $out_t->yviewMoveto (1);
1096  }
1097
1098  return;
1099}
1100
1101# ------------------------------------------------------------------------------
1102# SYNOPSIS
1103#   &display_subcmd_frame ($name);
1104#
1105# DESCRIPTION
1106#   Change selected subcommand to $name, and display the frame containing the
1107#   widgets for configuring the options and arguments of that subcommand.
1108# ------------------------------------------------------------------------------
1109
1110sub display_subcmd_frame {
1111  my $name = $_[0];
1112
1113  if ($selsubcmd ne $name and not $cmdrunning) {
1114    $subcmd_b{$name     }->configure ('-relief' => 'sunken');
1115    $subcmd_b{$selsubcmd}->configure ('-relief' => 'raised') if $selsubcmd;
1116
1117    $subcmd_f{$name     }->grid ('-sticky' => 'new');
1118    $subcmd_f{$selsubcmd}->gridForget if $selsubcmd;
1119
1120    $selsubcmd = $name;
1121  }
1122
1123  return;
1124}
1125
1126# ------------------------------------------------------------------------------
1127# SYNOPSIS
1128#   $pos = &get_wm_pos ();
1129#
1130# DESCRIPTION
1131#   Returns the position part of the geometry string of the main window.
1132# ------------------------------------------------------------------------------
1133
1134sub get_wm_pos {
1135  my $geometry = $mw->geometry ();
1136  $geometry =~ /^=?(?:\d+x\d+)?([+-]\d+[+-]\d+)$/;
1137  return $1;
1138}
1139
1140# ------------------------------------------------------------------------------
1141# SYNOPSIS
1142#   $command = &setup_cmd ($name);
1143#
1144# DESCRIPTION
1145#   Setup the the system command for the sub-command $name.
1146# ------------------------------------------------------------------------------
1147
1148sub setup_cmd {
1149  my $name = $_[0];
1150  my $cmd  = '';
1151
1152  if ($name eq 'BRANCH') {
1153    $cmd .= lc ($name);
1154    if ($subcmdvar{$name}{OPT} eq 'create') {
1155      $cmd .= ' -c --svn-non-interactive';
1156      $cmd .= ' -n '     . $subcmdvar{$name}{NAME} if $subcmdvar{$name}{NAME};
1157      $cmd .= ' -t '     . $subcmdvar{$name}{TYPE};
1158      $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG};
1159      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1160      $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET};
1161      $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch';
1162
1163    } elsif ($subcmdvar{$name}{OPT} eq 'delete') {
1164      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1165      $cmd .= ' -d --svn-non-interactive';
1166
1167    } elsif ($subcmdvar{$name}{OPT} eq 'list') {
1168      $cmd .= ' -l';
1169      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1170
1171    } else {
1172      $cmd .= ' -i';
1173      $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD};
1174      $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB};
1175      $cmd .= ' --show-other'    if $subcmdvar{$name}{S_OTH};
1176      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1177    }
1178    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
1179    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1180
1181  } elsif ($name eq 'CHECKOUT') {
1182    $cmd .= lc ($name);
1183    $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1184    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1185    $cmd .= ' ' . $subcmdvar{$name}{URL};
1186    $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH};
1187
1188  } elsif ($name eq 'STATUS') {
1189    $cmd .= lc ($name);
1190    $cmd .= ' -u' if $subcmdvar{$name}{UPDATE};
1191    $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1192    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1193
1194  } elsif ($name eq 'DIFF') {
1195    $cmd .= lc ($name);
1196    $cmd .= ' -g' if $subcmdvar{$name}{TOOL} eq 'graphical';
1197
1198    if ($subcmdvar{$name}{BRANCH}) {
1199      $cmd .= ' -b';
1200      $cmd .= ' -t' if $subcmdvar{$name}{TOOL} eq 'trac';
1201      $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
1202    }
1203
1204    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1205
1206  } elsif ($name eq 'ADD' or $name eq 'DELETE') {
1207    $cmd .= lc ($name);
1208    $cmd .= ' -c' if $subcmdvar{$name}{CHECK};
1209    $cmd .= ' --non-interactive'
1210      if $name eq 'DELETE' and not $subcmdvar{$name}{CHECK};
1211    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1212
1213  } elsif ($name eq 'MERGE') {
1214    $cmd .= lc ($name);
1215
1216    if ($subcmdvar{$name}{MODE} ne 'automatic') {
1217      $cmd .= ' --' . $subcmdvar{$name}{MODE};
1218      $cmd .= ' --revision ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1219    }
1220
1221    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
1222    $cmd .= ' -v'        if $subcmdvar{$name}{VERBOSE};
1223    $cmd .= ' ' . $subcmdvar{$name}{SRC}   if $subcmdvar{$name}{SRC};
1224    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1225
1226  } elsif ($name eq 'CONFLICTS') {
1227    $cmd .= lc ($name);
1228    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1229
1230  } elsif ($name eq 'COMMIT') {
1231    $cmd .= lc ($name);
1232    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
1233    $cmd .= ' --svn-non-interactive';
1234    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1235
1236  } elsif ($name eq 'SWITCH') {
1237    $cmd .= lc ($name);
1238    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
1239    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1240
1241  } elsif ($name eq 'UPDATE') {
1242    $cmd .= lc ($name);
1243    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1244
1245  }
1246
1247  return $cmd;
1248}
1249
1250# ------------------------------------------------------------------------------
1251# SYNOPSIS
1252#   &invoke_cmd ($cmd);
1253#
1254# DESCRIPTION
1255#   Invoke the command $cmd.
1256# ------------------------------------------------------------------------------
1257
1258sub invoke_cmd {
1259  my $cmd      = $_[0];
1260  return unless $cmd;
1261
1262  my $disp_cmd = 'fcm ' . $cmd;
1263  $cmd         = (index ($cmd, 'help ') == 0)
1264                 ? $disp_cmd
1265                 : ('fcm_gui_internal ' . &get_wm_pos () . ' ' . $cmd);
1266
1267  # Change directory to working copy top if necessary
1268  if ($subcmdvar{$selsubcmd}{USEWCT} and $subcmdvar{WCT} ne $subcmdvar{CWD}) {
1269    chdir $subcmdvar{WCT};
1270    $out_t->insert ('end', 'cd ' . $subcmdvar{WCT} . "\n");
1271    $out_t->yviewMoveto (1);
1272  }
1273
1274  # Report start of command
1275  $out_t->insert ('end', timestamp_command ($disp_cmd, 'Start'));
1276  $out_t->yviewMoveto (1);
1277
1278  # Open the command as a pipe
1279  if ($cmdpid = open CMD, '-|', $cmd . ' 2>&1') {
1280    # Disable all action buttons
1281    $action_b{$_}->configure ('-state' => 'disabled') for (keys %action_b);
1282    $cmdrunning = 1;
1283
1284    # Set up a file event to read output from the command
1285    $mw->fileevent (\*CMD, readable => sub {
1286      if (sysread CMD, my ($buf), 1024) {
1287        # Insert text into the output text box as it becomes available
1288        $out_t->insert ('end', $buf);
1289        $out_t->yviewMoveto (1);
1290
1291      } else {
1292        # Delete the file event and close the file when the command finishes
1293        $mw->fileevent(\*CMD, readable => '');
1294        close CMD;
1295        $cmdpid = undef;
1296
1297        # Check return status
1298        if ($?) {
1299          $out_t->insert (
1300            'end', '"' . $disp_cmd . '" failed (' . $? . ')' . "\n",
1301          );
1302          $out_t->yviewMoveto (1);
1303        }
1304
1305        # Report end of command
1306        $out_t->insert ('end', timestamp_command ($disp_cmd, 'End'));
1307        $out_t->yviewMoveto (1);
1308
1309        # Change back to CWD if necessary
1310        if ($subcmdvar{$selsubcmd}{USEWCT} and
1311            $subcmdvar{WCT} ne $subcmdvar{CWD}) {
1312          chdir $subcmdvar{CWD};
1313          $out_t->insert ('end', 'cd ' . $subcmdvar{CWD} . "\n");
1314          $out_t->yviewMoveto (1);
1315        }
1316
1317        # Enable all action buttons again
1318        $action_b{$_}->configure ('-state' => 'normal') for (keys %action_b);
1319        $cmdrunning = 0;
1320
1321        # If the command is "checkout", change directory to working copy
1322        if (lc ($selsubcmd) eq 'checkout') {
1323          my $url = expand_url_keyword (URL => $subcmdvar{CHECKOUT}{URL});
1324          my $dir = $subcmdvar{CHECKOUT}{PATH}
1325                  ? $subcmdvar{CHECKOUT}{PATH}
1326                  : basename $url;
1327          $dir    = File::Spec->rel2abs ($dir);
1328          &change_cwd ($dir);
1329
1330        # If the command is "switch", change URL
1331        } elsif (lc ($selsubcmd) eq 'switch') {
1332          $subcmdvar{URL_CWD} = &get_url_of_wc ($subcmdvar{CWD}, 1);
1333          $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}, 1);
1334        }
1335      }
1336      1;
1337    });
1338
1339  } else {
1340    $mw->messageBox (
1341      '-title'   => 'Error',
1342      '-message' => 'Error running "' . $cmd . '"',
1343      '-icon'    => 'error',
1344    );
1345  }
1346
1347  return;
1348}
1349
1350# ------------------------------------------------------------------------------
1351
1352__END__
Note: See TracBrowser for help on using the repository browser.