New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
fcm_gui in branches/UKMO/dev_r5518_MEDUSA_optim_RH/NEMOGCM/EXTERNAL/fcm/bin – NEMO

source: branches/UKMO/dev_r5518_MEDUSA_optim_RH/NEMOGCM/EXTERNAL/fcm/bin/fcm_gui @ 7692

Last change on this file since 7692 was 7692, checked in by frrh, 7 years ago

Strip out svn keywords

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