ecearth3/sources/nemo-3.6/EXTERNAL/fcm/bin/fcm_gui

#!/usr/bin/env perl
#-------------------------------------------------------------------------------
# (C) Crown copyright Met Office. All rights reserved.
# For further details please refer to the file COPYRIGHT.txt
# which you should have received as part of this distribution.
#-------------------------------------------------------------------------------

use strict;
use warnings;

use FindBin;
use lib "$FindBin::Bin/../lib";
use Cwd;
use Fcm::Config;
use Fcm::Keyword;
use Fcm::Timer;
use Fcm::Util;
use File::Basename;
use File::Spec;
use Tk;
use Tk::ROText;

# ------------------------------------------------------------------------------

# Argument
if (@ARGV) {
  my $dir = shift @ARGV;
  chdir $dir if -d $dir;
}

# Get configuration settings
my $config = Fcm::Config->new ();
$config->get_config ();

# ------------------------------------------------------------------------------

# FCM subcommands
my @subcmds = qw/CHECKOUT BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT
                 UPDATE SWITCH/;

# Subcommands allowed when CWD is not a WC
my @nwc_subcmds = qw/CHECKOUT BRANCH/;

# Subcommands allowed, when CWD is a WC
my @wc_subcmds = qw/STATUS BRANCH DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
                    SWITCH/;

# Subcommands that apply to WC only
my @wco_subcmds = qw/BRANCH STATUS DIFF ADD DELETE MERGE CONFLICTS COMMIT UPDATE
                     SWITCH/;

# Subcommands that apply to top level WC only
my @wcto_subcmds = qw/BRANCH MERGE COMMIT UPDATE SWITCH/;

# Selected subcommand
my $selsubcmd = '';

# Selected subcommand is running?
my $cmdrunning = 0;

# PID of running subcommand
my $cmdpid = undef;

# List of subcommand frames
my %subcmd_f;

# List of subcommand buttons
my %subcmd_b;

# List of subcommand button help strings
my %subcmd_help = (
  BRANCH    => 'list information about, create or delete a branch.',
  CHECKOUT  => 'check out a working copy from a repository.',
  STATUS    => 'print the status of working copy files and directories.',
  DIFF      => 'display the differences in modified files.',
  ADD       => 'put files and directories under version control.',
  DELETE    => 'remove files and directories from version control.',
  MERGE     => 'merge changes into your working copy.',
  CONFLICTS => 'use a graphical tool to resolve conflicts in your working copy.',
  COMMIT    => 'send changes from your working copy to the repository.',
  UPDATE    => 'bring changes from the repository into your working copy.',
  SWITCH    => 'update your working copy to a different URL.',
);

for (keys %subcmd_help) {
  $subcmd_help{$_} = 'Select the "' . lc ($_) . '" sub-command - ' .
                     $subcmd_help{$_};
}

# List of subcommand button bindings (key name and underline position)
my %subcmd_bind = (
  BRANCH    => {KEY => '<Alt-Key-b>', U => 0},
  CHECKOUT  => {KEY => '<Alt-Key-o>', U => 5},
  STATUS    => {KEY => '<Alt-Key-s>', U => 0},
  DIFF      => {KEY => '<Alt-Key-d>', U => 0},
  ADD       => {KEY => '<Alt-Key-a>', U => 0},
  DELETE    => {KEY => '<Alt-Key-t>', U => 4},
  MERGE     => {KEY => '<Alt-Key-m>', U => 0},
  CONFLICTS => {KEY => '<Alt-Key-f>', U => 3},
  COMMIT    => {KEY => '<Alt-Key-c>', U => 0},
  UPDATE    => {KEY => '<Alt-Key-u>', U => 0},
  SWITCH    => {KEY => '<Alt-Key-w>', U => 1},
);

# List of subcommand variables
my %subcmdvar = (
  CWD       => cwd (),
  WCT       => '',
  CWD_URL   => '',
  WCT_URL   => '',

  BRANCH    => {
    OPT     => 'info',
    URL     => '',
    NAME    => '',
    TYPE    => 'DEV',
    REVFLAG => 'NORMAL',
    REV     => '',
    TICKET  => '',
    SRCTYPE => 'trunk',
    S_CHD   => 0,
    S_SIB   => 0,
    S_OTH   => 0,
    VERBOSE => 0,
    OTHER   => '',
  },

  CHECKOUT  => {
    URL     => '',
    REV     => 'HEAD',
    PATH    => '',
    OTHER   => '',
  },

  STATUS    => {
    USEWCT  => 0,
    UPDATE  => 0,
    VERBOSE => 0,
    OTHER   => '',
  },

  DIFF      => {
    USEWCT  => 0,
    TOOL    => 'graphical',
    BRANCH  => 0,
    URL     => '',
    OTHER   => '',
  },

  ADD       => {
    USEWCT  => 0,
    CHECK   => 1,
    OTHER   => '',
  },

  DELETE    => {
    USEWCT  => 0,
    CHECK   => 1,
    OTHER   => '',
  },

  MERGE     => {
    USEWCT  => 1,
    SRC     => '',
    MODE    => 'automatic',
    DRYRUN  => 0,
    VERBOSE => 0,
    REV     => '',
    OTHER   => '',
  },

  CONFLICTS => {
    USEWCT  => 0,
    OTHER   => '',
  },

  COMMIT    => {
    USEWCT  => 1,
    DRYRUN  => 0,
    OTHER   => '',
  },

  UPDATE    => {
    USEWCT  => 1,
    OTHER   => '',
  },

  SWITCH    => {
    USEWCT  => 1,
    URL     => '',
    OTHER   => '',
  },
);

# List of action buttons
my %action_b;

# List of action button help strings
my %action_help = (
  QUIT  => 'Quit fcm gui',
  HELP  => 'Print help to the output text box for the selected sub-command',
  CLEAR => 'Clear the output text box',
  RUN   => 'Run the selected sub-command',
);

# List of action button bindings
my %action_bind = (
  QUIT  => {KEY => '<Control-Key-q>', U => undef},
  HELP  => {KEY => '<F1>'           , U => undef},
  CLEAR => {KEY => '<Alt-Key-l>'    , U => 1},
  RUN   => {KEY => '<Alt-Key-r>'    , U => 0},
);

# List of branch subcommand options
my %branch_opt = (
  INFO   => undef,
  CREATE => undef,
  DELETE => undef,
  LIST   => undef,
);

# List of branch create types
my %branch_type = (
  'DEV'         => undef,
  'DEV::SHARE'  => undef,
  'TEST'        => undef,
  'TEST::SHARE' => undef,
  'PKG'         => undef,
  'PKG::SHARE'  => undef,
  'PKG::CONFIG' => undef,
  'PKG::REL'    => undef,
);

# List of branch create source type
my %branch_srctype = (
  TRUNK  => undef,
  BRANCH => undef,
);

# List of branch create revision prefix option
my %branch_revflag = (
  NORMAL => undef,
  NUMBER => undef,
  NONE   => undef,
);

# List of branch info/delete options
my %branch_info_opt = (
  S_CHD   => 'Show children',
  S_SIB   => 'Show siblings',
  S_OTH   => 'Show other',
  VERBOSE => 'Print extra information',
);

# List of diff display options
my %diff_display_opt = (
  default   => 'Default mode',
  graphical => 'Graphical tool',
  trac      => 'Trac (only for diff relative to the base of the branch)',
);

# Text in the status bar
my $statustext = '';

# ------------------------------------------------------------------------------

my $mw = MainWindow->new ();

my $mw_title = 'FCM GUI';
$mw->title ($mw_title);

# Frame containing subcommand selection buttons
my $top_f = $mw->Frame ()->grid (
  '-row'    => 0,
  '-column' => 0,
  '-sticky' => 'w',
);

# Frame containing subcommand options
my $mid_f = $mw->Frame ()->grid (
  '-row'    => 1,
  '-column' => 0,
  '-sticky' => 'ew',
);

# Frame containing action buttons
my $bot_f = $mw->Frame ()->grid (
  '-row'    => 2,
  '-column' => 0,
  '-sticky' => 'ew',
);

# Text box to display output
my $out_t  = $mw->Scrolled ('ROText', '-scrollbars' => 'osow')->grid (
  '-row'    => 3,
  '-column' => 0,
  '-sticky' => 'news',
);

# Text box - allow scroll with mouse wheel
$out_t->bind (
  '<4>' => sub {
    $_[0]->yview ('scroll', -1, 'units') unless $Tk::strictMotif;
  },
);

$out_t->bind (
  '<5>' => sub {
    $_[0]->yview ('scroll', +1, 'units') unless $Tk::strictMotif;
  },
);

# Status bar
$mw->Label (
  '-textvariable' => \$statustext,
  '-relief'       => 'groove',
)->grid (
  '-row'    => 4,
  '-column' => 0,
  '-sticky' => 'ews',
);

# Main window grid configure
{
  my ($cols, $rows) = $mw->gridSize ();
  $mw->gridColumnconfigure ($_, '-weight' => 1) for (0 .. $cols - 1);
  $mw->gridRowconfigure    ( 3, '-weight' => 1);
}

# Frame grid configure
{
  my ($cols, $rows) = $mid_f->gridSize ();
  $bot_f->gridColumnconfigure (3, '-weight' => 1);
}

$mid_f->gridRowconfigure    (0, '-weight' => 1);
$mid_f->gridColumnconfigure (0, '-weight' => 1);

# ------------------------------------------------------------------------------

# Buttons to select subcommands
{
  my $col = 0;
  for my $name (@subcmds) {
    $subcmd_b{$name} = $top_f->Button (
      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
      '-command' => [\&button_clicked, $name],
      '-width'   => 8,
    )->grid (
      '-row'    => 0,
      '-column' => $col++,
      '-sticky' => 'w',
    );

    $subcmd_b{$name}->bind ('<Enter>', sub {$statustext = $subcmd_help{$name}});
    $subcmd_b{$name}->bind ('<Leave>', sub {$statustext = ''});

    $subcmd_b{$name}->configure ('-underline' => $subcmd_bind{$name}{U})
      if defined $subcmd_bind{$name}{U};

    $mw->bind ($subcmd_bind{$name}{KEY}, sub {$subcmd_b{$name}->invoke});
  }
}

# ------------------------------------------------------------------------------

# Frames to contain subcommands options
{
  my %row = ();

  for my $name (@subcmds) {
    $subcmd_f{$name} = $mid_f->Frame ();
    $subcmd_f{$name}->gridColumnconfigure (1, '-weight' => 1);

    $row{$name} = 0;

    # Widgets common to all sub-commands
    $subcmd_f{$name}->Label ('-text' => 'Current working directory: ')->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Label ('-textvariable' => \($subcmdvar{CWD}))->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'w',
    );
  }

  # Widgets common to all sub-commands that apply to working copies
  for my $name (@wco_subcmds) {
    my @labtxts = (
      'Corresponding URL: ',
      'Working copy top: ',
      'Corresponding URL: ',
    );
    my @varrefs = \(
      $subcmdvar{URL_CWD},
      $subcmdvar{WCT},
      $subcmdvar{URL_WCT},
    );

    for my $i (0 .. $#varrefs) {
      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
        '-row'    => $row{$name},
        '-column' => 0,
        '-sticky' => 'w',
      );
      $subcmd_f{$name}->Label ('-textvariable' => $varrefs[$i])->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'w',
      );
    }

    $subcmd_f{$name}->Checkbutton (
      '-text'     => 'Apply sub-command to working copy top',
      '-variable' => \($subcmdvar{$name}{USEWCT}),
      '-state'    => (grep ({$_ eq $name} @wcto_subcmds) ? 'disabled' : 'normal'),
    )->grid (
      '-row'        => $row{$name}++,
      '-column'     => 0,
      '-columnspan' => 2,
      '-sticky'     => 'w',
    );
  }

  # Widget for the Branch sub-command
  {
    my $name = 'BRANCH';

    # Radio buttons to select the sub-option of the branch sub-command
    my $opt_f = $subcmd_f{$name}->Frame ()->grid (
      '-row'        => $row{$name}++,
      '-column'     => 0,
      '-columnspan' => 2,
      '-sticky'     => 'w',
    );

    my $col = 0;
    for my $key (sort keys %branch_opt) {
      my $opt = lc $key;

      $branch_opt{$key} = $opt_f->Radiobutton (
        '-text'     => $opt,
        '-value'    => $opt,
        '-variable' => \($subcmdvar{$name}{OPT}),
        '-state'    => 'normal',
      )->grid (
        '-row'      => 0,
        '-column'   => $col++,
        '-sticky'   => 'w',
      );
    }

    # Label and entry box for specifying URL
    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{URL}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );

    # Label and entry box for specifying create branch name
    $subcmd_f{$name}->Label (
      '-text' => 'Branch name (create only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{NAME}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );

    # Label and entry box for specifying create branch source revision
    $subcmd_f{$name}->Label (
      '-text' => 'Source revision (create/list only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{REV}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );

    # Label and radio buttons box for specifying create branch type
    $subcmd_f{$name}->Label (
      '-text' => 'Branch type (create only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );

    {
      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'w',
      );

      my $col = 0;
      for my $key (sort keys %branch_type) {
        my $txt = lc $key;
        my $opt = $key;

        $branch_opt{$key} = $opt_f->Radiobutton (
          '-text'     => $txt,
          '-value'    => $opt,
          '-variable' => \($subcmdvar{$name}{TYPE}),
          '-state'    => 'normal',
        )->grid (
          '-row'      => 0,
          '-column'   => $col++,
          '-sticky'   => 'w',
        );
      }
    }

    # Label and radio buttons box for specifying create source type
    $subcmd_f{$name}->Label (
      '-text' => 'Source type (create only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );

    {
      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'w',
      );

      my $col = 0;
      for my $key (sort keys %branch_srctype) {
        my $txt = lc $key;
        my $opt = lc $key;

        $branch_opt{$key} = $opt_f->Radiobutton (
          '-text'     => $txt,
          '-value'    => $opt,
          '-variable' => \($subcmdvar{$name}{SRCTYPE}),
          '-state'    => 'normal',
        )->grid (
          '-row'      => 0,
          '-column'   => $col++,
          '-sticky'   => 'w',
        );
      }
    }

    # Label and radio buttons box for specifying create prefix option
    $subcmd_f{$name}->Label (
      '-text' => 'Prefix option (create only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );

    {
      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'w',
      );

      my $col = 0;
      for my $key (sort keys %branch_revflag) {
        my $txt = lc $key;
        my $opt = $key;

        $branch_opt{$key} = $opt_f->Radiobutton (
          '-text'     => $txt,
          '-value'    => $opt,
          '-variable' => \($subcmdvar{$name}{REVFLAG}),
          '-state'    => 'normal',
        )->grid (
          '-row'      => 0,
          '-column'   => $col++,
          '-sticky'   => 'w',
        );
      }
    }

    # Label and entry box for specifying ticket number
    $subcmd_f{$name}->Label (
      '-text' => 'Related Trac ticket(s) (create only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{TICKET}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );

    # Check button for info/delete
    # --show-children, --show-siblings, --show-other, --verbose
    $subcmd_f{$name}->Label (
      '-text' => 'Options for info/delete only: ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );

    {
      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'w',
      );

      my $col = 0;

      for my $key (sort keys %branch_info_opt) {
        $opt_f->Checkbutton (
          '-text'     => $branch_info_opt{$key},
          '-variable' => \($subcmdvar{$name}{$key}),
        )->grid (
          '-row'    => 0,
          '-column' => $col++,
          '-sticky' => 'w',
        );
      }
    }
  }

  # Widget for the Checkout sub-command
  {
    my $name = 'CHECKOUT';

    # Label and entry boxes for specifying URL and revision
    my @labtxts = (
      'URL: ',
      'Revision: ',
      'Path: ',
    );
    my @varrefs = \(
      $subcmdvar{$name}{URL},
      $subcmdvar{$name}{REV},
      $subcmdvar{$name}{PATH},
    );

    for my $i (0 .. $#varrefs) {
      $subcmd_f{$name}->Label ('-text' => $labtxts[$i])->grid (
        '-row'    => $row{$name},
        '-column' => 0,
        '-sticky' => 'w',
      );
      $subcmd_f{$name}->Entry (
        '-textvariable' => $varrefs[$i],
      )->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'ew',
      );
    }
  }

  # Widget for the Status sub-command
  {
    my $name = 'STATUS';

    # Checkbuttons for various options
    my @labtxts = (
      'Display update information',
      'Print extra information',
    );
    my @varrefs = \(
      $subcmdvar{$name}{UPDATE},
      $subcmdvar{$name}{VERBOSE},
    );

    for my $i (0 .. $#varrefs) {
      $subcmd_f{$name}->Checkbutton (
        '-text'     => $labtxts[$i],
        '-variable' => $varrefs[$i],
      )->grid (
        '-row'        => $row{$name}++,
        '-column'     => 0,
        '-columnspan' => 2,
        '-sticky'     => 'w',
      );
    }
  }

  # Widget for the Diff sub-command
  {
    my $name = 'DIFF';

    my $entry;
    $subcmd_f{$name}->Checkbutton (
      '-text'     => 'Show differences relative to the base of the branch',
      '-variable' => \($subcmdvar{$name}{BRANCH}),
      '-command'  => sub {
        $entry->configure (
          '-state' => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
        );
      },
    )->grid (
      '-row'        => $row{$name}++,
      '-column'     => 0,
      '-columnspan' => 2,
      '-sticky'     => 'w',
    );

    # Label and radio buttons box for specifying tool
    $subcmd_f{$name}->Label (
      '-text' => 'Display diff in: ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );

    {
      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'w',
      );

      my $col = 0;
      for my $key (qw/default graphical trac/) {
        my $txt = $diff_display_opt{$key};
        my $opt = $key;

        $branch_opt{$key} = $opt_f->Radiobutton (
          '-text'     => $txt,
          '-value'    => $opt,
          '-variable' => \($subcmdvar{$name}{TOOL}),
          '-state'    => 'normal',
        )->grid (
          '-row'      => 0,
          '-column'   => $col++,
          '-sticky'   => 'w',
        );
      }
    }

    $subcmd_f{$name}->Label ('-text' => 'Branch URL')->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );

    $entry = $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{URL}),
      '-state'        => ($subcmdvar{$name}{BRANCH} ? 'normal' : 'disabled'),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );
  }

  # Widget for the Add/Delete sub-command
  for my $name (qw/ADD DELETE/) {

    # Checkbuttons for various options
    $subcmd_f{$name}->Checkbutton (
      '-text'     => 'Check for files or directories not under version control',
      '-variable' => \($subcmdvar{$name}{CHECK}),
    )->grid (
      '-row'        => $row{$name}++,
      '-column'     => 0,
      '-columnspan' => 2,
      '-sticky'     => 'w',
    );
  }

  # Widget for the Merge sub-command
  {
    my $name = 'MERGE';

    # Label and radio buttons box for specifying merge mode
    $subcmd_f{$name}->Label (
      '-text' => 'Mode: ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );

    {
      my $opt_f = $subcmd_f{$name}->Frame ()->grid (
        '-row'    => $row{$name}++,
        '-column' => 1,
        '-sticky' => 'w',
      );

      my $col = 0;
      for my $key (qw/automatic custom reverse/) {
        my $txt = lc $key;
        my $opt = $key;

        $branch_opt{$key} = $opt_f->Radiobutton (
          '-text'     => $txt,
          '-value'    => $opt,
          '-variable' => \($subcmdvar{$name}{MODE}),
          '-state'    => 'normal',
        )->grid (
          '-row'      => 0,
          '-column'   => $col++,
          '-sticky'   => 'w',
        );
      }
    }

    # Check buttons for dry-run
    $subcmd_f{$name}->Checkbutton (
      '-text'     => 'Dry run',
      '-variable' => \($subcmdvar{$name}{DRYRUN}),
    )->grid (
      '-row'        => $row{$name}++,
      '-column'     => 0,
      '-columnspan' => 2,
      '-sticky'     => 'w',
    );

    # Check buttons for verbose mode
    $subcmd_f{$name}->Checkbutton (
      '-text'     => 'Print extra information',
      '-variable' => \($subcmdvar{$name}{VERBOSE}),
    )->grid (
      '-row'        => $row{$name}++,
      '-column'     => 0,
      '-columnspan' => 2,
      '-sticky'     => 'w',
    );

    # Label and entry boxes for specifying merge source
    $subcmd_f{$name}->Label (
      '-text' => 'Source (automatic/custom only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{SRC}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );

    # Label and entry boxes for specifying merge revision (range)
    $subcmd_f{$name}->Label (
      '-text' => 'Revision (custom/reverse only): ',
    )->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{REV}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );
  }

  # Widget for the Commit sub-command
  {
    my $name = 'COMMIT';

    # Checkbuttons for various options
    $subcmd_f{$name}->Checkbutton (
      '-text'     => 'Dry run',
      '-variable' => \($subcmdvar{$name}{DRYRUN}),
    )->grid (
      '-row'        => $row{$name}++,
      '-column'     => 0,
      '-columnspan' => 2,
      '-sticky'     => 'w',
    );
  }

  # Widget for the Switch sub-command
  {
    my $name = 'SWITCH';

    # Label and entry boxes for specifying switch URL
    $subcmd_f{$name}->Label ('-text' => 'URL: ')->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{URL}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );
  }

  # Widgets common to all sub-commands
  for my $name (@subcmds) {
    $subcmd_f{$name}->Label ('-text' => 'Other options: ')->grid (
      '-row'    => $row{$name},
      '-column' => 0,
      '-sticky' => 'w',
    );
    $subcmd_f{$name}->Entry (
      '-textvariable' => \($subcmdvar{$name}{OTHER}),
    )->grid (
      '-row'    => $row{$name}++,
      '-column' => 1,
      '-sticky' => 'ew',
    );
  }
}

# ------------------------------------------------------------------------------

# Buttons to perform main actions
{
  my $col = 0;
  for my $name (qw/QUIT HELP CLEAR RUN/) {
    $action_b{$name} = $bot_f->Button (
      '-text'    => uc (substr ($name, 0, 1)) . lc (substr ($name, 1)),
      '-command' => [\&button_clicked, $name],
      '-width'   => 8,
    )->grid (
      '-row'    => 0,
      '-column' => $col++,
      '-sticky' => ($name eq 'RUN' ? 'ew' : 'w'),
    );

    $action_b{$name}->bind ('<Enter>', sub {$statustext = $action_help{$name}});
    $action_b{$name}->bind ('<Leave>', sub {$statustext = ''});

    $action_b{$name}->configure ('-underline' => $action_bind{$name}{U})
      if defined $action_bind{$name}{U};

    $mw->bind ($action_bind{$name}{KEY}, sub {$action_b{$name}->invoke});
  }
}

&change_cwd ($subcmdvar{CWD});

# ------------------------------------------------------------------------------

# Handle the situation when the user attempts to quit the window while a
# sub-command is running

$mw->protocol ('WM_DELETE_WINDOW', sub {
  if (defined $cmdpid) {
    my $ans = $mw->messageBox (
      '-title'   => $mw_title,
      '-message' => $selsubcmd . ' is still running. Really quit?',
      '-type'    => 'YesNo',
      '-default' => 'No',
    );

    if ($ans eq 'Yes') {
      kill 9, $cmdpid; # Need to kill the sub-process before quitting

    } else {
      return; # Do not quit
    }
  }

  exit;
});

MainLoop;

# ------------------------------------------------------------------------------
# SYNOPSIS
#   &change_cwd ($dir);
#
# DESCRIPTION
#   Change current working directory to $dir
# ------------------------------------------------------------------------------

sub change_cwd {
  my $dir = $_[0];
  my @allowed_subcmds = (&is_wc ($dir) ? @wc_subcmds : @nwc_subcmds);

  for my $subcmd (@subcmds) {
    if (grep {$_ eq $subcmd} @allowed_subcmds) {
      $subcmd_b{$subcmd}->configure ('-state' => 'normal');

    } else {
      $subcmd_b{$subcmd}->configure ('-state' => 'disabled');
    }
  }

  &display_subcmd_frame ($allowed_subcmds[0])
    if not grep {$_ eq $selsubcmd} @allowed_subcmds;

  chdir $dir;
  $subcmdvar{CWD} = $dir;

  if (&is_wc ($dir)) {
    $subcmdvar{WCT}     = &get_wct ($dir);
    $subcmdvar{URL_CWD} = &get_url_of_wc ($dir);
    $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT});

    $branch_opt{INFO}  ->configure ('-state' => 'normal');
    $branch_opt{DELETE}->configure ('-state' => 'normal');
    $subcmdvar{BRANCH}{OPT} = 'info';

  } else {
    $branch_opt{INFO}  ->configure ('-state' => 'disabled');
    $branch_opt{DELETE}->configure ('-state' => 'disabled');
    $subcmdvar{BRANCH}{OPT} = 'create';
  }

  return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   &button_clicked ($name);
#
# DESCRIPTION
#   Call back function to handle a click on a command button named $name.
# ------------------------------------------------------------------------------

sub button_clicked {
  my $name = $_[0];

  if (grep {$_ eq $name} keys %subcmd_b) {
    &display_subcmd_frame ($name);

  } elsif ($name eq 'CLEAR') {
    $out_t->delete ('1.0', 'end');

  } elsif ($name eq 'QUIT') {
    exit;

  } elsif ($name eq 'HELP') {
    &invoke_cmd ('help ' . lc ($selsubcmd));

  } elsif ($name eq 'RUN') {
    &invoke_cmd (&setup_cmd ($selsubcmd));

  } else {
    $out_t->insert ('end', $name . ': function to be implemented' . "\n");
    $out_t->yviewMoveto (1);
  }

  return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   &display_subcmd_frame ($name);
#
# DESCRIPTION
#   Change selected subcommand to $name, and display the frame containing the
#   widgets for configuring the options and arguments of that subcommand.
# ------------------------------------------------------------------------------

sub display_subcmd_frame {
  my $name = $_[0];

  if ($selsubcmd ne $name and not $cmdrunning) {
    $subcmd_b{$name     }->configure ('-relief' => 'sunken');
    $subcmd_b{$selsubcmd}->configure ('-relief' => 'raised') if $selsubcmd;

    $subcmd_f{$name     }->grid ('-sticky' => 'new');
    $subcmd_f{$selsubcmd}->gridForget if $selsubcmd;

    $selsubcmd = $name;
  }

  return;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $pos = &get_wm_pos ();
#
# DESCRIPTION
#   Returns the position part of the geometry string of the main window.
# ------------------------------------------------------------------------------

sub get_wm_pos {
  my $geometry = $mw->geometry ();
  $geometry =~ /^=?(?:\d+x\d+)?([+-]\d+[+-]\d+)$/;
  return $1;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   $command = &setup_cmd ($name);
#
# DESCRIPTION
#   Setup the the system command for the sub-command $name.
# ------------------------------------------------------------------------------

sub setup_cmd {
  my $name = $_[0];
  my $cmd  = '';

  if ($name eq 'BRANCH') {
    $cmd .= lc ($name);
    if ($subcmdvar{$name}{OPT} eq 'create') {
      $cmd .= ' -c --svn-non-interactive';
      $cmd .= ' -n '     . $subcmdvar{$name}{NAME} if $subcmdvar{$name}{NAME};
      $cmd .= ' -t '     . $subcmdvar{$name}{TYPE};
      $cmd .= ' --rev-flag ' . $subcmdvar{$name}{REVFLAG};
      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
      $cmd .= ' -k ' . $subcmdvar{$name}{TICKET} if $subcmdvar{$name}{TICKET};
      $cmd .= ' --branch-of-branch ' if $subcmdvar{$name}{SRCTYPE} eq 'branch';

    } elsif ($subcmdvar{$name}{OPT} eq 'delete') {
      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
      $cmd .= ' -d --svn-non-interactive';

    } elsif ($subcmdvar{$name}{OPT} eq 'list') {
      $cmd .= ' -l';
      $cmd .= ' -r ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};

    } else {
      $cmd .= ' -i';
      $cmd .= ' --show-children' if $subcmdvar{$name}{S_CHD};
      $cmd .= ' --show-siblings' if $subcmdvar{$name}{S_SIB};
      $cmd .= ' --show-other'    if $subcmdvar{$name}{S_OTH};
      $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
    }
    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'CHECKOUT') {
    $cmd .= lc ($name);
    $cmd .= ' -r' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};
    $cmd .= ' ' . $subcmdvar{$name}{URL};
    $cmd .= ' ' . $subcmdvar{$name}{PATH} if $subcmdvar{$name}{PATH};

  } elsif ($name eq 'STATUS') {
    $cmd .= lc ($name);
    $cmd .= ' -u' if $subcmdvar{$name}{UPDATE};
    $cmd .= ' -v' if $subcmdvar{$name}{VERBOSE};
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'DIFF') {
    $cmd .= lc ($name);
    $cmd .= ' -g' if $subcmdvar{$name}{TOOL} eq 'graphical';

    if ($subcmdvar{$name}{BRANCH}) {
      $cmd .= ' -b';
      $cmd .= ' -t' if $subcmdvar{$name}{TOOL} eq 'trac';
      $cmd .= ' ' . $subcmdvar{$name}{URL} if $subcmdvar{$name}{URL};
    }

    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'ADD' or $name eq 'DELETE') {
    $cmd .= lc ($name);
    $cmd .= ' -c' if $subcmdvar{$name}{CHECK};
    $cmd .= ' --non-interactive'
      if $name eq 'DELETE' and not $subcmdvar{$name}{CHECK};
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'MERGE') {
    $cmd .= lc ($name);

    if ($subcmdvar{$name}{MODE} ne 'automatic') {
      $cmd .= ' --' . $subcmdvar{$name}{MODE};
      $cmd .= ' --revision ' . $subcmdvar{$name}{REV} if $subcmdvar{$name}{REV};
    }

    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
    $cmd .= ' -v'        if $subcmdvar{$name}{VERBOSE};
    $cmd .= ' ' . $subcmdvar{$name}{SRC}   if $subcmdvar{$name}{SRC};
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'CONFLICTS') {
    $cmd .= lc ($name);
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'COMMIT') {
    $cmd .= lc ($name);
    $cmd .= ' --dry-run' if $subcmdvar{$name}{DRYRUN};
    $cmd .= ' --svn-non-interactive';
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'SWITCH') {
    $cmd .= lc ($name);
    $cmd .= ' ' . $subcmdvar{$name}{URL}   if $subcmdvar{$name}{URL};
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  } elsif ($name eq 'UPDATE') {
    $cmd .= lc ($name);
    $cmd .= ' ' . $subcmdvar{$name}{OTHER} if $subcmdvar{$name}{OTHER};

  }

  return $cmd;
}

# ------------------------------------------------------------------------------
# SYNOPSIS
#   &invoke_cmd ($cmd);
#
# DESCRIPTION
#   Invoke the command $cmd.
# ------------------------------------------------------------------------------

sub invoke_cmd {
  my $cmd      = $_[0];
  return unless $cmd;

  my $disp_cmd = 'fcm ' . $cmd;
  $cmd         = (index ($cmd, 'help ') == 0)
                 ? $disp_cmd
                 : ('fcm gui-internal ' . &get_wm_pos () . ' ' . $cmd);

  # Change directory to working copy top if necessary
  if ($subcmdvar{$selsubcmd}{USEWCT} and $subcmdvar{WCT} ne $subcmdvar{CWD}) {
    chdir $subcmdvar{WCT};
    $out_t->insert ('end', 'cd ' . $subcmdvar{WCT} . "\n");
    $out_t->yviewMoveto (1);
  }

  # Report start of command
  $out_t->insert ('end', timestamp_command ($disp_cmd, 'Start'));
  $out_t->yviewMoveto (1);

  # Open the command as a pipe
  if ($cmdpid = open CMD, '-|', $cmd . ' 2>&1') {
    # Disable all action buttons
    $action_b{$_}->configure ('-state' => 'disabled') for (keys %action_b);
    $cmdrunning = 1;

    # Set up a file event to read output from the command
    $mw->fileevent (\*CMD, readable => sub {
      if (sysread CMD, my ($buf), 1024) {
        # Insert text into the output text box as it becomes available
        $out_t->insert ('end', $buf);
        $out_t->yviewMoveto (1);

      } else {
        # Delete the file event and close the file when the command finishes
        $mw->fileevent(\*CMD, readable => '');
        close CMD;
        $cmdpid = undef;

        # Check return status
        if ($?) {
          $out_t->insert (
            'end', '"' . $disp_cmd . '" failed (' . $? . ')' . "\n",
          );
          $out_t->yviewMoveto (1);
        }

        # Report end of command
        $out_t->insert ('end', timestamp_command ($disp_cmd, 'End'));
        $out_t->yviewMoveto (1);

        # Change back to CWD if necessary
        if ($subcmdvar{$selsubcmd}{USEWCT} and
            $subcmdvar{WCT} ne $subcmdvar{CWD}) {
          chdir $subcmdvar{CWD};
          $out_t->insert ('end', 'cd ' . $subcmdvar{CWD} . "\n");
          $out_t->yviewMoveto (1);
        }

        # Enable all action buttons again
        $action_b{$_}->configure ('-state' => 'normal') for (keys %action_b);
        $cmdrunning = 0;

        # If the command is "checkout", change directory to working copy
        if (lc ($selsubcmd) eq 'checkout' && $subcmdvar{CHECKOUT}{URL}) {
          my $url = Fcm::Keyword::expand($subcmdvar{CHECKOUT}{URL});
          my $dir = $subcmdvar{CHECKOUT}{PATH}
                  ? $subcmdvar{CHECKOUT}{PATH}
                  : basename $url;
          $dir    = File::Spec->rel2abs ($dir);
          &change_cwd ($dir);

        # If the command is "switch", change URL
        } elsif (lc ($selsubcmd) eq 'switch') {
          $subcmdvar{URL_CWD} = &get_url_of_wc ($subcmdvar{CWD}, 1);
          $subcmdvar{URL_WCT} = &get_url_of_wc ($subcmdvar{WCT}, 1);
        }
      }
      1;
    });

  } else {
    $mw->messageBox (
      '-title'   => 'Error',
      '-message' => 'Error running "' . $cmd . '"',
      '-icon'    => 'error',
    );
  }

  return;
}

# ------------------------------------------------------------------------------

__END__

=head1 NAME

fcm_gui

=head1 SYNOPSIS

fcm_gui [DIR]

=head1 DESCRIPTION

The fcm_gui command is a simple graphical user interface for some of the
commands of the FCM system. The optional argument DIR modifies the initial
working directory.

=head1 COPYRIGHT

(C) Crown copyright Met Office. All rights reserved.

=cut