source: LMDZ6/branches/Amaury_dev/tools/fcm/bin/fcm_gui @ 5136

Last change on this file since 5136 was 5129, checked in by abarral, 4 months ago

Re-add removed by mistake fcm
  • Property svn:executable set to *
File size: 34.9 KB
Line 
1#!/usr/bin/env perl
2#-------------------------------------------------------------------------------
3# Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
4#
5# This file is part of FCM, tools for managing and building source code.
6#
7# FCM is free software: you can redistribute it and/or modify
8# it under the terms of the GNU General Public License as published by
9# the Free Software Foundation, either version 3 of the License, or
10# (at your option) any later version.
11#
12# FCM is distributed in the hope that it will be useful,
13# but WITHOUT ANY WARRANTY; without even the implied warranty of
14# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15# GNU General Public License for more details.
16#
17# You should have received a copy of the GNU General Public License
18# along with FCM. If not, see <http://www.gnu.org/licenses/>.
19#-------------------------------------------------------------------------------
20
21use strict;
22use warnings;
23
24use FindBin;
25use lib "$FindBin::Bin/../lib";
26use Cwd qw{cwd};
27use FCM::Context::Event;
28use FCM::Util;
29use FCM1::Config;
30use FCM1::Keyword;
31use FCM1::Timer qw{timestamp_command};
32use FCM1::Util qw{get_url_of_wc get_wct is_wc};
33use File::Basename qw{basename};
34use File::Spec::Functions qw{catfile rel2abs};
35use Tk;
36use Tk::ROText;
37
38# ------------------------------------------------------------------------------
39
40# Argument
41if (@ARGV) {
42  my $dir = shift @ARGV;
43  chdir $dir if -d $dir;
44}
45
46FCM1::Keyword::set_util(FCM::Util->new());
47
48# Get configuration settings
49my $config = FCM1::Config->new ();
50$config->get_config ();
51
52# ------------------------------------------------------------------------------
53
54# FCM subcommands
55my @subcmds = qw/CHECKOUT BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT
56                 UPDATE SWITCH/;
57
58# Subcommands allowed when CWD is not a WC
59my @nwc_subcmds = qw/CHECKOUT BRANCH/;
60
61# Subcommands allowed, when CWD is a WC
62my @wc_subcmds = qw/STATUS BRANCH DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
63                    SWITCH/;
64
65# Subcommands that apply to WC only
66my @wco_subcmds = qw/BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
67                     SWITCH/;
68
69# Subcommands that apply to top level WC only
70my @wcto_subcmds = qw/BRANCH MERGE COMMIT UPDATE SWITCH/;
71
72# Selected subcommand
73my $selsubcmd = '';
74
75# Selected subcommand is running?
76my $cmdrunning = 0;
77
78# PID of running subcommand
79my $cmdpid = undef;
80
81# List of subcommand frames
82my %subcmd_f;
83
84# List of subcommand buttons
85my %subcmd_b;
86
87# List of subcommand button help strings
88my %subcmd_help = (
89  BRANCH    => 'list information about, create or delete a branch.',
90  CHECKOUT  => 'check out a working copy from a repository.',
91  STATUS    => 'print the status of working copy files and directories.',
92  DIFF      => 'display the differences in modified files.',
93  ADD       => 'put files and directories under version control.',
94  DELETE    => 'remove files and directories from version control.',
95  MERGE     => 'merge changes into your working copy.',
96  CONFLICTS => 'use a graphical tool to resolve conflicts in your working copy.',
97  COMMIT    => 'send changes from your working copy to the repository.',
98  UPDATE    => 'bring changes from the repository into your working copy.',
99  SWITCH    => 'update your working copy to a different URL.',
100);
101
102for (keys %subcmd_help) {
103  $subcmd_help{$_} = 'Select the "' . lc ($_) . '" sub-command - ' .
104                     $subcmd_help{$_};
105}
106
107# List of subcommand button bindings (key name and underline position)
108my %subcmd_bind = (
109  BRANCH    => {KEY => '<Alt-Key-b>', U => 0},
110  CHECKOUT  => {KEY => '<Alt-Key-o>', U => 5},
111  STATUS    => {KEY => '<Alt-Key-s>', U => 0},
112  DIFF      => {KEY => '<Alt-Key-d>', U => 0},
113  ADD       => {KEY => '<Alt-Key-a>', U => 0},
114  DELETE    => {KEY => '<Alt-Key-t>', U => 4},
115  MERGE     => {KEY => '<Alt-Key-m>', U => 0},
116  CONFLICTS => {KEY => '<Alt-Key-f>', U => 3},
117  COMMIT    => {KEY => '<Alt-Key-c>', U => 0},
118  UPDATE    => {KEY => '<Alt-Key-u>', U => 0},
119  SWITCH    => {KEY => '<Alt-Key-w>', U => 1},
120);
121
122# List of subcommand variables
123my %subcmdvar = (
124  CWD       => cwd (),
125  WCT       => '',
126  CWD_URL   => '',
127  WCT_URL   => '',
128
129  BRANCH    => {
130    OPT     => 'info',
131    URL     => '',
132    NAME    => '',
133    TYPE    => 'DEV',
134    REVFLAG => 'NORMAL',
135    TICKET  => '',
136    SRCTYPE => 'trunk',
137    S_CHD   => 0,
138    S_SIB   => 0,
139    S_OTH   => 0,
140    VERBOSE => 0,
141    OTHER   => '',
142  },
143
144  CHECKOUT  => {
145    URL     => '',
146    REV     => 'HEAD',
147    PATH    => '',
148    OTHER   => '',
149  },
150
151  STATUS    => {
152    USEWCT  => 0,
153    UPDATE  => 0,
154    VERBOSE => 0,
155    OTHER   => '',
156  },
157
158  DIFF      => {
159    USEWCT  => 0,
160    TOOL    => 'graphical',
161    BRANCH  => 0,
162    URL     => '',
163    OTHER   => '',
164  },
165
166  ADD       => {
167    USEWCT  => 0,
168    CHECK   => 1,
169    OTHER   => '',
170  },
171
172  DELETE    => {
173    USEWCT  => 0,
174    CHECK   => 1,
175    OTHER   => '',
176  },
177
178  MERGE     => {
179    USEWCT  => 1,
180    SRC     => '',
181    MODE    => 'automatic',
182    DRYRUN  => 0,
183    VERBOSE => 0,
184    REV     => '',
185    OTHER   => '',
186  },
187
188  CONFLICTS => {
189    USEWCT  => 0,
190    OTHER   => '',
191  },
192
193  COMMIT    => {
194    USEWCT  => 1,
195    DRYRUN  => 0,
196    OTHER   => '',
197  },
198
199  UPDATE    => {
200    USEWCT  => 1,
201    OTHER   => '',
202  },
203
204  SWITCH    => {
205    USEWCT  => 1,
206    URL     => '',
207    OTHER   => '',
208  },
209);
210
211# List of action buttons
212my %action_b;
213
214# List of action button help strings
215my %action_help = (
216  QUIT  => 'Quit fcm gui',
217  HELP  => 'Print help to the output text box for the selected sub-command',
218  CLEAR => 'Clear the output text box',
219  RUN   => 'Run the selected sub-command',
220);
221
222# List of action button bindings
223my %action_bind = (
224  QUIT  => {KEY => '<Control-Key-q>', U => undef},
225  HELP  => {KEY => '<F1>'           , U => undef},
226  CLEAR => {KEY => '<Alt-Key-l>'    , U => 1},
227  RUN   => {KEY => '<Alt-Key-r>'    , U => 0},
228);
229
230# List of branch subcommand options
231my %branch_opt = (
232  INFO   => undef,
233  CREATE => undef,
234  DELETE => undef,
235  LIST   => undef,
236);
237
238# List of branch create types
239my %branch_type = (
240  'DEV'         => undef,
241  'DEV::SHARE'  => undef,
242  'TEST'        => undef,
243  'TEST::SHARE' => undef,
244  'PKG'         => undef,
245  'PKG::SHARE'  => undef,
246  'PKG::CONFIG' => undef,
247  'PKG::REL'    => undef,
248);
249
250# List of branch create source type
251my %branch_srctype = (
252  TRUNK  => undef,
253  BRANCH => undef,
254);
255
256# List of branch create revision prefix option
257my %branch_revflag = (
258  NORMAL => undef,
259  NUMBER => undef,
260  NONE   => undef,
261);
262
263# List of branch info/delete options
264my %branch_info_opt = (
265  S_CHD   => 'Show children',
266  S_SIB   => 'Show siblings',
267  S_OTH   => 'Show other',
268  VERBOSE => 'Print extra information',
269);
270
271# List of diff display options
272my %diff_display_opt = (
273  default   => 'Default mode',
274  graphical => 'Graphical tool',
275  trac      => 'Trac (only for diff relative to the base of the branch)',
276);
277
278# Text in the status bar
279my $statustext = '';
280
281# ------------------------------------------------------------------------------
282
283my $mw = MainWindow->new ();
284
285my $mw_title = 'FCM GUI';
286$mw->title ($mw_title);
287
288# Frame containing subcommand selection buttons
289my $top_f = $mw->Frame ()->grid (
290  '-row'    => 0,
291  '-column' => 0,
292  '-sticky' => 'w',
293);
294
295# Frame containing subcommand options
296my $mid_f = $mw->Frame ()->grid (
297  '-row'    => 1,
298  '-column' => 0,
299  '-sticky' => 'ew',
300);
301
302# Frame containing action buttons
303my $bot_f = $mw->Frame ()->grid (
304  '-row'    => 2,
305  '-column' => 0,
306  '-sticky' => 'ew',
307);
308
309# Text box to display output
310my $out_t  = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid (
311  '-row'    => 3,
312  '-column' => 0,
313  '-sticky' => 'news',
314);
315
316# Text box - allow scroll with mouse wheel
317$out_t->bind (
318  '<4>' => sub {
319    $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif;
320  },
321);
322
323$out_t->bind (
324  '<5>' => sub {
325    $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif;
326  },
327);
328
329# Status bar
330$mw->Label (
331  '-textvariable' => \$statustext,
332  '-relief'       => 'groove',
333)->grid (
334  '-row'    => 4,
335  '-column' => 0,
336  '-sticky' => 'ews',
337);
338
339# Main window grid configure
340{
341  my ($cols, $rows) = $mw->gridSize ();
342  $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1);
343  $mw->gridRowconfigure    ( 3, '-weight' => 1);
344}
345
346# Frame grid configure
347{
348  my ($cols, $rows) = $mid_f->gridSize ();
349  $bot_f->gridColumnconfigure (3, '-weight' => 1);
350}
351
352$mid_f->gridRowconfigure    (0, '-weight' => 1);
353$mid_f->gridColumnconfigure (0, '-weight' => 1);
354
355# ------------------------------------------------------------------------------
356
357# Buttons to select subcommands
358{
359  my $col = 0;
360  for my $name (@subcmds) {
361    $subcmd_b{$name} = $top_f->Button (
362      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
363      '-command' => [\&button_clicked, $name],
364      '-width'   => 8,
365    )->grid (
366      '-row'    => 0,
367      '-column' => $col++,
368      '-sticky' => 'w',
369    );
370
371    $subcmd_b{$name}->bind ('<Enter>', sub {$statustext = $subcmd_help{$name}});
372    $subcmd_b{$name}->bind ('<Leave>', sub {$statustext = ''});
373
374    $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U})
375      if defined $subcmd_bind{$name}{U};
376
377    $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke});
378  }
379}
380
381# ------------------------------------------------------------------------------
382
383# Frames to contain subcommands options
384{
385  my %row = ();
386
387  for my $name (@subcmds) {
388    $subcmd_f{$name} = $mid_f->Frame ();
389    $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1);
390
391    $row{$name} = 0;
392
393    # Widgets common to all sub-commands
394    $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid (
395      '-row'    => $row{$name},
396      '-column' => 0,
397      '-sticky' => 'w',
398    );
399    $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid (
400      '-row'    => $row{$name}++,
401      '-column' => 1,
402      '-sticky' => 'w',
403    );
404  }
405
406  # Widgets common to all sub-commands that apply to working copies
407  for my $name (@wco_subcmds) {
408    my @labtxts = (
409      'Corresponding URL: ',
410      'Working copy top: ',
411      'Corresponding URL: ',
412    );
413    my @varrefs = \(
414      $subcmdvar{URL_CWD},
415      $subcmdvar{WCT},
416      $subcmdvar{URL_WCT},
417    );
418
419    for my $i (0 .. $#varrefs) {
420      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
421        '-row'    => $row{$name},
422        '-column' => 0,
423        '-sticky' => 'w',
424      );
425      $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid (
426        '-row'    => $row{$name}++,
427        '-column' => 1,
428        '-sticky' => 'w',
429      );
430    }
431
432    $subcmd_f{$name}->Checkbutton (
433      '-text'     => 'Apply sub-command to working copy top',
434      '-variable' => \($subcmdvar{$name}{USEWCT}),
435      '-state'    => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'),
436    )->grid (
437      '-row'        => $row{$name}++,
438      '-column'     => 0,
439      '-columnspan' => 2,
440      '-sticky'     => 'w',
441    );
442  }
443
444  # Widget for the Branch sub-command
445  {
446    my $name = 'BRANCH';
447
448    # Radio buttons to select the sub-option of the branch sub-command
449    my $opt_f = $subcmd_f{$name}->Frame ()->grid (
450      '-row'        => $row{$name}++,
451      '-column'     => 0,
452      '-columnspan' => 2,
453      '-sticky'     => 'w',
454    );
455
456    my $col = 0;
457    for my $key (sort keys %branch_opt) {
458      my $opt = lc $key;
459
460      $branch_opt{$key} = $opt_f->Radiobutton (
461        '-text'     => $opt,
462        '-value'    => $opt,
463        '-variable' => \($subcmdvar{$name}{OPT}),
464        '-state'    => 'normal',
465      )->grid (
466        '-row'      => 0,
467        '-column'   => $col++,
468        '-sticky'   => 'w',
469      );
470    }
471
472    # Label and entry box for specifying URL
473    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
474      '-row'    => $row{$name},
475      '-column' => 0,
476      '-sticky' => 'w',
477    );
478    $subcmd_f{$name}->Entry (
479      '-textvariable' => \($subcmdvar{$name}{URL}),
480    )->grid (
481      '-row'    => $row{$name}++,
482      '-column' => 1,
483      '-sticky' => 'ew',
484    );
485
486    # Label and entry box for specifying create branch name
487    $subcmd_f{$name}->Label (
488      '-text' => 'Branch name (create only): ',
489    )->grid (
490      '-row'    => $row{$name},
491      '-column' => 0,
492      '-sticky' => 'w',
493    );
494    $subcmd_f{$name}->Entry (
495      '-textvariable' => \($subcmdvar{$name}{NAME}),
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 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    if ($subcmdvar{$name}{OPT} eq 'create') {
1128      $cmd .= 'branch-create';
1129      $cmd .= ' --svn-non-interactive';
1130      $cmd .= ' -t '     . $subcmdvar{$name}{TYPE};
1131      $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG};
1132      $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET};
1133      $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch';
1134      $cmd .= ' ' . $subcmdvar{$name}{NAME};
1135
1136    } elsif ($subcmdvar{$name}{OPT} eq 'delete') {
1137      $cmd .= 'branch-delete';
1138      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1139      $cmd .= ' --svn-non-interactive';
1140
1141    } elsif ($subcmdvar{$name}{OPT} eq 'list') {
1142      $cmd .= 'branch-list';
1143
1144    } else {
1145      $cmd .= 'branch-info';
1146      $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD};
1147      $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB};
1148      $cmd .= ' --show-other'    if $subcmdvar{$name}{S_OTH};
1149      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1150    }
1151    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
1152    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1153
1154  } elsif ($name eq 'CHECKOUT') {
1155    $cmd .= lc ($name);
1156    $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
1157    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1158    $cmd .= ' ' . $subcmdvar{$name}{URL};
1159    $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH};
1160
1161  } elsif ($name eq 'STATUS') {
1162    $cmd .= lc ($name);
1163    $cmd .= ' -u' if $subcmdvar{$name}{UPDATE};
1164    $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
1165    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
1166
1167  } elsif ($name eq 'DIFF') {
1168    if ($subcmdvar{$name}{BRANCH}) {
1169      $cmd .= 'branch-diff';
1170      $cmd .= ' -t' if $subcmdvar{$name}{TOOL} eq 'trac';
1171      $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
1172    }
1173    else {
1174      $cmd .= 'diff';
1175    }
1176
1177    $cmd .= ' -g' if $subcmdvar{$name}{TOOL} eq 'graphical';
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 = FCM1::Keyword::expand($subcmdvar{CHECKOUT}{URL});
1298          my $dir = $subcmdvar{CHECKOUT}{PATH}
1299                  ? $subcmdvar{CHECKOUT}{PATH}
1300                  : basename($url);
1301          $dir    = 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
1344Copyright (C) 2006-2021 British Crown (Met Office) & Contributors.
1345
1346=cut
Note: See TracBrowser for help on using the repository browser.