#!/usr/pkg/bin/perl
# gus_xml-rpc_client_tk.pl
# Copyright 2005 -2006 by Gan Uesli Starling
# XML-RPC client script written in Perl.
# See POD at EOF for full description.
# 3360 lines of code & 708 comment lines.

use Tk;
use Tk::Balloon;
use Getopt::Long;
use File::Basename;
use Frontier::Client;
use Sys::Hostname::Long;
use Log::Logger;
use strict;

our $formal_name      = 'XML-RPC Client GUI';
our $formal_date      = '2006-06-20';

use vars qw( $host_name );

# Get host name of this PC.
BEGIN { $host_name = hostname_long(); }

###########################################
# BEGIN THINGS USER CAN AND SHOULD CHANGE #
###########################################

# Full path to the line delimited, text file listing scripts which are safe to
# execute. The list may contain only file names, no paths or arguments. Decending
# directory paths are allow, but not any ascending ones. Be sure to enclose in
# single quotes.
our $script_list = '';

# Where the servers will listen. If you don't know what this is, best to
# set at either 8080 or its less common alternate of 8888. A default of 8080
# if left completely unset.
my $local_port = '';

# User's own default encryption key for startup.
# If left empty will fall back to GUS::Crypt package default.
my $cipher_key = '';

# Init an startup password. User later enters own.
# If left empty will fall back to 'XML-RPC'.
our $plain_pw = '';

# Default list of server URLs, if any.
my $url_list = '';

# NOTE: Any of the ABOVE user-options may be overridden by other values if
# started on command line or by script. For info, start on command line as
# exampled below (or use pull-down menu 'help -> options')...
# EXAMPLE: perl gus_xml-rpc_client_tk.pl --help

# Whether and how much of transactions to log.
# Set like so: 0 = No log; 1 = Rough info; 2 = Detailed info.
my $log_level = 1;

# How many logs to keep (when logging at all).
# Set like so: 0 = Same file always; 1 = New file each session.
my $log_multi = 0;

# Where to keep logs (when logging at all).
# Defaults to same directory as $script_list if left empty.
our $log_path = '';

# Whether to pop up darkseagreen background help
# windows with clues about various functions.
my $verbose_flag = 1;

# Used to filter whole lines from outgoing text during the 'add_doc_elsewhere'
# method. Inside the hash, each key and value is a regex, like so...
# '.*foobar\.txt$' => ['this', 'that', 'the other']
my %lines_to_skip;

#########################################
# END THINGS USER CAN AND SHOULD CHANGE #
#########################################
# BEGIN FALLBACK DEFAULTS #
###########################

# For when left completely unset at startup.
$local_port = 8080 unless $local_port =~ /[0-9]+/;
$host_name = '127.0.0.1' unless $host_name =~ /[0-9|A-Z|a-z]+/;
$plain_pw = 'XML-RPC' unless $plain_pw =~ /[0-9|A-Z|a-z]+/;

#########################
# END FALLBACK DEFAULTS #
##########################
# BEGIN OPTION OVERRIDES #
##########################

# For when options are given at startup on the command line.
my $help_flag = 0;
&GetOptions(
    "local_port=i"  => \$local_port,
    "script_list=s" => \$script_list,
    "cipher_key=s"  => \$cipher_key,
    "password=s"    => \$plain_pw,
    "url_list=s"    => \$url_list,
    "verbose"       => \$verbose_flag,
    "help=i"        => \$help_flag,
);

# For convenience of author only. All others may ignore or
# else change to suit own domains and/or purposes.
if ($host_name =~ /(amalekite|paulstra|milcom)/) {

    # Update docs.
    GUS::Document::make_html();

    # Take out non-interesting lines from files before
    # sending for upload to Apache server.
    %lines_to_skip = (
        'specimen\.log' => [
            'Web Watcher',
            'Information .Stmgr.',
            'Procedure Beginning',
            'Software Interlock',
            'Program interlock is set',
            'Cannot open file',
            'Counters', ' - ', 'Time',
            'Exiting', 'Entering',
        ],
    );

    # Some of author's test PCs.
    if ( $host_name =~ /amalekite/ ) {
        $script_list = '/home/aplonis/gus_pl/gus_xml-rpc_pl/safe_list.txt';
    }
    else {
        $script_list = 'C:/XML-RPC/safe_list.txt';
    }
}

########################
# END OPTION OVERRIDES #
###################################
# BEGIN STARTUP SECURITY MEASURES #
###################################

# Where passwords are remembered for later re-use.
my %prior_passwords;
$prior_passwords{format_DTG(time, 0) . ' (Startup)'} = $plain_pw;

# Where crypt settings are remembered for later re-use.
my %prior_cipher_keys;
$prior_cipher_keys{format_DTG(time, 0) . ' (Startup)'} = $cipher_key;

# Below are the clear-text XML-RPC method method used in subroutine definitions.
# Severly obfuscated variants thereof are what appear in network transmission.
my @method_names = qw (
    server_status
    server_log
    change_password
    change_cipher
    execute_script
    execute_command
    add_new_script
    add_doc_elsewhere
    remove_doc_elsewhere
    remove_scripts
    reboot_server
    kill_server
    relay_sql_query
);

# Make all keys of hash into same-length gibberish.
sub mk_obfuscation_hash {
    my $length = shift;
    my %hash;

    # Salt the input so will not be same every time.
    my $salt;
    $salt .= substr($plain_pw, 0, 3) if $plain_pw;
    $salt .= substr($cipher_key, 0, 3) if $cipher_key;

    foreach (@_) {
        $hash{$_} = GUS::Crypt::obfuscate(
            $salt . $_,
            $length,
        );
    }
    return %hash;
}

# Char length of values in hash to follow.
my $obfuscation_size = 32; # Used twice!


# Scalar to hold Blowfish cipher used for encryption.
my $cipher;

# Hash where obfuscated method name variants will be stored.
my %obfuscated;

# Create the cipher and obfuscation hash.
sub call_locksmith {
    my $cipher_key = shift;

    # Servers reply with a copy of their old cipher. So this client
    # change its cipher only now...after gathering all replies.
    $cipher = GUS::Crypt::brew_cipher(
        GUS::Crypt::grind_key($cipher_key, 56),
        'Blowfish', 1);

    # Using the new cipher, re-obfuscate method names.
    %obfuscated = mk_obfuscation_hash($obfuscation_size, @method_names);
}

# Create startup-default cipher and obfuscation hash.
call_locksmith($cipher_key);

# Cobble together a log file name.
my $log_fh;
sub init_log {
    # $log_fh->close() if defined $log_fh;
    if ( $log_level ) {
        my $log_name = $host_name . '_client';
        $log_name =~ s/\./_/g; # Lose dots from URL.

        # If new log each session, append date-time group.
        $log_name .= '_' . format_DTG(time, 1) if $log_multi;

        # Some OSes disallow filenames to start with numerals.
        $log_name = "URL_$log_name" if $log_name =~ /^[0-9]+/;

        # If left empty by user, revert to common directory.
        $log_path = dirname($script_list) if $log_path !=~ /[a-z|A-Z|0-9|_]+/;

        $log_fh = new Log::Logger "$log_path/$log_name.log"
            or print "Oops! Sub 'init_log' reports could not init file handle.\n";
    }
}

# Write output to log depending on user-choice logging level.
sub log_this {
    $log_fh->log( format_DTG(time, 0) . "\n$_[0]")
        if $log_level - $_[1] >= 0;
}

init_log();

# Give warning in case of non-secure, fallback key.
# Note: Do here, after both key and log are initialized.
if ( $GUS::Crypt::reply =~ /Oops!/ ) {
    GUS::pop_up_window::start_MainLoop(
        'gold', 'GUS::Crypt::grind key warns', $GUS::Crypt::reply,
        'Okay', sub{}, [],
        'Log', sub{ log_this($GUS::Crypt::reply, 1) }, [],
    ); # With optional 2nd button.
    $GUS::Crypt::reply = '';
}

#################################
# END STARTUP SECURITY MEASURES #
#################################
# BEGIN STARTUP DEFINITIONS #
#############################

# Used to open files in Tk.
my $file_types = [
    [ 'Perl',    '.pl',  'TEXT' ],
    [ 'Perl',    '.pm',  'TEXT' ],
    [ 'Python',  '.py',  'TEXT' ],
    [ 'Ruby',    '.rb',  'TEXT' ],
    [ 'C Shell', '.csh', 'TEXT' ],
    [ 'K Shell', '.ksh', 'TEXT' ],
    [ 'Shell',   '.sh',  'TEXT' ],
    [ 'TCL',     '.tcl', 'TEXT' ],
    [ 'Awk',     '.awk', 'TEXT' ],
    [ 'SEd',     '.sed', 'TEXT' ],
    [ 'PHP',     '.php', 'TEXT' ],
    [ 'Batch',   '.bat', 'TEXT' ],
    [ 'Batch',   '.cmd', 'TEXT' ],
    [ 'Any',     '.*',   'TEXT' ]
];

# Used to open files in Tk.
my $doc_file_types = [
    [ 'ASCII',   '.txt', 'TEXT' ],
    [ 'ASCII',   '.log', 'TEXT' ],
    [ 'ASCII',   '.dat', 'TEXT' ],
    [ 'Any',     '.*',   'TEXT' ]
];

# Sub used in command-line option overrides.
sub quick_help {
    my $help_msg = <<END_HERE;

USAGE:
$0 [ options ]

OPTIONS:
  --l[ocal_port]    Default local port of servers.
  --s[cript_list]   List of scripts for execute_script method
  --c[rypt_key]     Pass phrase for Blowfish encryption
  --p[assword]      Password sent from client to server
  --u[rl_list]      Full path to list of server ULRs
  --h[elp]          This message

EXAMPLES (long):
    gus_xml-rpc_client_tk.pl --local_port 8888
    gus_xml-rpc_client_tk.pl --script_list "C:/XML-RPC/safe_list.txt"
    gus_xml-rpc_client_tk.pl --cipher_key "Four score and..."
    gus_xml-rpc_client_tk.pl --password "Foobar"
    gus_xml-rpc_client_tk.pl --url_list "C:/XML-RPC/server_urls.txt"
    gus_xml-rpc_client_tk.pl --help

EXAMPLE (short):
    gus_xml-rpc_client_tk.pl --l 8888 --s "C:/XML-RPC/safe_list.txt" --p "Foobar"

NOTE:
If no command-line options given, scripted-in defaults apply.

END_HERE

    print "$help_msg"; # For CLI
    return $help_msg;  # For GUI
}

# Respond immediately to command-line help flag.
quick_help() if $help_flag;# Sub used in command-line option overrides.

# Header line common to all methods.
sub header_line {
    my $method_name = shift;
    my $line =  format_DTG(time, 0);
    $line .= " XML-RPC client at $host_name requests: \n";
    $line .= "Method = '$method_name'. ";
    foreach ( @_ ) { $line .= "\n$_. " }
    return "$line \n\n";
}

# A URL for each XML-RPC server as a constant.
# All these are behind a firewall.
my @server_urls = sort (
    "$host_name",
);

# For use as array ref with GUS::checklist_via_file package.
my @script_paths = ();

# Must init at startup lest user employ 'add_new_script' prior to
# running any old scripts. Why? Because it is the %scripts_hash which
# prevents duplicate listing of script by same name.
my ($reply, %scripts_hash) = GUS::checklist_via_file::lines_to_hash(
    \$script_list, 100);

# An array of clients from which to select.
my @clients = get_clients( @server_urls );
our @clients_subset = ();
use vars qw( @checks_urls );


###########################
# END STARTUP DEFINITIONS #
###########################
# BEGIN GUI STUFF #
###################

my $label_width = 12;
my $entry_width = 50;

# Colors for help info balloons and info message area.
my $balloon_bg = 'darkseagreen';
my $balloon_fg = 'black';

# First declare the main GUI frame and all her daughters.

my $mw = MainWindow->new( -title => " $formal_name" );

# Provide help info as balloon widgets.
my $help_info = $mw->Label(
    -borderwidth => 2,
    -relief      => 'groove',
    -background  => $balloon_bg,
    -foreground  => $balloon_fg,
);
my $balloon = $mw->Balloon(
    -statusbar       => $help_info,
    -balloonposition => 'mouse',
    -background      => $balloon_bg,
    -foreground      => $balloon_fg,
);
$balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );

# At least one sunken frame above flat frame for buttons,  etc.
my $frame_top = $mw->Frame(
    -relief      => 'sunken',
    -borderwidth => 5
);

my $frame_btm = $mw->Frame(
    -relief      => 'flat',
    -borderwidth => 5
);

# Begin MENU BAR
$mw->configure( -menu => my $menubar = $mw->Menu );

# Return true if current password previously used.
# Used to prevent widgets from from displaying when
# wholly unknown password is used...assuming user
# to be away from screen.
sub plain_pw_okay {
    my $flag = 0;
    my $reply = "Oops! Password not recognized.\n\n";
    foreach (values %prior_passwords) {
        $flag = 1 if $_ eq $plain_pw;
    }
    GUS::pop_up_window::start_MainLoop(
        'gold',
        'XML-RPC Client Warns',
        "\n$reply\n",
        'Okay', sub{}, [],
    ) unless $flag; # Sans optional 2nd button.
    return $flag;
}

# What shows in a hint pop-up when changing server cipher key.
my $server_key_doc = <<END_HERE;
Even though server URLs are unchecked, the current
password still matters. This is because a 'salt' is
employed to better randomize method obfuscation. The
current password is part of that salt.

It follows that in order for client and server to share
matching method obfuscations, their passwords must have
likewise matched when each generated its own cipher.

Thus if server later responds 'no such method', it means
that either a wrong cipher key or else a wrong password
was used to generate the cipher.

Such mismatches can be repaired from the client side by
unchecking all server URLs then generating the cipher anew
so as to exactly match with the server.
END_HERE

# What shows in a hint pop-up when changing client cipher key.
my $client_key_doc = <<END_HERE;
All server URLs have been unchecked so that they will
not be affected by the client changing its cipher key.
END_HERE

# Append identical info to header.
$client_key_doc .= "\n$server_key_doc";

# What shows in a hint pop-up when changing client password.
my $client_password_doc = <<END_HERE;
All server URLs have been unchecked so that they will
not be affected by the client changing its password.
END_HERE

# What shows in a hint pop-up when changing client password.
my $wrong_password_doc = <<END_HERE;
The password currently entered into the password entry box
at bottom of main window does not match any which are
recognized by the client.

Recognized passwords include that specified at startup plus
any new ones created with either of the two pull-down menus
entitled 'Client' and 'Servers'.

You could clear the password entry box any time when you
must leave the PC unattended for any reason.
END_HERE

# What shows in a hint pop-up when reverting to prior
# password or cipher key.
my $client_priors_doc = <<END_HERE;
At top of the radio button list is the startup value as
defined at the head of the script by the user...or if that
were left empty, the fallback default as defined by the
author.

Below that are any later creations made by the user via
a pull-down menu. The list is sorted by date of creation.

Only the client remembers prior definitions in this fashion.
The list is remembered as a convenience for such times as
when you have servers grouped into sets with different
cipher keys and passwords.
END_HERE

# What shows in a hint pop-up when executing a command.
my $execute_command_doc = <<END_HERE;
Be forwarned that very few keywords are exempted from
this feature at present. It will cheerfully let you do
very stupid things...lose data, crash the sytem, etc!

Further know that if what you type would hang on the
command line at the remote PC, then it will also hang
in the client. That is to say, the client will freeze
waiting for feedback from the frozen CLI window at the
remote PC.
END_HERE

# When verbose hinting is on, pop up a note relevent to
# just-clicked event.
sub verbose_hint {
    my $note = shift;
    GUS::pop_up_window::start_MainLoop(
        'darkseagreen', 'Verbose Hint',
        $note,
        'Close Hint', sub{}, [],
        'No More Hints', sub{ $verbose_flag = 0 }, [],
    ) if $verbose_flag; # With optional 2nd button.

}

# Get new cipher key and propagate it.
sub new_password {
    my $note = shift;

    # Determin if password was previously loaded.
    my $flag = plain_pw_okay();

    # Change verbose note if strange password.
    $note = $wrong_password_doc unless $flag;

    # Give verbose hint when so configured.
    verbose_hint($note) unless (scalar @clients_subset);

    # Change password if all is well.
    GUS::confirm_string::start_MainLoop(
        'Change Password',
        'Password',
        \&accept_new_password,
    ) if $flag;
}

# Pop up a window to select from among prior passwords
# provided that password in entry box is among that list.
sub prior_password {
    my $note = shift;

    # Determin if password was previously loaded.
    my $flag = plain_pw_okay();

    # Change verbose note if strange password.
    $note = $wrong_password_doc unless $flag;

    # Give verbose hint when so configured.
    verbose_hint($note);

    GUS::radio_list::start_MainLoop(
        'Prior Password',
        'Select: ',
        'Passwords listed by time of creation.',
        [sort keys(%prior_passwords)],
        sub { $plain_pw = $prior_passwords{$_[0]} },
    ) if $flag;
}


# Where is stored the file paths and repeat() returns
# for later canceling.
my %sendings;

# What shows in a hint pop-up when canceling the repeated
# sending of doc(s) elsewhere.
my $cancel_sendings_doc = <<END_HERE;
These are the documents currently being repeatedly sent
to clients as a result of having used the 'Send' button
some time earlier.

Select any which you want to repeatedly send no longer.

To delete from the server any such files as have already
been sent, use the 'Remove Sent' function.
END_HERE

# Pop up a window to select from among curent docs being
# repeatedly sent elsewhere from previous use of the 'Send'
# button.
sub cancel_sendings {
    my $note = shift;
    my $flag = plain_pw_okay();

    $note = $wrong_password_doc unless $flag;
    verbose_hint($note);

    my $list_hint = 'Cancel Sending:';
    my $sref = sub {
        $sendings{$_[0]}->cancel();
        delete $sendings{$_[0]};
    };

    # Inform and disable when none being sent.
    unless (%sendings) {
        $list_hint .= ' None being sent. ';
        $sref = sub {};
    }

    GUS::radio_list::start_MainLoop(
        'Repeatedly Sending',
        $list_hint,
        'List sorted by file path.',
        [sort keys(%sendings)],
        $sref,
        'Stop Sending','Never Mind',
    ) if $flag;
}

# Get new cipher key and propagate it.
sub new_cipher_key {
    my $note = shift;

    # Determin if password was previously loaded.
    my $flag = plain_pw_okay();

    # Change verbose note if strange password.
    $note = $wrong_password_doc unless $flag;

    # Give verbose hint when so configured.
    verbose_hint($note) unless (scalar @clients_subset);

    # Change cipher key if all is well.
    GUS::confirm_string::start_MainLoop(
        'Change Cipher Key',
        'Key Phrase',
        \&accept_new_cipher,
    ) if $flag;
}

# Pop up a window to select from among prior passwords
# provided that password in entry box is among that list.
sub prior_cipher_key {
    my $note = shift;

    # Determin if password was previously loaded.
    my $flag = plain_pw_okay();

    # Change verbose note if strange password.
    $note = $wrong_password_doc unless $flag;

    # Give verbose hint when so configured.
    verbose_hint($note);

    GUS::radio_list::start_MainLoop(
        'Prior Cipher Key',
        'Select: ',
        'Keys listed by time of creation.',
        [sort keys(%prior_cipher_keys)],
        sub {
            $cipher_key = $prior_cipher_keys{$_[0]};
            call_locksmith($cipher_key);
        },
    ) if $flag;
}

# Begin MENU CLIENT
my $menu_client = $menubar->cascade( -label => ' ~Client ' );
$menu_client->command(
    -label   => "Load URLs",
    -command => sub {load_server_urls() if plain_pw_okay()},
);

$menu_client->command(
    -label   => 'New Password',
    -command => sub {
        GUS::tk::clear_frame_label_checks(@checks_urls);
        @clients_subset = ();
        new_password($client_password_doc);
    },
);

$menu_client->command(
    -label   => "New Cipher Key",
    -command => sub {
        GUS::tk::clear_frame_label_checks(@checks_urls);
        @clients_subset = ();
        new_cipher_key($client_key_doc);
    },
);

# Menu will not pop up unless password is most current.
$menu_client->command(
    -label   => "Prior Password",
    -command => sub { prior_password($client_priors_doc) },
);

# Menu will not pop up unless password is known.
$menu_client->command(
    -label   => "Prior Cipher Key",
    -command => sub { prior_cipher_key($client_priors_doc) },
);

# Menu will not pop up unless password is known.
$menu_client->command(
    -label   => "Currently Sending",
    -command => sub { cancel_sendings($cancel_sendings_doc) },
);

# Begin MENU SERVERS
my $menu_servers = $menubar->cascade( -label => ' ~Servers ' );
$menu_servers->command(
    -label   => "View Logs",
    -command => sub {view_server_log() if plain_pw_okay()},
);
$menu_servers->command(
    -label   => 'New Password',
    -command => sub {
        GUS::confirm_string::start_MainLoop(
            'Change Server Password',
            'Password',
            \&accept_new_password,
        ) if plain_pw_okay();
    },
);
$menu_servers->command(
    -label   => "New Cipher Key",
    -command => sub { new_cipher_key($server_key_doc)},
);
$menu_servers->command(
    -label   => 'Remove Scripts',
    -command => sub {
        GUS::get_string::start_MainLoop(
            'Remove Scripts',
            'Script',
            'Enter exact name to match single script or regular expression for plural.',
            [\&accept_deletion_regex],
        ) if plain_pw_okay();;
    },
);
$menu_servers->command(
    -label   => 'Remove Sent',
    -command => sub {
        GUS::get_string::start_MainLoop(
            'Remove Sent',
            'Document',
            'Enter exact name to match single doc or file glob for plural.',
            [\&accept_deletion_glob],
        ) if plain_pw_okay();;
    },
);

# Begin MENU DANGEROUS
my $menu_dangerous = $menubar->cascade( -label => ' At ~Your Hazard! ' );
$menu_dangerous->command(
    -label   => "Reboot Server",
    -command => sub {
        if (plain_pw_okay()) {
            my $replies = header_line('reboot_server');
            $replies .= join '', reboot_server_plural( @clients_subset );
            GUS::pop_up_window::start_MainLoop(
                'white', 'XML-RPC Server Replies', $replies,
                'Okay', sub{}, [],
                'Log', sub{ log_this($replies, 1) }, [],
            ); # With optional 2nd button.
        }
    },
);
$menu_dangerous->command(
    -label   => "Add New Script",
    -command => sub {
        if (plain_pw_okay()) {
            my $file_path = $mw->getOpenFile( -filetypes => $file_types );

            # User might pick cancel, getting empty return.
            if ($file_path) {
                GUS::confirm_script::check_ascii_only(
                    $file_path,
                    \&accept_new_script,
                    0,
                );
            }
        }
    },
);
$menu_dangerous->command(
    -label   => 'Execute Command',
    -command => sub {
        verbose_hint($execute_command_doc);
        GUS::get_string::start_MainLoop(
            'Execute Command',
            'Command',
            'Carefully enter exact command to be executed.',
            [\&execute_command_plural, @clients_subset],
        ) if plain_pw_okay();;
    },
);

# There must be a TAB after each URL.
my $sql_relay_doc = <<END_HERE;
Assuming you have a database server (PostgreSQL,
MySQL, etc.) on the same PC as the XML-RPC server,
then you may relay single SQL queries to it.

Each call will execute as follows:

    1. Open a new connection to the DB.
    2. Pass a single SQL query.
    3. Close the connection to the DB.
    4. Display SQL response rows.

The only advantage in submitting SQL via XML-RPC in
this way is to detour blocked ports on a firewall.
For that you need to also be ruinning the companion
CGI bridge script.
END_HERE

# Begin MENU RELAYS
my $menu_extras = $menubar->cascade( -label => ' ~Relays ' );
$menu_extras->command(
    -label   => 'SQL Queries',
    -command => sub {
        verbose_hint($sql_relay_doc);
        GUS::SQL_Panel::start_MainWindow();
    },
);

# There must be a TAB after each URL.
my $example_url_doc = <<END_HERE;
# Comment line at top needs pound sign.
merlin.foobar.com	Foobar Corp
192.168.0.2 Some other PC
192.168.0.3 Yet another PC
$host_name:80   Other side of firewall
$host_name/cgi-bin/gus_xml-rpc_bridge.pl:80 Likewise
END_HERE

# List of file names.
my $example_safe_scripts_doc = <<END_HERE;
# Comment line at top needs pound sign.
For_Any_OS.pl
For_Any_OS.py
For_Any_OS.rb
For_Unix.sh
For_Unix.csh
For_Unix.ksh
For_Win32.bat
For_Win32.cmd
wants_args.pl arg_1 arg_2
"has spaces.pl" "arg 1" "arg 2"
END_HERE

# Begin MENU EXAMPLE
my $menu_examples = $menubar->cascade( -label => ' ~Examples ' );
$menu_examples->command(
    -label   => "Server URLs List as *.txt",
    -command => sub {
        GUS::pop_up_window::start_MainLoop(
            'white', 'Note: Use TAB between URL and descriptive text!',
            $example_url_doc,
            'Close', sub{}, [],
        ); # No 2nd button.
    },
);$menu_examples->command(
    -label   => "Safe Scripts List as *.txt",
    -command => sub {
        GUS::pop_up_window::start_MainLoop(
            'white', 'Note: File names and args. Quote if has spaces',
            $example_safe_scripts_doc,
            'Close', sub{}, [],
        ); # No 2nd button.
    },
);

# Begin MENU HELP
my $menu_help = $menubar->cascade( -label => ' ~Help ' );
$menu_help->command(
    -label   => "About",
    -command => sub { GUS::help_about::start_MainLoop() },
);
$menu_help->command(
    -label   => "Startup",
    -command => sub {
        GUS::pop_up_window::start_MainLoop(
            'white', 'Startup Options', quick_help(),
            'Close', sub{}, [],
        ); # No 2nd button.
    },
);
$menu_help->command(
    -label   => "POD",
    -command => sub {
        GUS::pop_up_window::start_MainLoop(
            'white', 'Plain Old Documentation',
            GUS::Document::pod_as_text(),
            'Close', sub{}, [],
        ); # No 2nd button.
    },
);
$menu_help->command(
    -label   => "HTML",
    -command => sub {
        GUS::Document::make_html();
        GUS::pop_up_window::start_MainLoop(
            'white', 'HTML',
            "POD translated to HTML in path below:\n$GUS::Document::html_path",
            'Close', sub{}, []
        ); # No 2nd button.
    },
);
$menu_help->command(
    -label   => "Hint Verbosely",
    -command => sub { $verbose_flag = 1 },
);

################################
# Begin non-template GUI stuff #
################################

display_server_urls( @server_urls );

my @buttons_methods = GUS::tk::frame_label_buttons(
    $frame_btm,
    'Methods:',
    [ 'Status', 'Execute', 'Send', 'Kill', 'Quit' ],
    [
        sub {
            if (plain_pw_okay()) {
                my $replies = header_line( 'server_status' );
                $replies .= join '', server_status_plural( @clients_subset );
                GUS::pop_up_window::start_MainLoop(
                    'white', 'XML-RPC Server Replies', $replies,
                    'Okay', sub{}, [],
                    'Log', sub{ log_this($replies, 1) }, [],
                ); # With optional 2nd button.
            }
        },
        sub {
            if (plain_pw_okay()) {
                my $reply = '';

                # In a new Tk window, build a checklist from lines of a file.
                # When array has selections, trigger sub to act upon it.
                GUS::checklist_via_file::start_MainLoop(
                    'white',
                    'Executable Scripts',
                    'Files & Arguments',
                    $script_list,
                    \@script_paths,
                    \&script_from_selected_files,
                    \%scripts_hash,
                    \$reply,
                );
                log_this($reply, 2) if $reply;
            }
        },
        sub {
            if (plain_pw_okay()) {
                my $file_path = $mw->getOpenFile( -filetypes => $doc_file_types );
                GUS::get_string::start_MainLoop(
                    'Compose File Name Prefix',
                    'Prefix:',
                    'To differentiate similarly named files:',
                    [\&send_repeatedly, $file_path],
                );
            }
        },
        sub {
            if (plain_pw_okay()) {
                GUS::pop_up_window::start_MainLoop(
                    'orange', 'Confirm Request',
                    "Killed servers cannot be remotely restarted.\n" .
                    "Are you sure that you want to do this?",
                    'Kill', sub{ kill_server_plural( @clients_subset ) }, [],
                    'Ignore', sub {}, [],
                ); # With optional 2nd button.
            }
        },
        \&quit_MainLoop,
    ],
    [
        'green',
        'red',
        'gold',
        'orange',
        'blue',
    ]
);

# Supply user hints to method buttons.
$balloon->attach(
    $buttons_methods[2],
    -balloonmsg => 'Get echos?',
    -statusmsg => 'Ask servers to harmlessly echo their status. No other action is taken.'
);
$balloon->attach(
    $buttons_methods[3],
    -balloonmsg => 'Run a script?',
    -statusmsg => 'Browse for a script. Ask servers to execute own copy. Results may be dangerous!'
);
$balloon->attach(
    $buttons_methods[4],
    -balloonmsg => 'Send a document?',
    -statusmsg => 'Browse for a document. Ask servers to copy it where they think best.'
);
$balloon->attach(
    $buttons_methods[5],
    -balloonmsg => 'Kill servers?',
    -statusmsg => 'Request servers to die. Killed servers on remote PCs may not easily be restarted.'
);
$balloon->attach(
    $buttons_methods[6],
    -balloonmsg => 'Exit?',
    -statusmsg => "Quit this XML-RPC client GUI. Has no effect on running servers."
);

my $send_feedback_flag;

# Send a file now.
sub send_now {
    my ($prefix, $file_path, $snapshot_aref) = @_;
    GUS::confirm_script::check_ascii_only(
        $file_path,
        \&send_doc_elsewhere,
        1,
        $prefix,
        $snapshot_aref,
    );
};

# Send at intervals for fixed period.
sub send_now_and_again {
    my ($prefix, $file_path, $i, $j) = @_;

    # User might pick cancel, getting empty return.
    if ($file_path) {

        # Retain snapshot of current GUI settings. This so as to
        # not crash any later repeats should same GUI is used for
        # possible further transactions with different clients, etc.
        # Very especially so that user may clear the password entrybox.
        my $snapshot_aref = [
            $plain_pw,
            $cipher,
            @clients_subset,
        ];

        # Send immediately once;
        $send_feedback_flag = 1;
        send_now($prefix, $file_path, $snapshot_aref);
        $send_feedback_flag = 0;

        # Send again repeatedly if needed.
        if ($i > 0) {
            $sendings{"$file_path"} = $mw->repeat(
                int(1000*60*60*$i),
                sub {send_now($prefix, $file_path, $snapshot_aref)}
            );
            $mw->after(
                1000*60*60*$j,
                sub {
                    $sendings{"$file_path"}->cancel();
                    delete $sendings{"$file_path"};
                }
            ) if $j && exists $sendings{"$file_path"};
        }
    }
}

sub send_repeatedly {
    GUS::scales::start_MainLoop(
        "Send Schedule",
        "Enter repeat interval and cancel period in hours:",
        [\&send_now_and_again, @_],
        " Repeat ", 0, 24, 0.1, 'horizontal',
        " Cancel ", 0, 24 * 7, 1, 'horizontal',
    );
}

# For entry of password as security measure.
my @security = GUS::tk::frame_label_entry(
    $frame_btm,
    'Password:',
    \$plain_pw,
);

# Being for password entry, obscure the text.
$security[2]->configure( -show => '*');

# Supply user hints about security.
$balloon->attach(
    $security[2],
    -balloonmsg => 'Enter password.',
    -statusmsg => 'Without correct password, most client widgets ignore the mouse and all servers deny requests.'
);

$frame_top->pack( -side => 'top', -expand => 1, -fill => 'both' );
$help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );
$frame_btm->pack( -side => 'top', -expand => 0, -fill => 'x' );

$mw->after(100, sub { load_server_urls($url_list) if $url_list;});

MainLoop;

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw->destroy() if Tk::Exists($mw);
    GUS::help_about::quit_MainLoop();
    GUS::get_string::quit_MainLoop();
    GUS::confirm_string::quit_MainLoop();
    GUS::pop_up_window::quit_MainLoop();
    GUS::checklist_via_file::quit_MainLoop();
    GUS::radio_list::quit_MainLoop();
    GUS::SQL_Panel::quit_MainLoop();
}

#################
# End GUI stuff #
#############################
# Begin XML-RPC Method Subs #
#############################

# Get harmless response from one server.
sub server_status {
    my $reply = $_[0]->call( $obfuscated{'server_status'}, $_[-1] );
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Get harmless response from plural servers.
sub server_status_plural {
    my @replies = ();
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    foreach (@_) {

        # So that script will not die on first failure to connect to
        # a given XML-RPC server, perform call inside an eval.
        unless ( eval { push @replies, server_status($_, $cipher_pw) } ) {
            push @replies, "Oops! $@ \n";
        }
    }
    return @replies;
}

# Get harmless response from one server.
sub server_log {
    my $reply = $_[0]->call( $obfuscated{'server_log'}, $_[-1] );
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Get harmless response from plural servers.
sub server_log_plural {
    my @replies = ();
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    foreach (@_) {

        # So that script will not die on first failure to connect to
        # a given XML-RPC server, perform call inside an eval.
        unless ( eval { push @replies, server_log($_, $cipher_pw) } ) {
            push @replies, "Oops! $@ \n";
        }
    }
    return @replies;
}

# Change the password on the server.
sub change_password {
    my $reply = $_[0]->call($obfuscated{'change_password'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Change the password on plural servers, then on the client.
sub change_password_plural {
    my $new_pw = shift;
    my $payload = GUS::Crypt::gus_crypt($cipher, $new_pw, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt($cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();
    foreach (@_) {
        unless ( eval { push @replies, change_password($_, $payload, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Change the cipher key on the server.
sub change_cipher {
    my $reply = $_[0]->call( $obfuscated{'change_cipher'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Change the cipher key on plural servers.
sub change_cipher_plural {
    $cipher_key = shift;
    my $payload = GUS::Crypt::gus_crypt( $cipher, $cipher_key, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();
    foreach (@_) {
        unless ( eval { push @replies, change_cipher($_, $payload, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Execute a file on one server.
# A possibly dangerous do-anything sub.
sub execute_script {
    my $reply = $_[0]->call($obfuscated{'execute_script'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Execute same file on plural servers.
sub execute_script_plural {
    my $file_path = shift;
    my $payload = GUS::Crypt::gus_crypt( $cipher, $file_path, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();
    foreach (@_) {
        unless ( eval { push @replies, execute_script($_, $payload, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Execute a file on one server.
# A possibly dangerous do-anything sub.
sub execute_command {
    my $reply = $_[0]->call($obfuscated{'execute_command'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Execute same command on plural servers.
# Undoubtedly a dangerous do-anyting sub.
sub execute_command_plural {
    my $command = shift;
    my $payload = GUS::Crypt::gus_crypt( $cipher, $command, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();
    foreach (@_) {
        unless ( eval { push @replies, execute_command($_, $payload, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }

    # Differs from other methods in that there is no return.
    # There is no return because only one command, not several may be issued.
    show_replies(join('', @replies), 'execute_command');
}

# Add a new script to one server.
# A probably dangerous thing to do.
sub add_new_script {
    my $reply = $_[0]->call($obfuscated{'add_new_script'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Add same new script to plural servers.
sub add_new_script_plural {
    my $all_in_one = shift;
    my $payload = GUS::Crypt::gus_crypt( $cipher, $all_in_one, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();
    foreach (@_) {
        unless ( eval { push @replies, add_new_script($_, $payload, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Remove scripts from the server.
sub remove_scripts {
    my $reply = $_[0]->call($obfuscated{'remove_scripts'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Add same new script to plural servers.
sub remove_scripts_plural {
    my $reg_exp = shift;
    my $payload = GUS::Crypt::gus_crypt( $cipher, $reg_exp, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();
    foreach (@_) {
        unless ( eval { push @replies, remove_scripts($_, $payload, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Add a new doc to one server.
# Different from sibling subs because cipher is passed in as arg.
sub add_doc_elsewhere {
    my $reply = $_[0]->call($obfuscated{'add_doc_elsewhere'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $_[3], $reply, 'decrypt', 64) . "\n";
}

# Add a doc to plural servers.
# Different from sibling subs the Tk after/repeat method can be envolved.
# Thus a snapshot of once-current password, cipher and client array are fed in.
sub add_doc_elsewhere_plural {
    my $all_in_one = shift;
    my $plain_pw = shift;
    my $cipher = shift;
    my $payload = GUS::Crypt::gus_crypt( $cipher, $all_in_one, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();

    # The rest of @$snapshot_aref is historical snapshot of clients.
    foreach (@_) {
        unless ( eval { push @replies, add_doc_elsewhere($_, $payload, $cipher_pw, $cipher) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Remove doc pervriously sent elsewhere by the server.
sub remove_doc_elsewhere {
    my $reply = $_[0]->call($obfuscated{'remove_doc_elsewhere'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Remove doc previously sent elsewhere by plural servers.
sub remove_doc_elsewhere_plural {
    my $reg_exp = shift;
    my $payload = GUS::Crypt::gus_crypt( $cipher, $reg_exp, 'encrypt', 64);
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    my @replies = ();
    foreach (@_) {
        unless ( eval { push @replies, remove_doc_elsewhere($_, $payload, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Order single server to reboot.
sub reboot_server {
    my $reply = $_[0]->call($obfuscated{'reboot_server'}, $_[1]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Order selected servers to all reboot.
sub reboot_server_plural {
    my @replies = ();
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    foreach (@_) {
        unless ( eval { push @replies, reboot_server($_, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Order single server to die.
sub kill_server {
    my $reply = $_[0]->call($obfuscated{'kill_server'}, $_[1]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Order selected servers to all die.
sub kill_server_plural {
    my @replies = ();
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    foreach (@_) {
        unless ( eval { push @replies, kill_server($_, $cipher_pw) } ) {
            push @replies, "\nOops! $@";
        }
    }
    return @replies;
}

# Get postgreSQL response from one server.
sub relay_sql_query {
    my $reply = $_[0]->call( $obfuscated{'relay_sql_query'}, $_[1], $_[2]);
    return GUS::Crypt::gus_crypt( $cipher, $reply, 'decrypt', 64) . "\n";
}

# Get postgreSQL response from plural servers.
sub relay_sql_query_plural {
    my $sql_args = shift;
    $sql_args = GUS::Crypt::gus_crypt( $cipher, $sql_args, 'encrypt', 64);
    my @replies = ();
    my $cipher_pw = GUS::Crypt::gus_crypt( $cipher, $plain_pw, 'encrypt', 64);
    foreach (@_) {

        # So that script will not die on first failure to connect to
        # a given XML-RPC server, perform call inside an eval.
        unless ( eval { push @replies, relay_sql_query($_, $sql_args, $cipher_pw) } ) {
            push @replies, "Oops! $@ \n";
        }
    }
    return @replies;
}

###########################
# End XML-RPC Method Subs #
###########################
# Begin Misc Subs #
###################

# Display a pop-up window containing feedback from servers.
sub show_replies {
    my $text = shift;
    $text = header_line(@_) . $text;
    GUS::pop_up_window::start_MainLoop(
        'white',
        'XML-RPC Servers Reply',
        $text,
        'Close', sub{}, [],
        'Log', sub{ log_this($text, 1); }, [],
    ); # With optional 2nd button.
}

# Disply server logs.
sub view_server_log {
    my $replies .= join '', server_log_plural( $_[0], @clients_subset );
    show_replies($replies, 'server_log');
}

# Keep new password.
sub accept_new_password {
    my $replies .= join '', change_password_plural( $_[0], @clients_subset );
    show_replies($replies, 'change_password');

    $plain_pw = $_[0];

    # Remember for later restoration.
    $prior_passwords{format_DTG(time, 0)} = $plain_pw;
}

# Keep new encryption key.
sub accept_new_cipher {
    my $replies .= join '', change_cipher_plural( $_[0], @clients_subset );
    show_replies($replies, 'change_cipher');

    $cipher_key = $_[0];
    call_locksmith($cipher_key);

    # Remember for later restoration.
    $prior_cipher_keys{format_DTG(time, 0)} = $cipher_key;
}

# Append to local list of executable scripts.
sub remember_script_name {
    my $name = shift;
    if ( open LIST, ">>$script_list" ){
        print LIST "$name\n";
        close LIST;
    }
    else {
        my $reply = "Oops! Could not open path '$script_list': $!";
        GUS::pop_up_window::start_MainLoop(
            'gold', 'Error',
            $reply,
            'Close', sub{}, [],
        );
        log_this("$reply at sub 'remember_script_name'.", 1);
   }
}

# Keep new script.
sub accept_new_script {

    # 1st arg is name. Make it acceptable to any OS.
    my $name = shift;
    $name =~ s/!(0-9|A-Z|a-z|_)/_/g;
    $name =~ s/__/_/;

    # Combine the $file_name and all lines from array ref as below. Done so as to
    # not distinguish this item of traffic from that of other methods by virtue of
    # its having two payloads.
    # Joined with nulls because server OS may be different. Best to let it
    # reassemble strings using own line seperator char(s).
    my $lines_aref = shift;
    my $all_in_one = "$name\000" . join "\000", @$lines_aref;

    my $replies .= join '', add_new_script_plural( $all_in_one, @clients_subset );
    show_replies($replies, 'add_new_script');

    # Append to list file if not seemingly there already.
    # Note: The hash must be (and is) initialized at startup.
    remember_script_name($name) unless exists($scripts_hash{"$name"});
}

# Transmit a doc for server to store in path outside its usual directory.
# Similar to sub 'accept_new_script' except that does not 'remember'.
sub send_doc_elsewhere {

    # 1st arg is name. Make it acceptable to any OS.
    my $name = shift;
    $name =~ s/!(0-9|A-Z|a-z|_)/_/g;
    $name =~ s/__/_/;

    # Combine the $file_name and all lines from file as below.
    my $lines_aref = shift;
    cull_certain_lines($name, $lines_aref);
    my $all_in_one = "$name\000" . join "\000", @$lines_aref;

    # Call with historical snapshot of password, cipher and clients.
    my $snapshot_aref = shift;
    my $replies .= join '', add_doc_elsewhere_plural( $all_in_one, @$snapshot_aref );
    show_replies($replies, 'add_doc_elsewhere') if $send_feedback_flag;
}

# Remove whole lines from all_in_one doc if name matches
# key (which is a regex) in %lines_to_skip hash. This is so
# that bandwith is reduced by removal of useless info.
sub cull_certain_lines {
    my ($name, $lines_aref) = @_;
    while (my ($key, $value_aref) = each %lines_to_skip) {
        next unless $name =~ /$key/;
        foreach my $skip_this (@$value_aref) {
            my @kept_lines = ();
            foreach my $line (@$lines_aref) {
                next if $line =~ /$skip_this/;
                push @kept_lines, $line;
            }
            @$lines_aref = @kept_lines;
        }
    }
}

# Toss existing script info.
sub accept_deletion_regex {
    my $reg_exp = shift;

    my $replies .= join '', remove_scripts_plural( $reg_exp, @clients_subset );
    show_replies($replies, 'remove_scripts');

    # Delete from client PC also.
    unless ($replies =~ /Oops!/) {
        my $i = forget_script_names($reg_exp);
        $replies .= "\tTotal script names forgotten: $i \n";
        $replies .= rewrite_script_list() if $i > 0;
    }
    GUS::pop_up_window::start_MainLoop(
        'white',
        'XML-RPC Client Reports:',
        $replies,
        'Close', sub{}, [],
        'Log', sub{ log_this($replies, 1); }, [],
    ); # With optional 2nd button.
}

# Remove from hash of script names used as reference.
sub forget_script_names {
    my $reg_exp = shift;
    my $i = 0;
    foreach (keys %scripts_hash) {
        next unless $_ =~ /$reg_exp/;
        delete $scripts_hash{"$_"};
        ++$i;
    }
    return $i;
}

# Remove deleted script name from file listing names for 'execute_script' method.
# This is so that it stays gone and will not re-appear by closing/opening client.
sub rewrite_script_list {
    if (open LIST, ">$script_list") {
        foreach (keys %scripts_hash) { print LIST "$_\n" }
        close LIST;
        return "Okay! Safe scripts reference list re-written to '$script_list'.\n";
    }
    else { return "Oops! Sub 'rewrite_script_list' could not write to '$script_list': $!\n" }
}

# Have selected servers remove doc(s) previously sent.
sub accept_deletion_glob {
    my $glob = shift;

    my $replies .= join '', remove_doc_elsewhere_plural( $glob, @clients_subset );
    show_replies($replies, 'remove_sent');

    GUS::pop_up_window::start_MainLoop(
        'white',
        'XML-RPC Client Reports:',
        $replies,
        'Close', sub{}, [],
        'Log', sub{ log_this($replies, 1); }, [],
    ); # With optional 2nd button.
}

sub script_from_selected_files {
    my $replies = '';
    foreach ( @script_paths ) {
        $replies .= join '', execute_script_plural( $_, @clients_subset );
    }
    my $paths_list = join "', '", @script_paths;
    show_replies($replies, 'execute_script', "Paths = '$paths_list'");
    @script_paths = ();
}

# As a sub so can change list by loading text file.
sub display_server_urls {

    # Clear away old checkbuttons.
    foreach ( @checks_urls[0..2] ) {
        $_->destroy() if Tk::Exists($_);
    }

    my ( @urls, @urls_on, @urls_off, @urls_checked, @urls_cmd );

    foreach ( @_ ) {
        push @urls,        $_;
        push @urls_on,      1;
        push @urls_off,     0;
        push @urls_checked, 0;
        push @urls_cmd,     \&get_clients_subset;
    }

    # Build a frame, label and checkboxes.
    @checks_urls = GUS::tk::frame_label_checks(
        $label_width,
        $frame_top,
        'Server URLs:',
        \@urls,                 # Channels
        \@urls_on,              # on-value refs
        \@urls_off,             # off-value refs
        \@urls_checked,         # checked or not
        \@urls_cmd,             # actions taken when checked
        'top',                  # How to align checkbuttons
    );

    # Attach a balloon to each widget.
    for ( my $j = 2 ; $j < $#checks_urls ; $j += 2 ) {
        $balloon->attach(
            $checks_urls[$j],
            -balloonmsg => 'Select this URL?',
            -statusmsg => 'Check to include this URL in next method.'
        );
    }
}

# Load server URLs from text file
sub load_server_urls {
    my $file_path = shift;
    $file_path =~ s{\\}{\/}g; # Perlify file path.
    if ($file_path) { $file_path = "$file_path" }
    else { $file_path = $mw->getOpenFile(-filetypes => $doc_file_types) }

    if ( open TEXT, $file_path ) {
        my $ascii_pound = "\043"; # Confuses editor syntax highlighting.
        my @server_urls = ();
        while (<TEXT>) {
            next if $_ =~ /^$ascii_pound/;
            chomp $_ ;
            push @server_urls, formalize_server_url($_);
        }
        @server_urls = sort @server_urls;
        display_server_urls(@server_urls);
        @clients = get_clients( @server_urls );
        log_this("Server URLs loaded from $file_path.", 2);
    }
    else {
        my $reply = "Oops! Could not open path '$file_path': $!";
        GUS::pop_up_window::start_MainLoop(
            'gold', 'Error',
            $reply,
            'Close', sub{}, [],
        );
        log_this("$reply at sub 'load_items_list'.", 2);
   }
}

# Read in a script for transmission to servers.
sub load_new_script {
    my $file_path = shift;
    my @file_lines = ();
    if ( open TEXT, $file_path ) {
        while (<TEXT>) {
            # chomp $_;
            push @file_lines, $_;
        }
    }
    else {
        my $reply = "Oops! Could not open path '$file_path': $!";
        GUS::pop_up_window::start_MainLoop(
            'gold', 'Error',
            $reply,
            'Close', sub{}, [],
        );
        log_this("$reply at sub 'load_new_script'.", 2);
   }
   return @file_lines;
}

# Return an array of clients from array of urls.
sub get_clients {
    my @clients;
    foreach (@_) {
        $_ =~ s/RPC2.*/RPC2/; # Lose plain text ID.
        push @clients, Frontier::Client->new(
            url   => formalize_server_url($_),
            debug => 0,
        );
    }
    return @clients;
}

sub formalize_server_url {

    # Clean up first. May have MS-DOS (plural) line endings.
    $_ =~ s/^\s*//;
    $_ =~ s/\s*$//;

    # Segregate auxilliary plain-text ID from the URL.
    my $aux_txt = '';
    $aux_txt = $_ if $_ =~ /\t/;
    $aux_txt =~ s/.*\t//;

    # Quicker to strip than test for these.
    $_ =~ s/\t.*//;
    $_ =~ s/http(s)?:\/\///;
    $_ =~ s/\/RPC2//;

    # Add default port if port not there already.
    $_ .= ":$local_port" unless $_ =~ /(cgi-bin|:[0-9]+)/;

    # Add required XML-RPC URL elems. Although 'cgi-bin' is
    # excepted, is better to adapt the Apache server as shown
    # below (path is for NetBSD OS):
    # ScriptAlias /RPC2 /usr/pkg/libexec/cgi-bin/gus_xml-rpc_bridge.pl
    $_ .= '/RPC2' unless $_ =~ /cgi-bin/;
    $_ = "http://$_";

    # Not supported by Frontier, yet. But accomodated here for when
    # later it might be.
    $_ =~ s/^http/https/ if $_ =~ /:443/;

    # Add aux text to checkbox as extra ID if present.
    $_ .= qq|  @  "$aux_txt"| if $aux_txt ne '';

    return $_;
}

# Collect a client for each available XML-RPC server.
# Gives no return, adjusts global array in place.
sub get_clients_subset {
    @clients_subset = ();
    my $i = 0;
    foreach ( GUS::tk::poll_frame_label_checks(@checks_urls) ) {
        if ($_) { push @clients_subset, $clients[$i] }
        ++$i;
    }
}

# Return Date Time Group.
sub format_DTG {
    my (
        $sec, $min, $hour,
        $mday, $mon, $year,
        $wday, $yday, $isdst
    ) = localtime($_[0]);

    #  The ISO 8601 approved way for text.
    my $DTG = sprintf(
        "%04d-%02d-%02d %02d:%02d:%02d",
        $year + 1900, $mon + 1,
        $mday, $hour, $min, $sec
    );

    # Or sans colons and spaces for file names.
    if ($_[1]) {
    	$DTG =~ s/:/-/g;
    	$DTG =~ s/\s/_/g;
    }
    return ("$DTG");
}

sub encrypt_rand {
    return
        crypt $_[0],
        join '', ('.', '/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64];
}

#################
# End misc subs #
#################

END {
    log_this("Shutdown of XML-RPC client at URL $host_name.", 1);
    $log_fh->close();
}

################################################################################
################################################################################
##                      GUS PACKAGES -- STANDARD SET                          ##
##                  FOR USE UNEDITED ACROSS ANY PROGRAM                       ##
##                          VERSION 2005-09-12                                ##
################################################################################
################################################################################

################################
# Begin GUS Tk widgets Package #
# Version 2005-10-31           #
################################

# A separate package for ease of re-use.

package GUS::tk;

use Tk;
use Tk::Pane;
use Tk::DirTree;

use vars qw( $debug_flag $widget_id $label_width $entry_width $button_width $text_height $text_width $file_basename $feedback $color_bg $color_fg $color_bg_balloon $color_fg_balloon $color_bg_active $color_bg_inactive );

BEGIN {
    $debug_flag          = 0;
    $widget_id           = 0;
    $label_width         = 12;
    $entry_width         = 12;
    $button_width        = 12;
    $main::file_basename = 'foo.txt' unless defined $main::file_basename;
}

use vars qw(
  %frame
  $dir_toplevel
);

# Used in label widgets, to avoid char clipping.
sub allow_wider {
    my ($text, $width) = @_;
    my $measure = length $text;
    $width = $measure if $width < $measure;
    return $width;
}

sub new_widget { $widget_id++; return $widget_id; }

# Automate the build of a lable & entry wiget set inside GUS::tk frame.
sub frame_label_entry {
    my ( $parent, $label_text, $text_var_ref ) = @_;
    my @widgets = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $label_text ",
    )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Scrolled(
        'Entry',
        -textvariable => $text_var_ref,
        -width        => $entry_width,
        -background   => "white",
        -foreground   => 'blue',
        -relief       => 'sunken',
        -font         => 'courier'
      )->pack(
        -side   => 'left',
        -expand => 1,
        -fill   => 'x'
      );
    return @widgets;
}

# Automate the build of a lable & entry wiget set inside GUS::tk frame.
sub frame_label_listbox {
    my ( $parent, $label_text, $list_ref, $selectmode, $takefocus ) = @_;
    my @widgets = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $label_text ",
    )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Scrolled(
        'Listbox',
        -selectmode   => $selectmode,
        -takefocus    => $takefocus,
        -width        => $entry_width,
        -background   => "white",
        -foreground   => 'blue',
        -relief       => 'sunken',
        -font         => 'courier'
      )->pack(
        -side   => 'left',
        -expand => 1,
        -fill   => 'x'
      );
    return @widgets;
}


# Automate the build of a lable & set of entry widgets set inside GUS::tk frame.
sub frame_label_entries {
    my $parent     = shift;
    my $label_text = shift;
    my @widgets    = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $label_text",
    )->pack( -side => 'left' );

    foreach my $text_var_ref (@_) {
        push @widgets, $widgets[0]->Scrolled(
            'Entry',
            -textvariable => $text_var_ref,
            -background   => "white",
            -foreground   => 'blue',
            -relief       => 'sunken',
            -font         => 'courier',
            -justify      => 'right',
            -width        => 3,
          )->pack(
            -side   => 'left',
            -expand => 1,
            -fill   => 'x',
          );

        # Just a spacer between plural entryboxes.
        if ( scalar @_ ) { $widgets[0]->Label( -width => 2 )->pack( -side => 'left' ) }
    }
    return @widgets;
}

# Automate the build of a lable & text wiget set inside GUS::tk frame.
sub frame_label_text {
    my ( $parent, $label_text, $text_height, $text_width ) = @_;
    my @widgets = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => allow_wider($label_text, $label_width),
        -text  => " $label_text ",
    )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Scrolled(
        'Text',
        -height       => $text_height,
        -width        => $text_width,
        -background   => "white",
        -foreground   => 'blue',
        -relief       => 'sunken',
        -font         => 'courier',
        -wrap         => 'word',
      )->pack(
        -side   => 'left',
        -expand => 1,
        -fill   => 'x'
      );
    return @widgets;
}

# Automate the build of a lable & set of label widgets set inside GUS::tk frame.
sub frame_label_labels {
    my $parent     = shift;
    my $label_text = shift;
    my @widgets    = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $label_text",
    )->pack( -side => 'left' );

    foreach $label_text (@_) {
        push @widgets, $widgets[0]->Label(
            -text   => "$label_text",
            -relief => 'flat',
          )->pack(
            -side   => 'left',
            -expand => 1,
            -fill   => 'x'
          );
    }
    return @widgets;
}

sub frame_label_entry_button {
    my @widgets_1 = frame_label_entry( @_[ 0 .. 2 ] );
    my @widgets_2 = ();
    my ( $width, $text, $cmd_ref, $bg, $abg, $fg ) = @_[ 3 .. 8 ];
    $width = 7         unless defined($width);
    $text  = ' Clear ' unless defined($text);
    $bg    = 'gray'    unless defined($bg);
    $abg   = 'green'   unless defined($abg);
    $fg    = 'blue'    unless defined($fg);
    $cmd_ref = sub {
        $widgets_1[2]->delete( 0, 'end' );
      }

      unless defined($cmd_ref);
    $widgets_1[0]->Button(
        -width            => $width,
        -relief           => 'raised',
        -foreground       => $fg,
        -background       => $bg,
        -activebackground => $abg,
        -command          => $cmd_ref,
        -text             => $text
    )->pack( -side => 'left' );
    return ( @widgets_1, @widgets_2 );
}

# Automate the build of a lable & radiobutton wiget set inside a frame.
sub frame_label_radio {
    my ( $width, $parent, $label_text, $text_array_ref, $var_ref, $cmd_ref, $pack_side ) = @_;
    $pack_side = 'left' unless $pack_side;
    my @widgets = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5
      )->pack(
        -side   => 'top',
        -expand => 0,
        -fill   => 'x'
      );

    # Override label length if title over long.
    my $label_chars = length $label_text;
    $label_chars = $label_width if $label_chars < $label_width;

    push @widgets, $widgets[0]->Label(
        -width => $label_chars,
        -text  => " $label_text ",
    )->pack( -side => $pack_side );

    # Make N radiobuttons.
    foreach my $text (@$text_array_ref) {
        push @widgets, $widgets[0]->Radiobutton(
            -text     => $text,
            -justify  => 'left',
            -anchor   => 'w',
            -width    => $width,
            -value    => $text,
            -variable => $var_ref,
            -command  => $cmd_ref
          )->pack(
            -side   => $pack_side,
            -expand => 1,
            -fill   => 'x'
          );
    }    # End of foreach.
    return @widgets;
}

# Automate the build of a lable & scale wiget set inside a frame.
sub frame_label_scale {
    my ( $parent, $text, $from, $to, $res, $orient ) = @_;
    $orient = 'horizontal' unless defined($orient);    # Default option.
    $res    = 1            unless defined($res);       # Default option.
    my @widgets = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $text ",
    )->pack( -side => 'left' );

    push @widgets, $widgets[0]->Scale(
        -from       => $from,
        -to         => $to,
        -resolution => $res,
        -orient     => $orient,
      )->pack(
        -side   => 'left',
        -expand => 1,
        -fill   => 'x'
      );
    return @widgets;
}

# Just like &frame_label_scale above but with zoom-in, zoom-out buttons.
sub frame_label_zoom {
    my ( $parent, $text, $from, $to, $min_limit, $max_limit, $res_limit, $orient ) = @_;
    $orient = 'horizontal' unless defined($orient);
    my $res = zoom_res( ( $to - $from ) / 20, $res_limit );    # Set reasonable default.
    $res = $res_limit if $res < $res_limit;        # Prevent starting out below limit.
    my @widgets = ();
    my $tick_interval = ( $to - $from ) / 1.99999;
    $tick_interval = int( $tick_interval) if $tick_interval == 1;
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $text ",
      )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Scale(
        -from         => $from,
        -to           => $to,
        -resolution   => $res,
        -orient       => $orient,
        -tickinterval => $tick_interval,
      )->pack(
        -side   => 'left',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Button(
        -width            => 3,
        -text             => '-',
        -command          => sub { zoom_scale( $widgets[2], 5, $min_limit, $max_limit, $res_limit ); },
        -activebackground => 'blue',
        -relief           => 'raised',
      )->pack(
        -side   => 'left',
        -expand => 0,
      );
    push @widgets, $widgets[0]->Button(
        -width            => 3,
        -text             => '+',
        -command          => sub { zoom_scale( $widgets[2], 0.2, $min_limit, $max_limit, $res_limit ); },
        -activebackground => 'orange',
        -relief           => 'raised',
      )->pack(
        -side   => 'left',
        -expand => 0,
      );
    return @widgets;
}

# Just like &frame_label_zoom above but with an entry box.
sub frame_label_entry_label_zoom_label_zoom {
    my ( $parent, $text_1, $text_var_ref,
         $text_2, $from_2, $to_2, $min_limit_2, $max_limit_2, $res_limit_2,
         $text_3, $from_3, $to_3, $min_limit_3, $max_limit_3, $res_limit_3,
         $orient ) = @_;
    $orient = 'horizontal' unless defined($orient);
    my $res_2 = zoom_res( ( $to_2 - $from_2 ) / 20, $res_limit_2 );    # Set reasonable default.
    my $res_3 = zoom_res( ( $to_3 - $from_3 ) / 20, $res_limit_3 );    # Set reasonable default.
    $res_2 = $res_limit_2 if $res_3 < $res_limit_2;        # Prevent starting out below limit.
    $res_3 = $res_limit_3 if $res_3 < $res_limit_3;        # Prevent starting out below limit.
    my @widgets = ();
    my $tick_interval_2 = ( $to_2 - $from_2 ) / 1.99999;
    my $tick_interval_3 = ( $to_3 - $from_3 ) / 1.99999;
    $tick_interval_2 = int( $tick_interval_2) if $tick_interval_2 == 1;
    $tick_interval_3 = int( $tick_interval_3) if $tick_interval_3 == 1;
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $text_1 ",
      )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Entry(
        -textvariable => $text_var_ref,
        -background   => "white",
        -foreground   => 'blue',
        -relief       => 'sunken',
        -font         => 'courier',
        -justify      => 'right',
        -width        => $label_width,
      )->pack(
        -side   => 'left',
        -expand => 0,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $text_2 ",
      )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Scale(
        -from         => $from_2,
        -to           => $to_2,
        -resolution   => $res_2,
        -orient       => $orient,
        -tickinterval => $tick_interval_2,
      )->pack(
        -side   => 'left',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Button(
        -width            => 3,
        -text             => '-',
        -command          => sub { zoom_scale( $widgets[4], 5, $min_limit_2, $max_limit_2, $res_limit_2 ); },
        -activebackground => 'blue',
        -relief           => 'raised',
      )->pack(
        -side   => 'left',
        -expand => 0,
      );
    push @widgets, $widgets[0]->Button(
        -width            => 3,
        -text             => '+',
        -command          => sub { zoom_scale( $widgets[4], 0.2, $min_limit_2, $max_limit_2, $res_limit_2 ); },
        -activebackground => 'orange',
        -relief           => 'raised',
      )->pack(
        -side   => 'left',
        -expand => 0,
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $text_3 ",
      )->pack( -side => 'left' );
    push @widgets, $widgets[0]->Scale(
        -from         => $from_3,
        -to           => $to_3,
        -resolution   => $res_3,
        -orient       => $orient,
        -tickinterval => $tick_interval_3,
      )->pack(
        -side   => 'left',
        -expand => 1,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Button(
        -width            => 3,
        -text             => '-',
        -command          => sub { zoom_scale( $widgets[8], 5, $min_limit_3, $max_limit_3, $res_limit_3 ); },
        -activebackground => 'blue',
        -relief           => 'raised',
      )->pack(
        -side   => 'left',
        -expand => 0,
      );
    push @widgets, $widgets[0]->Button(
        -width            => 3,
        -text             => '+',
        -command          => sub { zoom_scale( $widgets[8], 0.2, $min_limit_3, $max_limit_3, $res_limit_3 ); },
        -activebackground => 'orange',
        -relief           => 'raised',
      )->pack(
        -side   => 'left',
        -expand => 0,
      );
    return @widgets;
}

sub zoom_res {
    my ( $range, $res_limit ) = @_;    # Compare to margin.
    my $res = 1;

    while ( $range / $res < 500 ) { last if $res < 0.000001; $res /= 10; }

    # When 1 is too small.
    while ( $range / $res > 500 ) { last if $res > 999_999; $res *= 10 }

    # Range is okay now.
    print "At zoom_res, \$res = $res & \$res_limit = $res_limit \n" if $debug_flag > 1;
    $res = $res_limit if $res < $res_limit;    # Prevent going below limit.
    return $res;
}

# Sub below called by &frame_label_zoom when zoom button clicked.
sub zoom_scale {
    my ( $scale_ref, $power, $min_limit, $max_limit, $res_limit ) = @_;
    my $to     = $scale_ref->cget( -to );
    my $from   = $scale_ref->cget( -from );
    my $value  = $scale_ref->get();
    my $margin = ( ( $value - $from ) + ( $to - $value ) ) / 2;

    # Above are as-was values, now zoom in or out to new values.
    my $res = zoom_res( $margin * $power, $res_limit );
    $from = $value - $margin * $power;
    $to   = $value + $margin * $power;

    # Limit leftmost if required.
    if ( ( defined $min_limit ) && ( $from < $min_limit ) ) {
        $from = $min_limit;
    }

    # Limit rightmost if required.
    if ( ( defined $max_limit ) && ( $to > $max_limit ) ) {
        $to = $max_limit;
    }

    # Accomodate possible limiting from above.
    $margin = ( $to - $from ) / 2;
    $res    = zoom_res( $margin, $res_limit );

    # Adjust scale zoom within limits.
    unless ( defined($res_limit)
        && ( $power < 1 )
        && ( $res < $res_limit ) )
    {

        # Remake the scale at the new zoom level, avoiding
        # any zoom so close that no increments remain.
        $scale_ref->configure(
            -from         => $from,
            -to           => $to,
            -resolution   => $res,
            -tickinterval => $margin * 0.99999,
        ) if $to - $from > $res * 5;
    }
}

# Automate the build of a lable & button wiget set inside a frame.
sub frame_label_buttons {
    my ( $parent, $label_text, $text_array_ref, $cmd_ref_array_ref, $color_array_ref ) = @_;
    my @widgets = ();
    push @widgets,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 0,
        -fill   => 'x'
      );
    push @widgets, $widgets[0]->Label(
        -width => $label_width,
        -text  => " $label_text ",
    )->pack( -side => 'left' );

    # Make N buttons.
    foreach my $text (@$text_array_ref) {
        push @widgets, $widgets[0]->Button(
            -width            => $button_width,
            -text             => $text,
            -command          => shift ( @{$cmd_ref_array_ref} ),
            -activebackground => shift ( @{$color_array_ref} ),
            -relief           => 'raised',
          )->pack(
            -side   => 'left',
            -expand => 1,
            -fill   => 'x'
          );
    }    # End of foreach.
    return @widgets;
}

#============ Begin subs for N checkbutton frames ============

# Automate the build of a lable & button wiget set inside a frame.
sub frame_label_checks {
    # The var_ref's in var_ref_array_ref are on-off values.
    my ( $width, $parent, $label_text, $text_array_ref, $on_array_ref, $off_array_ref, $bool_array_ref,
        $cmd_ref_array_ref, $side )
      = @_;

    # So the Scrolled method of Pane can accomodate varying widths prettily.
    if ( $width == 0 ) {
        foreach ( @$text_array_ref ) { $width = length $_ if $_ > $width }
    }

    $side = 'left' unless defined $side;
    my @widgets_and_vars = ();
    push @widgets_and_vars,
      $parent->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
      )->pack(
        -side   => 'top',
        -expand => 1,
        -fill   => 'x'
      );

    # Override label length if title over long.
    my $label_chars = length $label_text;
    $label_chars = $label_width if $label_chars < $label_width;

    push @widgets_and_vars, $widgets_and_vars[0]->Label(
        -width => $label_chars,
        -text  => " $label_text ",
    )->pack( -side => $side );

    # Make N checkbuttons.
    foreach my $text (@$text_array_ref) {
        my $check_var = 0;
        push @widgets_and_vars, $widgets_and_vars[0]->Checkbutton(

            -text     => $text,
            -justify  => 'left',
            -anchor   => 'w',
            -width    => $width,
            -variable => \$check_var,
            -relief   => 'groove',
          )->pack(
            -side   => $side,
            -expand => 1,
            -fill   => 'x',
          );
        push @widgets_and_vars, \$check_var;

        # Assign the default on-value, if present.
        $widgets_and_vars[-2]->configure( -onvalue => shift @$on_array_ref )
          if defined $on_array_ref;

        # Assign the default off-value, if present.
        $widgets_and_vars[-2]->configure( -offvalue => shift @$off_array_ref )
          if defined $off_array_ref;

        # Assign checked or not-checked condition, if present.
        if ( defined $bool_array_ref ) {
            if ( shift @$bool_array_ref ) { $widgets_and_vars[-2]->select(); }
            else { $widgets_and_vars[-2]->deselect(); }
        }

        # Assign subroutine , if present.
        $widgets_and_vars[-2]->configure( -command => shift @$cmd_ref_array_ref )
            if defined $cmd_ref_array_ref;

    }   # End of foreach.
    return @widgets_and_vars;
}

# Return values of checkbutton widget set.
sub poll_frame_label_checks {

    # Input @_ = ( frame, label, check_1, var_1, check_2, var_2 ...)
    # print "Checklist poll input = ", join " ", @_, "\n" if $debug_flag;
    my @bar = ();
    for (my $i = 3; defined($_[$i]); $i += 2) {
        push @bar, ${$_[$i]};
    }

    # print "Checklist poll output = ", join " ", @bar, "\n" if $debug_flag;
    return @bar;
}

# Return values of checkbutton widget set.
sub clear_frame_label_checks {

    # Input @_ = ( frame, label, check_1, var_1, check_2, var_2 ...)
    my @bar = ();
    for (my $i = 3; defined($_[$i]); $i += 2) {
        ${$_[$i]} = 0;
    }
}

#============ End subs for N checkbutton frames ============
#============ Begin subs for N file browse entry frames ============

# One var and three subs below require sub label_entry defined above. Use them to
# make one-or-more file-browse widgets. Can add new ones underneath as required. Can also
# delete them, one-at-a-time, except for the top one.

my @auto_path_widgets = ();

# List of supported file patterns
$main::filetypes = [
    [ 'TAB delimited', '.dat', 'TEXT' ],
    [ 'ASCII', '.txt', 'TEXT' ],
    [ 'Any', '*.*', 'TEXT' ]
] unless defined $main::filetypes;

sub add_path_widget {
    my ( $frame, $var_ref, $label_str, ) = @_;
    $label_str = 'Input Path:' unless defined $label_str;
    my @path_widgets = frame_label_entry_button(
        $frame,
        $label_str,
        $var_ref, 7, 'Browse',
        sub {
            $$var_ref = $mw->getOpenFile( -filetypes => $main::file_types );
        },
        'gray',
        'red',
        'black',
    );
    push @auto_path_widgets, \@path_widgets;
    return @path_widgets;
}

sub delete_path_widget {
    if ( $#auto_path_widgets > 0 ) {
        my $a_ref = $auto_path_widgets[-1];
        ${$a_ref}[0]->destroy();
        $main::feedback = "Row " . ( $#auto_path_widgets + 1 ) . " has been removed.";
        pop @auto_path_widgets;
    }
    else { $main::feedback = "Oops! Can't remove only remaining row."; }
}

sub auto_path_widgets {
    my ( $count, $frame, $label_str ) = @_;
    $label_str = 'Input Path:' unless defined $label_str;
    if ( $count > 0 ) {
        for ( my $i = 1 ; $i <= $count ; $i++ ) {
            my $var = '';
            add_path_widget( $frame, $var, $label_str,  );
        }
        return @auto_path_widgets;
    }

    if ( $count < 0 ) {
        for ( my $i = 1 ; $i >= $count ; $i-- ) {
            delete_path_widget();
        }
    }
}

#============ End subs for N file browse entry frames ============
#============ Begin subs for N directory browse entry frames ============

# NOTE: This sucks! Why is there no proper dir browse widget in Tk like
# the getOpenFile() and getSaveFile() widgets?

sub add_dir_widget {
    my ( $frame, $var_ref, $label_str,) = @_;
    $label_str = 'Input Dir:' unless defined $label_str;
    my @dir_widgets =
      frame_label_entry_button( $frame, $label_str, $var_ref, 7, 'Browse', sub { \&dir_tree_window($var_ref); },
        'gray', 'red', 'blue', );
    return @dir_widgets;
}

# Return list of drives for Windoze.
sub drives {
    my @drives;
    for my $i ( 'C' .. 'Z' ) {
        $i = "$i" . ':';
        push ( @drives, $i ) if ( -d "$i\\" );
    }
    return @drives;
}

sub dir_tree_window {
    my ( $dir_path_ref, ) = @_;
    if ( !Exists($dir_toplevel) ) {
        $dir_toplevel = $mw->Toplevel( -title => 'Browse to directory...' );
        my $dir_tree = $dir_toplevel->Scrolled('DirTree')->pack( -side => 'top', -expand => 1, -fill => 'both', );
        $dir_tree->delete('all');

        chdir $GUS::os_detect::home;

        # Test if Windoze or a real OS...
        if ( $GUS::os_detect::OS eq 'WINDOWS' ) {

            # Cobble up for use with Windoze.
            foreach my $dir ( drives() ) { $dir_tree->chdir("$dir"); }
        }
        else { $dir_tree->chdir('/'); }    # For when Unician.

        my $button_frame = $dir_toplevel->Frame()->pack( -expand => 0, -fill => 'x' );

        frame_label_buttons(
            $button_frame,
            'Action:',
            [ 'Accept', 'Cancel' ],
            [
                sub {
                    $$dir_path_ref = $dir_tree->selectionGet();
                    $dir_toplevel->destroy;
                },
                sub { $dir_toplevel->destroy; }
            ],
            [ 'red', 'green' ],
        );
    }
}

#============ End subs for directory browse entry frames ============

# Preserve scale configuration in an array.
sub scale_cfg_save {
    my ( $tk_scl, $a_ref, $setting ) = @_;
    foreach ( '-from', '-to', '-res', '-tickinterval') {
        push @$a_ref, $tk_scl->cget($_);
    }
    push @$a_ref, $setting if defined $setting;
}

sub scale_cfg_restore {
    my ( $tk_scl, $a_ref, $i ) = @_;
    foreach ( '-from', '-to', '-res', '-tickinterval') {
        $tk_scl->configure($_, $$a_ref[$i]);
        ++$i;
    }
}

##############################
# End GUS Tk widgets package #
##############################
# Begin Help About Package #
# Version 2004-04-13       #
############################

# Note: Two vars required in package main as/per following example...
# our $formal_name = 'Gan Uesli Starling'; # However it's officially called.
# our $formal_date = '1955-12-24'; # Official date of this relase.

package GUS::help_about;

use Tk;
use strict;
no strict "refs";

# Declare variables for strict.
use vars qw( $mw_about );

sub start_MainLoop {

    # Get script name less path.
    my $script_name = $0;
    $script_name =~ s/.*[\\|\/]//;

    $mw_about = MainWindow->new( -title => 'About' );
    my $text =
      $mw_about->Label( -text => "$main::formal_name\n"
          . "Release $main::formal_date\n\n"
          . "Running as $script_name\n"
          . "since " . main::format_DTG($^T, 0) . "\n\n"
          . "Copyright 2005, Gan Uesli Starling\n\nTrailing Edge Technologies\n"
          . "http://starling.us/tet\n"
          . "email gan\@starling.us"
          . "\n" )->pack();
    my $bn_okay = $mw_about->Button(
        -width            => 8,
        -relief           => 'raised',
        -foreground       => 'blue',
        -activebackground => 'green',
        -command          => \&quit_MainLoop,
        -text             => 'Okay'
    )->pack( -side => 'top' );
    MainLoop;
}

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw_about->destroy() if Tk::Exists($mw_about);
}

###############################
# End Menu Help About Package #
###############################
# Begin Scales Package #
# Version 2005-09-19   #
########################

package GUS::scales;

use Tk;
use strict;
no strict "refs";

use vars qw( $mw_scales @widgets);

sub start_MainLoop {
    my ($title, $hint_text, $aref, @scale_args) = @_;
    $mw_scales = MainWindow->new( -title => $title );

    my $text = $mw_scales->Label(
        -text => $hint_text,
    )->pack();

    my $frame_top = $mw_scales->Frame(
        -relief      => 'sunken',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my $frame_btm = $mw_scales->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    @widgets = ();

    while (@scale_args) {
        push @widgets, GUS::tk::frame_label_scale(
            $frame_top,
            shift(@scale_args), # text
            shift(@scale_args), # from
            shift(@scale_args), # to
            shift(@scale_args), # resolution
            shift(@scale_args), # orientation
        );
    }

    my @action_buttons = GUS::tk::frame_label_buttons(
        $frame_btm,
        'Actions:',
        [ 'Accept', 'Cancel' ],
        [
            sub {
                my $sub_ref = shift @$aref;
                &{$sub_ref}(@$aref, poll_scales());
                quit_MainLoop();
            },
            \&quit_MainLoop,
        ],
        [
            'red',
            'green',
        ]
    );

    MainLoop;
}

# Get value from each of N scales, return to caller.
sub poll_scales {
    my @values;
    for (my $i = 2; $i <= $#widgets; $i += 3) {
        push @values, $widgets[$i]->get();
    }
    return @values;
}

# Close down the Perl/Tk GUI window
sub quit_MainLoop {
    $mw_scales->destroy() if Tk::Exists($mw_scales);
}

######################
# End Scales Package #
############################
# Begin Radio List Package #
# Version 2005-09-22       #
############################

package GUS::radio_list;

use Tk;
use strict;
no strict "refs";

use vars qw( $mw_radio_list $radio_var );

sub start_MainLoop {
    my ($title, $label, $hint_text, $text_array_ref, $sub_ref, $lh_btn_text, $rh_btn_text) = @_;
    ($lh_btn_text, $rh_btn_text) = ('Accept', 'Cancel') unless $lh_btn_text;

    $mw_radio_list = MainWindow->new( -title => $title );

    my $text = $mw_radio_list->Label(
        -text => $hint_text,
    )->pack();

    my $frame_top = $mw_radio_list->Frame(
        -relief      => 'sunken',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my $frame_btm = $mw_radio_list->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my @radio_wgt = GUS::tk::frame_label_radio(
        20, $frame_top, $label, $text_array_ref, \$radio_var, sub {}, 'top'
    );

    my @action_buttons = GUS::tk::frame_label_buttons(
        $frame_btm,
        'Actions:',
        [ "$lh_btn_text", "$rh_btn_text" ],
        [
            sub { &{$sub_ref}($radio_var); quit_MainLoop() },
            \&quit_MainLoop,
        ],
        [
            'red',
            'green',
        ]
    );

    MainLoop;
}

# Close down the Perl/Tk GUI window
sub quit_MainLoop {
    $mw_radio_list->destroy() if Tk::Exists($mw_radio_list);
}

##########################
# End Radio List Package #
############################
# Begin Get String Package #
# Version 2005-08-28       #
############################

package GUS::get_string;

use Tk;
use strict;
no strict "refs";

use vars qw( $mw_get_string );

sub start_MainLoop {
    my ($title, $label, $hint_text, $aref) = @_;

    $mw_get_string = MainWindow->new( -title => $title );
    my $string = '';

    my $text = $mw_get_string->Label(
        -text => $hint_text,
    )->pack();

    my $frame_top = $mw_get_string->Frame(
        -relief      => 'sunken',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my $frame_btm = $mw_get_string->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my @string_wgt = GUS::tk::frame_label_entry(
        $frame_top,
        "$label:",
        \$string,
    );

    my @action_buttons = GUS::tk::frame_label_buttons(
        $frame_btm,
        'Actions:',
        [ 'Accept', 'Cancel' ],
        [
            sub {
                my $sub_ref = shift @$aref;     # Extract subref from args.
                unshift @$aref, $string;        # In front of embeded @clinets_subset (when present).
                &{$sub_ref}(@$aref);            # Execute sub with old args and new.
                quit_MainLoop();
            },
            \&quit_MainLoop,
        ],
        [
            'red',
            'green',
        ]
    );

    MainLoop;
}

# Close down the Perl/Tk GUI window
sub quit_MainLoop {
    $mw_get_string->destroy() if Tk::Exists($mw_get_string);
}

##########################
# End Get String Package #
################################
# Begin Confirm String Package #
# Version 2005-08-27           #
################################

package GUS::confirm_string;

use Tk;
use strict;
no strict "refs";

use vars qw( $mw_confirm_string );

sub start_MainLoop {
    my ($title, $label, $sub_ref) = @_;

    $mw_confirm_string = MainWindow->new( -title => $title );
    my $pw_a = my $pw_b = '';

    my $text = $mw_confirm_string->Label(
        -text => "Enter twice to confirm.\n",
    )->pack();

    my $frame_top = $mw_confirm_string->Frame(
        -relief      => 'sunken',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my $frame_btm = $mw_confirm_string->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my @pw_a_wgt = GUS::tk::frame_label_entry(
        $frame_top,
        "$label:",
        \$pw_a,
    );

    my @pw_b_wgt = GUS::tk::frame_label_entry(
        $frame_top,
        ' Confirm:',
        \$pw_b,
    );

    # Hide passwords from view with stars.
    foreach ( $pw_a_wgt[2], $pw_b_wgt[2] ) { $_->configure( -show => '*' ) }

    my @action_buttons = GUS::tk::frame_label_buttons(
        $frame_btm,
        'Actions:',
        [ 'Accept', 'Cancel' ],
        [
            sub { compare_strings( $pw_a, $pw_b, $sub_ref ) },
            \&quit_MainLoop,
        ],
        [
            'red',
            'green',
        ]
    );

    MainLoop;
}

# Test passwords for equality. If okay, call passed sub via ref.
# Warn otherwise.
sub compare_strings {
    my ($pw_a, $pw_b, $sub_ref) = @_;
    if ( $pw_a eq $pw_b ) { &{$sub_ref}($pw_a) }
    else {
        my $reply = 'Oops! Two strings not alike.';
        GUS::pop_up_window::start_MainLoop(
            'gold',
            'String Test Results',
            "\n$reply\n",
            'Close', sub{}, []
        ); # Sans 2nd button.
    }
    quit_MainLoop();
}

# Close down the Perl/Tk GUI window
sub quit_MainLoop {
    $mw_confirm_string->destroy() if Tk::Exists($mw_confirm_string);
}

##############################
# End Confirm String Package #
################################
# Begin Confirm Script Package #
# Version 2005-09-18           #
################################

package GUS::confirm_script;

use Tk;
use strict;
no strict "refs";

use vars qw( $mw_confirm_script );

# Open, read in, and return lines from supposed pure-ASCII file.
# Called as sub inside &check_ascii_only defined below.
sub read_in_script {
    my ($file_path,) = @_;

    my @file_lines;
    if ( open TEXT, "$file_path" ) {
        my @items_list = ();
        while (<TEXT>) {
            $_ =~ s/\s*$//; # Chomp as if from another OS.
            push @file_lines, "$_\n";
        }
        return @file_lines;
    }
    else {
        my $reply = "Oops! Could not open file '$file_path': $!";
        GUS::pop_up_window::start_MainLoop(
            'gold',
            'XML-RPC Client Warns',
            "\n$reply\n",
            'Okay', sub{}, [],
            'Log', sub{ log_this("$reply at sub 'read_in_script'.", 1) }, [],
        ); # With optional 2nd button.
    }
}

# Get lines from file, test if pure ASCII or not.
sub check_ascii_only {
    my ($file_path, $sub_ref, $skip_confirm_flag, $prefix, $snapshot_aref) = @_;
    my @file_lines = read_in_script($file_path);

    # Parse file looking for non-ASCII bytes.
    my $bin_cnt = 0;
    foreach my $line (@file_lines) {
        last if $bin_cnt > 100; # Waste no more time.
        my @bytes = split '', $line;
        foreach (@bytes) {
            next if $_ =~ /\s/;
            ++$bin_cnt if ord($_) < 32;
            ++$bin_cnt if ord($_) > 126;
        }
    }

    # Continue if pure ASCII. Complain otherwise.
    if ($bin_cnt == 0) {
        my $file_name = $file_path;  # To safe confusion over role.
        $file_name =~ s/.*[\/|\\]//; # Leave only filename sans path.
        $file_name = $prefix . $file_name if $prefix; # Add prefix maybe.
            # Whether repleatedly sans confirmation or
            # else singularly with full user confirmation.
	    if ($skip_confirm_flag) {
                act_upon_file($file_name, $sub_ref, \@file_lines, $snapshot_aref);
	    }
	    else {
                start_MainLoop('File Lines Okay?', $file_name, $sub_ref, @file_lines);
	    }
    }
    else {
        $bin_cnt = 'More than ' . $bin_cnt if $bin_cnt >= 100;
        my $reply = "Oops! $bin_cnt binary chars found in file:\n'$file_path'";
        GUS::pop_up_window::start_MainLoop(
            'gold',
            'XML-RPC Client Warns',
            "\n$reply\n",
            'Okay', sub{}, [],
            'Log', sub{ log_this("Sub 'check_ascii_only' reports: $reply", 1) }, [],
        ); # With optional 2nd button.
    }
}

sub act_upon_file {
    my ($file_name, $sub_ref, $lines_aref, $snapshot_aref) = @_;

    # Assume may go to other OS. Let recipient add own line endings.
    foreach (@$lines_aref) { chomp $_ }

    # Run passed sub with args.
    &{$sub_ref}($file_name, $lines_aref, $snapshot_aref);
}

sub start_MainLoop {
    my ($title, $file_name, $sub_ref, @file_lines) = @_;

    $mw_confirm_script = MainWindow->new( -title => $title );
    my $file_text = '';

    my $text = $mw_confirm_script->Label(
        -text => "Verify each line carefully!\n",
    )->pack();

    my $frame_top = $mw_confirm_script->Frame(
        -relief      => 'sunken',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my $frame_btm = $mw_confirm_script->Frame(
        -relief      => 'flat',
        -borderwidth => 5,
    )->pack( -side => 'top', -expand => 1, -fill => 'x');

    my @file_text_wgt = GUS::tk::frame_label_text(
        $frame_top,
        "$file_name:", 24, 80,
    );

    # Show file text inside text widget.
    $file_text_wgt[2]->delete('1.0', 'end');
    foreach (@file_lines) {
        $file_text_wgt[2]->insert('end', $_);
    }

    my @action_buttons = GUS::tk::frame_label_buttons(
        $frame_btm,
        'Actions:',
        [ 'Accept', 'Cancel' ],
        [
            sub {
                # Empty [] is place holder for missing $snapshot_aref
                # when on full confirm rather than repeatedly sending.
                act_upon_file($file_name, $sub_ref, \@file_lines, []);
                &quit_MainLoop;
            },
            \&quit_MainLoop,
        ],
        [
            'red',
            'green',
        ]
    );

    MainLoop;
}

# Close down the Perl/Tk GUI window
sub quit_MainLoop {
    $mw_confirm_script->destroy() if Tk::Exists($mw_confirm_script);
}

##############################
# End Confirm Script Package #
###############################
# Begin Pop Up Window Package #
# Version 2005-09-07          #
###############################

package GUS::pop_up_window;

use Tk;
use strict;
no strict "refs";

# Declare variables for strict.
use vars qw(
    $mw_pop_up $pane_pop_up $background $title $message
    $text_1 $cmd_ref_1 $cmd_args_array_ref_1
    $text_2 $cmd_ref_2 $cmd_args_array_ref_2
    $frame_bn $font
);

# Calculate dimensions of message for pane, etc. Then
# configure widget to that height and width.
sub size_widget_for_string {
    my ($wgt, $msg, $font) = @_;

    # Measure widest line of string for given font.
    my @msg = split "\n", $msg;
    my $hght = 1.5 * $wgt->fontMetrics($font, -linespace);
    my $wdth = 0;
    foreach (@msg) {
        my $line_wdth = $wgt->fontMeasure($font, " $_ ");
        $wdth = $line_wdth if $wdth < $line_wdth;
        $hght += $wgt->fontMetrics($font, -linespace);
    }

    # Limit size to reasonable maximums.
    my $max_hght = 0.6 * $wgt->screenheight;
    my $max_wdth  = 0.9 * $wgt->screenwidth;
    $hght = $max_hght if $hght > $max_hght;
    $wdth = $max_wdth if $wdth > $max_wdth;

    # Configure the widget.
    $wgt->configure( -width => $wdth, -height => $hght );
}

sub start_MainLoop {
    # Only one pop-up at a time.
    quit_MainLoop() if Tk::Exists $mw_pop_up;

    ( $background, $title, $message,
        $text_1, $cmd_ref_1, $cmd_args_array_ref_1,
        $text_2, $cmd_ref_2, $cmd_args_array_ref_2,
    ) = @_;

    my $font = 'courier';

    $mw_pop_up = MainWindow->new(
        -title      => " $title",
    );

    # An outermost pane to scroll all sub-panes within.
    $pane_pop_up = $mw_pop_up->Scrolled(
        'Pane',
        -scrollbars => 'osow',
        -sticky     => 'new',
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    # Custom pane size for the label it will contain.
    size_widget_for_string($pane_pop_up, $message, $font);

    my $text = $pane_pop_up->Label(
        -text               => "$message",
        -background         => $background,
        -justify            => 'left',
        -font               => $font,
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    my $btn_width = 12;
    $btn_width *= 2 if defined $cmd_ref_2;

    $frame_bn = $mw_pop_up->Frame(
        -width       => $btn_width,
        -relief      => 'flat',
        -borderwidth => 0,
    )->pack( -side => 'top', -expand => 0 );

    # One button is requried.
    my $bn_1 = $frame_bn->Button(
        -width              => 12,
        -relief             => 'raised',
        -foreground         => 'blue',
        -activebackground   => 'green',
        -command            => \&action_1,
        -text               => " $text_1 ",
    )->pack( -side => 'left', -expand => 1, -fill => 'both');

    # A second button is optional.
    if ( defined $cmd_ref_2 ) {
        my $bn_1 = $frame_bn->Button(
            -width              => 12,
            -relief             => 'raised',
            -foreground         => 'blue',
            -activebackground   => 'green',
            -command            => \&action_2,
            -text               => " $text_2 ",
        )->pack( -side => 'left', -expand => 1, -fill => 'both');
    }

    MainLoop;
}

# What happens when you click the left or only button.
sub action_1 {
    if ( defined( $cmd_ref_1 ) ) {
        &{$cmd_ref_1}( @{$cmd_args_array_ref_1} );
        quit_MainLoop();
    }
}

# What happens when you click the (optional) right button.
sub action_2 {
    if ( defined( $cmd_ref_2 ) ) {
        &{$cmd_ref_2}( @{$cmd_args_array_ref_2} );
        quit_MainLoop();
    }
}

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw_pop_up->destroy() if Tk::Exists($mw_pop_up);
}

#############################
# End Pop Up Window Package #
####################################
# Begin Checklist Via File Package #
# Version 2005-09-05               #
####################################

# This package depends on the following packages:
# GUS::tk
# GUS::pop_up_window

package GUS::checklist_via_file;

use Tk;
use File::Basename;
use strict;
no strict "refs";

use vars qw( @items_list @checks_items $mw_flc $frame_top $pane_flc $splitter);

sub start_MainLoop {

    # Only one such window at a time.
    quit_MainLoop() if Tk::Exists $mw_flc;

    my ( $background, $title, $list_title, $full_path,
        $subset_aref, $action_sref, $items_href, $reply_ref ) = @_;

    # Because not every caller main::foo() needs to keep track of
    # what went into a given list it sometimes may not pass an href.
    %$items_href = {} unless defined %$items_href;
    $$reply_ref  = '' unless defined $$reply_ref; # Ditto on feedback string.

    $mw_flc = MainWindow->new(
        -title      => " $title",
        -background => $background,
    );

    # At least one sunken frame above flat frame for buttons,  etc.
    $frame_top = $mw_flc->Frame(
        -relief      => 'sunken',
        -borderwidth => 5
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    my $frame_btm = $mw_flc->Frame(
        -relief      => 'flat',
        -borderwidth => 5
    )->pack( -side => 'top', -expand => 0, -fill => 'x' );

    # Provide help info as balloon widgets.
    my $help_info = $frame_btm->Label(
       -borderwidth => 2,
       -relief      => 'groove',
       -background  => $balloon_bg,
       -foreground  => $balloon_fg,
    )->pack( -side => 'top', -expand => 0, -fill => 'x' );

    my $balloon = $frame_btm->Balloon(
       -statusbar       => $help_info,
       -balloonposition => 'mouse',
       -background      => $balloon_bg,
       -foreground      => $balloon_fg,
    );
    $balloon->attach( $help_info,
        -balloonmsg => 'Help messages appear here.',
        -statusmsg  => 'Hover mouse on any widget then read here.'
    );

    # An outermost pane to scroll all sub-panes within.
    $pane_flc = $frame_top->Scrolled(
        'Pane',
        -scrollbars => 'osow',
        -sticky     => 'new',
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    # Create the checklist, one-per-line, from a text file.
    create_checks( $list_title, $full_path, $items_href );

    my @buttons_actions = GUS::tk::frame_label_buttons(
        $frame_btm,
        'Actions:',
        [ 'Select', 'Load', 'Clear', 'Cancel' ],
        [
            sub {

                # Return the subset to main and trigger its action.
                get_selection_subset($subset_aref, $action_sref);
                @items_list = ();
                quit_MainLoop();
            },
            sub {
                destroy_checks();
                create_checks($list_title, '', $items_href, $reply_ref);
            },
            sub {
                @items_list = ();
                destroy_checks();
                create_checks($list_title, '', $items_href, $reply_ref);
            },
            \&quit_MainLoop
        ],
        [
            'blue',
            'red',
            'orange',
            'green',
        ]
    );
    # Supply user hints to method buttons.
    $balloon->attach(
        $buttons_actions[2],
        -balloonmsg => 'Accept checked?',
        -statusmsg => 'Accept the checked item from the list?.'
    );
    $balloon->attach(
        $buttons_actions[3],
        -balloonmsg => 'Load more items?',
        -statusmsg => 'Browse for a text file holding further list items.'
    );
    $balloon->attach(
        $buttons_actions[4],
        -balloonmsg => 'Clear all items?',
        -statusmsg => 'Clear existing list and browse for new list.'
    );
    $balloon->attach(
        $buttons_actions[5],
        -balloonmsg => 'Exit?',
        -statusmsg => 'Close out this window, doing nothing.'
    );
}

MainLoop;

# Clear away old checkbuttons.
sub destroy_checks {
    foreach ( @checks_items[0..2] ) {
        $_->destroy() if Tk::Exists($_);
    }
}

# Build checklist, appending items to those already there.
sub create_checks {
    my ($title, $full_path, $items_href, $reply_ref ) = @_;
    while ($full_path eq '') {
        $full_path = $mw_flc->getOpenFile(
            -initialdir => dirname($full_path),
            -filetypes => [['ASCII', '.txt', 'TEXT']],
        );
    }
    push @items_list, load_items_list( $full_path, 100, $items_href, $reply_ref );
    display_items_checklist( $title, @items_list );
}

# Collect the checked items from checklist. Act upon them as
# defined in main. Main has both array and sub because I have
# not figured out how to feed args to an sref.
sub get_selection_subset {
    my ( $aref, $sref ) = @_;
    my $i = 0;
    foreach ( GUS::tk::poll_frame_label_checks(@checks_items) ) {
        if ($_) { push @$aref, $items_list[$i] }
        ++$i;
    }
    # Act upon selection via main.
    # Let &$subr in main clear @$aref if required. Otherwise
    # let @$aref accumulate selections.
    &$sref;
}

# As a sub so can change list by loading text file.
sub display_items_checklist {
    my $list_title = shift;
    my ( @items, @items_on, @items_off, @items_checked, @items_cmd );
    foreach ( @_ ) {
        push @items,        $_;
        push @items_on,      1;
        push @items_off,     0;
        push @items_checked, 0;
        push @items_cmd,     sub {};
    }

    # Build a frame, label and checkboxes.
    @checks_items = GUS::tk::frame_label_checks(
        0,
        $pane_flc,
        $list_title,
        \@items,                 # Channels
        \@items_on,              # on-value refs
        \@items_off,             # off-value refs
        \@items_checked,         # checked or not
        \@items_cmd,             # actions taken when checked
        'top',                   # How to align checkbuttons
    );

    # Attach a balloon to each widget.
    for ( my $j = 2 ; $j < $#checks_items ; $j += 2 ) {
        $balloon->attach(
            $checks_items[$j],
            -balloonmsg => 'Choose?',
            -statusmsg => 'Check to include this item.'
        );
    }
}

# Original, pre-modify version (for reference).
sub read_file_lines_ora {
    my ($file_path) = @_;
    my @file_lines;
    if ( open TEXT, "$file_path" ) {
        while (<TEXT>) {
            $_ =~ s/\s*$//; # Chomp as if from another OS.
            push @file_lines, "$_\n";
        }
    }
    return @file_lines;
}

# Open, read in, and return lines from supposed pure-ASCII file.
# Called as sub inside &check_ascii_only defined below.
sub read_file_lines {
    (my $file_path, $splitter) = @_;
    my @file_lines;
    my $accum;
    if ( open TEXT, "$file_path" ) {
        while (<TEXT>) {
            next if $_ =~ /^\s*$/; # Skip pure whitespace.
            $_ =~ s/\s*$//;        # Chomp as if from another OS.
            $accum .= "$_\n";
        }
    }
    $splitter = "\n" unless $splitter;
    @file_lines = split /$splitter/, $accum ;

    # If $splitter ~= /\n/, receiving op should
    # know to make hash, showing the comment line as
    # selectable, but feeding the value.
    return @file_lines;
}

# Call up a Tk file browser and load list from text file.
sub fetch_list {
    my ($full_path_ref, $list_ref) = @_;
    my $browsed = $GUS::pop_up_window::mw_pop_up->getOpenFile(
       -filetypes => [[ 'Text', '.txt'],['Any', '*.*' ]],
       -title => 'Checklist Items File',
        -initialdir => dirname($$full_path_ref),
    );

    # In case user clicks cancel or selects badly.
    if (open TEST, "<$browsed") {
        close TEST;
        $$full_path_ref = $browsed;
        my @file_lines = read_file_lines($$full_path_ref);

        my $ascii_pound = "\043"; # Confuses editor syntax highlighting.
        @$list_ref = sans_comments($ascii_pound, @file_lines);
    }
}

# Given a list of lines read from a file
# remove all the comments therefrom.
sub sans_comments {
    my $cmnt = shift;
    my @sans_cmnts = ();
    foreach (@_) { push @sans_cmnts, $_ unless $_ =~ /^$cmnt/ }
    return @sans_cmnts;
}

# Read in passed file, convert to hash of keys and line numbers.
# Note 1: Feedback string $reply returned for use as whatever.
# Note 2: Hash returned so may check like so: exists %hash{$key} ? foo() : bar();
sub lines_to_hash {
    my ($full_path_ref, $max_items) = @_;
    my %line_items;

    my @file_lines = read_file_lines($$full_path_ref);
    my $ascii_pound = "\043"; # Confuses editor syntax highlighting.
    my @list_items = sans_comments($ascii_pound, @file_lines);

    my $mw_lth;

    # If full path fails, insist until works.
    while ( scalar(@list_items) == 0 ) {
        GUS::pop_up_window::start_MainLoop(
            'gold',
            'XML-RPC Client Warns',
            "\nOops! Sub 'lines_to_hash' could not open file\n'"
                . $$full_path_ref
                . "'.\nSelect another file.\n",
            'Browse', sub{ fetch_list($full_path_ref, \@list_items) },
        ); # Without optional 2nd button.;
    }

    my $i = 0;
    foreach my $name (@list_items) {
        ++$i;
        $name =~ s/^\s+//; # Strip LH whitespace.
        $name =~ s/\s+$//; # Strip RH whitespace.
        $line_items{$name} = $i;
        if ($i >= $max_items) {
            $reply .= "Oops? Sub 'lines_to_hash' found more than $i liness! Wrong list file? \n\t";
            last;
        }
    }
    my $reply = "Okay! Sub 'lines_to_hash' found $i lines in file ''.\n";
    foreach ( sort keys(%line_items) ) {
        $reply .= "\n\t$i\t$line_items{$_}"
    }
    return ($reply, %line_items);
}

# Read in items list from text file. Return as hash of
# strings and line numbers.
sub load_items_list {
    my ( $full_path, $max_items, $items_href, $reply_ref ) = @_;
    my $reply = '';

    # Exert some control over how many items from given file.
    # Note: Package 'main' wants a hash...this package, an array. So
    # store into referenced hash, then return an array of its keys.
    ($reply, %$items_href) = lines_to_hash(\$full_path, $max_items );

    if ( $reply =~ /Oops!/ )  {
        GUS::pop_up_window::start_MainLoop(
            'gold',
            'XML-RPC Client Warns',
            "\n$reply\n",
            'Okay', sub{}, [],
            'Log', sub{ $$reply_ref .= $reply }, [],
        ); # With optional 2nd button.
    }
    return sort keys(%$items_href);
}

# Close down the Perl/Tk GUI
sub quit_MainLoop {
    $mw_flc->destroy() if Tk::Exists($mw_flc);
}

##################################
# End Checklist Via File Package #
##################################
# Begin GUS::Crypt Package  #
# Version 2006-06-20        #
#############################

package GUS::Crypt;

use Crypt::CBC;
use MIME::Base64;
use strict;

use vars qw( $DEFAULT_KEY $reply );

BEGIN {
    # Default encryption key for startup defined here so that
    # it will pre-exist for a sub definition below.
    $GUS::Crypt::DEFAULT_KEY =
        "You must not fight too often with one enemy " .
        "or you will teach him all your art of war. " .
        "Napoleon Bonaparte";
}

# When provided string is empty, supply a default.
# When provided string is too short, re-double until long enough.
# If too long, keep middle part thereof (slightly more random).
sub grind_key {
    my ($s, $size ) = @_;

    # If undefined or empty, use default.
    # The '?' vesus '!' after 'Oops' in reply is deliberate.
    unless (defined($s) && ($s ne '')) {
        $reply = "Oops? String for user's own custom encryption key undefined or empty. \n";
        $reply .= "Package GUS::Crypt using built-in \$DEFAULT_KEY as fallback. \n";
        print $reply;
        $s = $GUS::Crypt::DEFAULT_KEY;
    }

    # If too short, lengthen it.
    while (length($s) < $size) {$s .= $s }

    # If string too long, keep only center part.
    if (length($s) > $size) {
        my $i = int( (length($s) - $size ) / 2);
        $s = substr($s, $i, $size);
    }

    # Ciphers want their key as binary, not ASCII.
    return pack("a*", $s);
}

# The initialization vector is allowed to be different for en- versus de-crypting.
# Pseudo-randomly choose form the 87 printable ASCII characters above ordinal 32.
sub rand_string {
    my $s = '';
    while ( length($s) < $_[0] ) { $s .= chr(int(rand(87)) + 32) }
    return $s;
}

# Generate the cipher. Refer to Crypt::CBC module for details.
sub brew_cipher {
    Crypt::CBC->new(                    # Version 2.17 tested only.
        {   'key'             => $_[0], # Packed as binary string.
            'cipher'          => $_[1], # 'Blowfish', 'Rijndael', 'IDEA', etc.
            'regenerate_key'  => $_[2], # False for as-is. True for MD5 hash thereof.
            'header'          => 'randomiv', 
            'iv'              => rand_string(8),
            'padding'         => 'space',
            'prepend_iv'      => 1
        }
    );
}

# All-in-one sub to encrypt or decrypt.
# SYNOPSIS 1: gus_crypt( $ascii_key, $plaintext,  'encrypt', 64);
# SYNOPSIS 2: gus_crypt( $ascii_key, $ciphertext, 'decrypt', 64);
sub gus_crypt {
    my ($cipher, $thru, $how, $base) = @_;
    die "Oops! Scalar \$how !~ /(en|de)crypt/ in sub gus_crypt \n"
        unless $how =~ /(en|de)crypt/;
    if ($how eq 'decrypt') {
        $thru = decode_base64($thru) if $base == 64;
    }
    $cipher->start($how . 'ing');
    $thru = $cipher->crypt($thru);
    $thru .= $cipher->finish();
    if ($how eq 'encrypt') {
        $thru = encode_base64($thru) if $base == 64;
    }
    return $thru;
}

# Given an ascii name, derive an impossibly obfuscated variant.
# Used for hash keys, etc., when transmitted in the clear.
sub obfuscate {
    my ($s, $size) = @_;

    # Grow into Blowfish key.
    until ( length($s) > $size + 56) {
        $s .= crypt $s, substr($s, length($s) - 2);
    }
    $s = substr($s, $size, 56);

    # Encrypt the string.
    my $cipher = Crypt::CBC->new( # Version 2.17 tested only.
        {   'key'    => pack("a*", $s),
            'cipher' => 'Blowfish',
            'header' => 'randomiv',
            'iv'     => substr($s, 0, 8),
        }
    );
    $cipher->start('encrypting');
    $s = $cipher->crypt($s);
    $s .= $cipher->finish();

    # Keep only alphanums.
    $s = encode_base64($s);
    $s =~ s/![0-9|A-Z|a-z]//g;

    # Slice from center.
    if (length($s) > $size) {
        my $i;
        $i = int( (length($s) - $size ) / 2);
        $s = substr($s, $i, $size);
    }

    return $s;
}

# A cheap and dirty cypher for ascii text. Works
# both ways with same key. Not very secure. Good
# only for making stored passwords less guessable.
sub xor_mask_ascii {
    my ( $key, $s ) = @_;
    my $msk = my $cfr = '';

    # Make an xor-mask longer than the plaintext.
    while ( length $msk < length $s ) {
        $msk .= crypt $key, substr( $key, 0, 2 );
        $msk = substr( $msk, 2, ((length $msk) - 1));
        $key = $msk;
    }

    # Create the cypher by xor-ing with the mask.
    for ( my $i = 0; $i < length $s; ++$i ) {
        no warnings;
        $cfr .=
            chr(
                ord( substr( $msk,  $i, $i + 1 ) )
                ^
                ord( substr( $s, $i, $i + 1 ) )
            );
    }
    return $cfr;
}

##########################
# End GUS::Crypt Package #
##########################
# Begin GUS::Document #
# Version 2005-09-08  #
#######################

package GUS::Document;

use Pod::Text;
use Pod::Html;
use File::Basename;
use strict;

use vars qw( $pod_path $text_path $html_path $pod_text );

BEGIN {
    $pod_path = $text_path = $html_path = dirname(__FILE__) . '/' . basename(__FILE__);
    $text_path =~ s/\.pl$/_pod.txt/;
    $html_path =~ s/\.pl$/.html/;
}

sub pod_as_text {
    my $parser = Pod::Text->new (
        sentence => 0,
        width => 60,
        loose => 1,
    );

    $pod_text = '';

    # Perl 5.8 feature!
    # Opens filehandle to scalar. Needed because the
    # pod parser writes to STDOUT or to file. It does
    # not return any output.
    if ( open my $fh_1, '>', \$pod_text ) {
    	if ( open my $fh_2, "<$pod_path" ) {

            my $select_save = select($fh_1);
            $parser->parse_from_filehandle($fh_2, $fh_1);
            select($select_save);
            close $fh_1;

    	}
    	else { $pod_text .= "Oops! Cannot open POD file: $!" }
    }
    else { $pod_text .= "Oops! Cannot open to scalar: $!" }
    return $pod_text;
}

sub make_html {
    system( 'pod2html',
        '--title', basename(__FILE__),
        '--backlink', 'Back to Top',
        '--outfile', $html_path,
        '--infile', $pod_path,
    );
    my $rm_files = dirname(__FILE__) . '/pod2htm*';
    if ($^O =~ /Win32/i) { $rm_files =~ s/\//\\/g; system("del $rm_files") }
    else { $rm_files =~ s/\\/\//g; system("rm $rm_files"); }
    print "New HTML: $html_path\n";
}

#####################
# End GUS::Document #
########################
# Begin GUS::SQL_Panel #
# Version 2005-11-03   #
########################

package GUS::SQL_Panel;

# NOTE: Does not use GUS::Tk package for widgets.

use Tk;
use Tk::DialogBox;
use Tk::LabEntry;
use File::Basename;
use XML::Simple;

use vars qw(
    $mw_sql $t_sql_rsp $t_sql_qry
    $qry_cnt $qry_index
    $data_base $user_name $pass_word
    $example_canned_queries_doc
    $help_canned_queries_doc
    %canned_query_sets
);

# Example docs outside MainLoop must be pre-defined.
BEGIN {

# Example XML doc for custom canned query set.
# Also written as default SQL menu XML file if none prior exists.
$example_canned_queries_doc = <<END_HERE;
<sql_queries>
  <!-- The 'title' node is how this query set will list in the selector menu -->
  <title>Public schema information</title>
  <!-- Innumerate 'set' nodes to so Perl can parse menu order -->
  <set_01>
    <!-- The 'key' node contains what will display in the checkbox widget -->
    <key>List all public catalogs</key>
    <!-- The 'value' node contains the SQL query -->
    <value>
        --
        -- List all catalogs in the public schema.
        --
        SELECT table_catalog
        FROM information_schema.tables
        WHERE table_schema = 'public'XML::Simple
        GROUP BY table_catalog;
    </value>
  </set_01>
  <set_02>
     <key>List all public tables</key>
     <value>        --
        -- List all tables in the public schema.
        --
        SELECT table_catalog, table_name
        FROM information_schema.tables
        WHERE table_schema = 'public'
        ORDER BY table_catalog, table_name;
     </value>
  </set_02>
  <set_03>
     <key>Describe all public columns</key>
     <value>        --
        -- Describe all columns in the public schema.
        --
        SELECT table_catalog, table_name, column_name, data_type, is_nullable
        FROM information_schema.columns
        WHERE table_schema = 'public'
        ORDER BY table_catalog, table_name, column_name;
     </value>
  </set_03>
</sql_queries>
END_HERE

# Doc for help menu
$help_canned_queries_doc = <<END_HERE;
Can your own custom queries! Keep as many sets
as you like each in its own seperate XML file.

Format each set following the example shown
in the pull-down 'Examples' menu.

Access them by calling up the regular menu for
built-in canned queries and further selecting
the 'New Menu' button to browse for XML docs
containing your own custom canned queries.
END_HERE

} # Tail of BEGIN

# Used in Database menu.
sub get_canned_query_menu {
    my $sql_default_set = dirname($main::script_list) . '/sql_query_set_000.xml';
    if (open SQL, "<$sql_default_set") { close SQL }
    elsif (open SQL, ">$sql_default_set") {
        print SQL $example_canned_queries_doc;
        close SQL;
    }
    else {
        GUS::pop_up_window::start_MainLoop(
            'gold', 'Error: ',
            "At sub 'GUS::SQL_Panel::get_canned_query_menu', the file\n"
            . "'$sql_default_set'\n"
            . "does not exist and cannot be written:\n$!\n",
            'Close', sub{}, [],
        ); # No 2nd button.
    }
    GUS::SQL_Menu::start_MainWindow(
        $sql_default_set,
        sub { $t_sql_qry->insert( 'end', $_[0] ) },
    )
}

# Used in Examples menu.XML::Simple
sub exemplify_canned_queries {
    GUS::pop_up_window::start_MainLoop(
        'white', 'Example canned query set in XML format: ',
        $example_canned_queries_doc,
        'Close', sub{}, [],
    ); # No 2nd button.
}

# Used in Help menu.
sub help_canned_queries {
    GUS::pop_up_window::start_MainLoop(
        'white', 'Can your own custom queries in XML format: ',
        $help_canned_queries_doc,
        'Close', sub{}, [],
    ); # No 2nd button.
}

######################################
# BEGIN CANNED QUERY MENU LIST STUFF #
######################################

# Create a menu of canned queries
sub present_canned_query_menu {
    my $parent = shift;
    catalog_canned_queries();
    my $query_list_ref = [];
    foreach my $key ( sort keys(%canned_query_sets) ) {
        push @$query_list_ref, [
            'command' => "$key",
            -command => sub {
                GUS::SQL_Menu::start_MainWindow(
                    $key,
                    $canned_query_sets{$key},
                    sub { $t_sql_qry->insert( 'end', $_[0] ) }
                )
            }
        ];
    }
    $parent->Menubutton(
         -text      => " Canned Queries ",
         -menuitems => $query_list_ref
    )->pack( -side => 'left' );
}

# Scan directory for canned queries in XML format
sub catalog_canned_queries {
    my @cans;
    my $dir_path = dirname($main::script_list);
    if ( opendir DIR, $dir_path) {
        @cans = grep { /^sql_query_set_[0-9]+\.xml/ && -f "$dir_path/$_" } readdir(DIR);
        closedir DIR;
    }
    foreach (@cans) { explore_canned_query("$dir_path/$_") }
}

# Load from text file
sub explore_canned_query {
    my $file_path = shift;
    my $xml_sql = XML::Simple->new();
    if ( my $tree = $xml_sql->XMLin($file_path) ) {
        my $title = $tree->{'title'};
        $canned_query_sets{$title} = "$file_path" if $title;
    }
    else {
        my $reply = "Oops! Module XML::Simple could not deal with '$file_path': $!";
        GUS::pop_up_window::start_MainLoop(
            'gold', 'Error',
            $reply,
            'Close', sub{}, [],
        );
   }
}

######################################
# END CANNED QUERY MENU LIST STUFF #
######################################

sub start_MainWindow {

    $mw_sql = MainWindow->new( -title => 'SQL Client Panel' );
    $mw_sql->minsize(600,400);

    # Colors for help info balloons and info message area.
    my $balloon_bg = 'darkseagreen';
    my $balloon_fg = 'black';

    # Provide help info as balloon widgets.
    my $help_info = $mw_sql->Label(
       -borderwidth => 2,
       -relief      => 'groove',
       -background  => $balloon_bg,
       -foreground  => $balloon_fg,
    );
    my $balloon = $mw_sql->Balloon(
       -statusbar       => $help_info,
       -balloonposition => 'mouse',
       -background      => $balloon_bg,
       -foreground      => $balloon_fg,
    );
    $balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );

    $data_base = '';
    $user_name = '';
    $pass_word = '';
    $qry_cnt = 1;

    my @sql_cstm_qry_list;
    my %sql_cstm_qry_hash;
    my $sql_cstm_qry_reply;

    # Menu One
    my $fm_menu_1 = $mw_sql->Frame(
        -relief => 'groove',
        -borderwidth => 2
    )->pack( -side => 'top', -expand  => 0, -fill => 'x' );
    $fm_menu_1->Menubutton(
         -text      => " Database ",
         -menuitems => [
            [ 'command' => "Login Info", -command => \&login_sql ],
            "-",
            [ 'command' => "Quit",       -command => \&quit_MainLoop ]
        ]
    )->pack( -side => 'left' );

    # Auto-create menu of canned queries from external XML files.
    present_canned_query_menu($fm_menu_1);

    # Menu Examples
    $fm_menu_1->Menubutton(
         -text      => " Examples ",
         -menuitems => [ [ 'command' => "Canned Query File", -command => \&exemplify_canned_queries ] ]
    )->pack( -side => 'left' );

    # Menu Help
    $fm_menu_1->Menubutton(
         -text      => " Help ",
         -menuitems => [ [ 'command' => "Canned Query Howto", -command => \&help_canned_queries ] ]
    )->pack( -side => 'left' );

    # Sunken SQL frame
    my $fm_sql = $mw_sql->Frame(
        -relief => 'sunken',
        -borderwidth => 5
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    # The SQL pane.
    my $pane_sql = $fm_sql->Scrolled(
        'Pane',
        -scrollbars => 'osoe',
        -sticky     => 'nsew',
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    # The UPPER SQL frame.
    my $fm_sql_rsp = $pane_sql->Frame(
        -relief => 'flat',
        -borderwidth => 5
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    $fm_sql_rsp->Label(
        -width => 10,
        -anchor => 'e',
        -text => 'Response:'
    )->pack( -side => 'top' );

    $t_sql_rsp = $fm_sql_rsp->Scrolled(
        'Text',
        -width  => 80,
        -height => 18,
        -wrap   => 'none',
        -font   => 'courier',
        -scrollbars => 'se',
        -foreground => 'blue',
        -background => 'white',
    )->pack( -side  => 'top', -expand => 1, -fill => 'both' );

    # Set color tags for upper text widget.
    $t_sql_rsp->tagConfigure('red', -foreground => 'red');
    $t_sql_rsp->tagConfigure('darkgreen', -foreground => 'darkgreen');
    $t_sql_rsp->tagConfigure('black', -foreground => 'black');

    # The LOWER SQL frame.
    my $fm_sql_qry = $pane_sql->Frame(
        -relief => 'flat',
        -borderwidth => 5
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    $fm_sql_qry->Label(
        -width => 10,
        -anchor => 'e',
        -text => "Query:"
    )->pack( -side  => 'top' );

    $t_sql_qry = $fm_sql_qry->Scrolled(
        'Text',
        -width  => 80,
        -height => 8,
        -wrap   => 'none',
        -font   => 'courier',
        -scrollbars => 'se',
        -foreground => "blue",
        -background => "white",
    )->pack( -side  => 'top', -expand => 1, -fill => 'both' );

    # Set color tags for lower text widget.
    $t_sql_qry->tagConfigure('black', -foreground => "black");
    $t_sql_qry->tagConfigure('red', -foreground => "red");

    $qry_index = '0.1';
    $t_sql_qry->insert( 'end', "--NOTE: Login info for SQL required via pull-down menu.\n", 'red' );

    # Pack here so as to be just above bottom buttons.
    $help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );

    # Bottom row of action buttons.
    my @buttons_actions = GUS::tk::frame_label_buttons(
        $mw_sql,
        'Actions:',
        [ 'Clear Upper', 'Clear Lower', 'Submit Query', 'Close' ],
        [
            sub { $t_sql_rsp->delete( 0.1, 'end' ) },
            sub {
                $t_sql_qry->delete( 0.1, 'end' );
                $qry_index = '0.1'
            },
            \&custom_query,
            \&quit_MainLoop,
        ],
        [
            'green',
            'gold',
            'orange',
            'blue',
        ]
    );

    $balloon->attach(
        $buttons_actions[2],
        -balloonmsg => 'Forget respones?',
        -statusmsg => 'Empty prior SQL responses from the upper frame.'
    );
    $balloon->attach(
        $buttons_actions[3],
        -balloonmsg => 'Forget queries?',
        -statusmsg => 'Empty prior SQL queries from the lower frame.'
    );
    $balloon->attach(
        $buttons_actions[4],
        -balloonmsg => 'Submit SQL query?',
        -statusmsg => 'Submit latest query from lower frame to the SQL server.'
    );
    $balloon->attach(
        $buttons_actions[5],
        -balloonmsg => 'Close window?',
        -statusmsg => 'Exit SQL client by closing this window.'
    );

    MainLoop;
}

# Dialog box for login info.
sub login_sql {
    my $db = $mw_sql->DialogBox(
       -title => 'Login',
       -buttons => ['Ok'],
       -default_button => 'Ok');
    $db->add('LabEntry',
       -textvariable => \$data_base,
       -width => 20,
       -label => 'Database',
       -labelPack => [-side => 'left', -anchor => 'w'],
       -labelFont => '9x15bold',
       -background => 'white')->pack;
    $db->add('LabEntry',
       -textvariable => \$user_name,
       -width => 20,
       -label => 'Username',
       -labelPack => [-side => 'left', -anchor => 'w'],
       -labelFont => '9x15bold',
       -background => 'white')->pack;
    $db->add('LabEntry',
       -textvariable => \$pass_word,
       -width => 20,
       -label => 'Password',
       -show => '*',
       -labelPack => [-side => 'left', -anchor => 'w'],
       -labelFont => '9x15bold',
       -background => 'white')->pack;
    $db->Show();
}

# Handle direct SQL querries via upper and lower text widgets.
sub custom_query {
    my $query = $t_sql_qry->get( $qry_index, 'end' );
    
    my @queries = split /;/, $query;
    while ($queries[-1] !~ /^\s*$/) {pop @queries}
    
    # So can get individual results from multiple query statements.
    foreach ( @queries ) {
        my @rpc_replies = main::relay_sql_query_plural(
            ( join "\000", ($data_base, $user_name, $pass_word, $_) ),
            @main::clients_subset
        );
        foreach ( @rpc_replies ) { display_query($_) }    
    }
}

# Shows DB results in the two text windows.
sub display_query {
    my ($xmlrpc_rsp, $sql_con, $sql_rsp, $sql_fdbk, $sql_dis) = split /\000/, shift;
    chomp $sql_dis;

    my $rpc_clr = $xmlrpc_rsp =~ /Oops/ ? 'red' : 'darkgreen';
    $t_sql_rsp->insert( 'end', "$xmlrpc_rsp", "$rpc_clr" );
    $t_sql_rsp->insert( 'end', "<SQL $qry_cnt: $sql_con> \n" );
    $t_sql_rsp->insert( 'end', "$sql_rsp", 'black');
    $t_sql_rsp->insert( 'end', "<SQL $qry_cnt: $sql_dis> \n" );
    $t_sql_qry->insert( 'end', "\n" );
    $qry_index = $t_sql_qry->index('end');

    if ($xmlrpc_rsp =~ /Can.t call method "prepare" on an undefined value/) {
        $sql_fdbk = "Oops! Something undefined. Login values?";
    }

    # Must add further row to $t_sql_qry text box or index will be off by one.
    $t_sql_qry->insert( 'end', "<SQL $qry_cnt: $sql_fdbk>\n", 'black' );
    ++$qry_cnt;
    $t_sql_rsp->see('end');
    $t_sql_qry->see('end');
}

sub quit_MainLoop {
  GUS::SQL_Menu::quit_MainLoop();
  $mw_sql->destroy() if Tk::Exists($mw_sql);
}

######################
# End GUS::SQL_Panel #
#######################
# Begin GUS::SQL_Menu #
# Version 2005-10-31  #
#######################

package GUS::SQL_Menu;

# NOTE: Does not use GUS::Tk package for widgets.

use Tk;
use XML::Simple;
use Data::Dumper;

# Used to open files in Tk.
my $xml_file_types = [
    [ 'ASCII', '.xml', 'TEXT' ],
    [ 'Any',   '.*',   'TEXT' ]
];

use vars qw(
    $mw_sql_menu $fm_0 $pane_0 @qrys_defn @checks_qrys $sub_title
);

sub start_MainWindow {
    $sub_title = shift;
    my ($xml_path, $cmd_ref) = @_;

    # Only one pop-up at a time.
    quit_MainLoop() if Tk::Exists $mw_sql_menu;

    $mw_sql_menu = MainWindow->new( -title => 'SQL Client Menu' );

    # Colors for help info balloons and info message area.
    my $balloon_bg = 'darkseagreen';
    my $balloon_fg = 'black';

    # Provide help info as balloon widgets.
    my $help_info = $mw_sql_menu->Label(
       -borderwidth => 2,
       -relief      => 'groove',
       -background  => $balloon_bg,
       -foreground  => $balloon_fg,
    );
    my $balloon = $mw_sql_menu->Balloon(
       -statusbar       => $help_info,
       -balloonposition => 'mouse',
       -background      => $balloon_bg,
       -foreground      => $balloon_fg,
    );
    $balloon->attach( $help_info, -msg => 'Hover mouse on any widget then read here.' );

    # Sunken SQL frame
    $fm_0 = $mw_sql_menu->Frame(
        -relief => 'sunken',
        -borderwidth => 5
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    # The 0th pane.
    $pane_0 = $fm_0->Scrolled(
        'Pane',
        -scrollbars => 'osoe',
        -sticky     => 'new',
    )->pack( -side => 'top', -expand => 1, -fill => 'both' );

    load_sql_queries($xml_path);

    # Pack here so as to be just above bottom buttons.
    $help_info->pack( -side => 'top', -expand => 0, -fill => 'x' );

    my @buttons_actions = GUS::tk::frame_label_buttons(
        $mw_sql_menu,
        'Actions:',
        [ 'Append', 'New Menu', 'Quit' ],
        [
            sub {
                &$cmd_ref( poll_query_subset() );
                GUS::tk::clear_frame_label_checks(@checks_qrys);
            },
            sub {
                my $file_path = $mw->getOpenFile(-filetypes => $xml_file_types);
                load_sql_queries($file_path);
            },
            \&quit_MainLoop,
        ],
        [
            'green',
            'gold',
            'blue',
        ]
    );

    $balloon->attach(
        $buttons_actions[2],
        -balloonmsg => 'Append query?',
        -statusmsg => 'Append selected query into SQL Panel query window.'
    );
    $balloon->attach(
        $buttons_actions[3],
        -balloonmsg => 'Change menu?',
        -statusmsg => 'Re-compose menu from an XML file of diffferent SQL queries..'
    );
    $balloon->attach(
        $buttons_actions[4],
        -balloonmsg => 'Close?',
        -statusmsg => 'Close this menu window.'
    );

    MainLoop;
}

# Get list of selected queries from checkbuttons.
sub poll_query_subset {
    my @subset = ();
    my $i = 0;
    foreach ( GUS::tk::poll_frame_label_checks(@checks_qrys) ) {
        if ($_) { push @subset, $qrys_defn[$i] }
        ++$i;
    }
    return( join "\n", @subset );
}

# As a sub so can change list by loading text file.
sub display_sql_queries {
    my $tree = shift;

    # Clear away old checkbuttons.
    foreach ( @checks_qrys[0..2] ) {
        $_->destroy() if Tk::Exists($_);
    }

    my ( @qrys_cmnt, @qrys_on, @qrys_off, @qrys_checked, @qrys_cmds );

    # Build menu from tree parsed by XML::Simple
    foreach my $key ( sort keys(%$tree) ) {
        next unless $key =~ /^set_[0-9]+/; # Skip nodes not like <set_001>, etc.
        if ( ref($tree->{$key}) eq 'HASH' ) {
            push @qrys_cmnt,    $tree->{$key}->{'key'};
            push @qrys_defn,    $tree->{$key}->{'value'};
            push @qrys_on,      1;
            push @qrys_off,     0;
            push @qrys_checked, 0;
            push @qrys_cmds,    sub {};
        }
        else {
            my $wtf = Dumper($tree);
            my $reply = "Oops! Sub 'display_sql_queries' choked on unexpected XML format:\n\n$wtf";
            GUS::pop_up_window::start_MainLoop(
                'gold', 'Error',
                $reply,
                'Close', sub{}, [],
            );
        }
    }

    unindent_xml_node(\@qrys_defn);

    # Build a frame, label and checkboxes.
    @checks_qrys = GUS::tk::frame_label_checks(
        12,
        $pane_0,
        "$sub_title:",
        \@qrys_cmnt,            # Like: -- Get such-and-such
        \@qrys_on,              # on-value refs
        \@qrys_off,             # off-value refs
        \@qrys_checked,         # checked or not
        \@qrys_cmds,            # actions taken when checked
        'top',                  # How to align checkbuttons
    );

    # Because Win32 hideously center justifys ballon text.
    # Font change works with sub 'pad_right_recitify' to force left-justify text.
    $balloon->configure(-font => "{Courier} 10 {normal}") if ($^O =~ /Win32/i);

    # Attach a balloon to each widget.
    for (my $j = 2; $j < $#checks_qrys; $j += 2) {
        $balloon->attach(
            $checks_qrys[$j],
            -balloonmsg => pad_right_rectify($qrys_defn[$j/2 - 1]),
            -statusmsg => 'Check to include this SQL query in next exchange.'
        );
    }
}

# Overcome Win32 Tk::Balloon center justification by padding.
# Works well only when balloon configured for monospace font.
sub pad_right_rectify {
    my $i = 0;
    my @block = split "\n", shift;
    foreach (@block) { $i = length $_ if $i < length $_ }
    my $fmt = '%' . -$i . 's';
    for (my $j = 0; $j <= $#block; ++$j) {
        $block[$j] = sprintf "$fmt", $block[$j]
    }
    return join "\n", @block;
}

# Unindent whitespace left over from XML
# so that SQL will be pretty.
sub unindent_xml_node {
    my $aref = shift;
    for (my $i = 0; $i <= $#{$aref}; ++$i) {
        $aref->[$i] =~ s/^\s*\n//; # Lose 0th all-blank line,if any.
        my @lines = split "\n", $aref->[$i];

        # Un-indent all lines until 0th line un-indented.
        while ($lines[0] =~ /^\s/) {
            for (my $j = 0; $j <= $#lines; ++$j) {
                $lines[$j] =~ s/^\s//;
            }
        }
        $aref->[$i] = join "\n", @lines;
    }
}

# Load from text file
sub load_sql_queries {
    my $file_path = shift;
    $file_path =~ s{\\}{\/}g; # Perlify file path.
    if ($file_path) { $file_path = "$file_path" }
    else { $file_path = $mw->getOpenFile(-filetypes => $xml_file_types) }

    @qrys_defn = ();

    my $xml_sql = XML::Simple->new();
    if ( my $tree = $xml_sql->XMLin($file_path) ) {
        display_sql_queries($tree);
    }
    else {
        my $reply = "Oops! Module XML::Simple could not deal with '$file_path': $!";
        GUS::pop_up_window::start_MainLoop(
            'gold', 'Error',
            $reply,
            'Close', sub{}, [],
        );
   }
}

sub quit_MainLoop {
  $mw_sql_menu->destroy() if Tk::Exists($mw_sql_menu);
}

#####################
# End GUS::SQL_Menu #
#####################

__END__

=head1 NAME

XML-RPC Client GUI

=head1 VERSION

Release date = 2006-06-20

=head1 SYNOPSIS

C<perl gus_xml-rpc_client_tk.pl --help>

=head1 DESCRIPTION

An XML-RPC client GUI useful in triggering external Perl scripts on any PC running the companion server.

=head1 FEATURES

=head2 User Options

These are things you can and should change.

=head3 Server Method Paths

The companion server for this client employs a custom XML-RPC method namedB<C< execute_script >> where the client sends it a text string containing the path to an external Perl script. The server then opens said script as a script (aka 'runs' it). For security reasons, only a finite set of these will the server accept. This list is available to the client in the form of a line-delimitedB<C< *.txt >> file. So that the client may find this list, you will need your own default directory path and default file name in the obvious place near the head of this XML-RPC client script.

=head4 When Sharing a Network Directory

This is to say, when a common path is attainable by both server and client. Click theB<C< Execute >> button on the client, then browse the shared network for aB<C< *.txt >> file of server-approvedB<C< *.pl >> files. A pop-up menu of that very list will appear. Select any of the B<C< *.pl >> files which you wish the server to run.

=head4 When Residing on Separate Networks

This is to say, when neither the server nor client share any hard drive resources. Click theB<C< Execute >> button on the client, then browse the local network for an updated copy of the B<C< *.txt >> file listing server-approvedB<C< *.pl >> files. A pop-up menu of that copied list will appear. Select any of theB<C< *.pl >>files, et cetera, which you wish the server to execute.

=head3 Local Port

The default local port for server URLs isB<C< 8080>>. This may be overriden by calling the client via command line and listing some port other thanB<C< 8080 >> as the first command-line argument. Or you may prefer to edit the built-in default near the head of this script. Chances are you need not change this. But if you should find that portB<C< 8080 >>is already in use for some other service (or blocked by a firewall), try instead portB<C< 8888>>, or any other as deemed convenient.

=head3 For the add_doc_elsewhere method

This is a method where, upon clicking theB<C< Send >>button, you browse for a pure ASCII document. A filtered copy thereof will be transmitted to selected servers. Upon receipt, each server will choose its own path for whatever kind of file it is.

The aforementioned filtering is accomplished skipping over any such lines as match against regular expressions from theB<C< %lines_to_skip >> hash whose keys are likewise regular expressions matching the filenames of user-selected documents.

=over 4

=item Example usage

The author employs theB<C< add_doc_elsewhere >>method as follows. Certain MTS servo-hydraulic testing machines which are left to run unattended on weekends had formerly required on-site visitation by operators working on overtime, and at their considerable inconvenience. Most frequently, however, such efforts were merely to determine that, no, the machines in question had not stopped and did not therefor require any service.

=back

=head2 Choosing Servers

At startup, this client will only know its own URL (on the assumption that the companion XML-RPC server runs there also...for testing purposes, or whatever). To change this, read in a list of any other URLs from a text file via the pull-down menu 'Config', sub-menu 'Load Server URLs'. Said text file should contain one URL per line, such asB<C< 168.192.0.1 >> orB<C< foo.bar.net:8080 >> orB<C< foo.bar.net:8080/RPC2>>. On any such URL, if at front theB< C< http:// >> or at back either theB< C< :8080 >> or the B< C< /RPC2 >> are missing, they will be added. Or you may prefer to edit the built-in default list near the head of this script. Optionally, each listed URL may include a single B<C< TAB >> followed by descriptive text on the same line.

=head2 Client Relays

The firewall-penetrating ability of XML-RPC can be exploited to relay communication with various daemons other than just XML-RPC itself.

=over 4

=item SQL Queries

An SQL client is already built into the companion XML-RPC server. Thus are SQL queries facilitated anywhere you can run the XML-RPC client. The author employs this for prototyping on his PostgreSQL server at home an equipment calibration DB for eventual use at work thus affording the freedom to tinker with it after hours and on weekends.

=back

=head1 SECURITY

=over 4

=item Encryption

A full 56-byte Blowfish cipher is employed to secure data contained within the otherwise standard XML-RPC transactions. At startup, both client and server must employ identical plain text pass phrases (refer toB<C< $cipher_key >>near the head of each). Or if this has been left empty, a default pass phrase (refer toB<C< $GUS::Crypt::DEFAULT_KEY >>near the tail of each) will serve in its stead. The client may later propagate new pass phrases to selected servers at any time.

=item For all methods

Method names are irreversibly obfuscated at startup (refer to subroutineB<C< $GUS::Crypt::obfuscate >>for details) and again each time the cipher is changed.

Transactions also require a password. At startup, both client and server must employ identical plain text passwords (refer toB<C< $plain_pw >>near the head of each). The client may later propagate new passwords to selected servers at any time. Obviously, when leaving the client unattended, you should delete any stars from the password entry widget.

=item For the execute_script method

In making a script-execution request, all that the client does is pass a name to the server. The server makes its own determination whether to run said script. Firstly, the server enforces its own directory for executable scripts (same as forB<C< $script_list >>) stripping away any ascending path elements. Secondly, it checks against its own list of allowable scripts (refB<C< $script_list>>). Thirdly it makes sure the script is pure ASCII. Lastly it insures against any modification since upload or server startup.

=item Vulnerabilities

The server enforces whatever conditions it found on startup. That is to say, it cannot know whether a script to be employed by theB<C< execute_script >>method is free from any malicious tampering prior to startup. This is the sole responsibility of the user.

=back

=head1 DEPENDENCIES

=head2 Perl Modules

Install these into Perl via ActiveState PPM, else into NetBSD pkgsrc or CPAN as appropriate for your OS:B<C< Frontier::Client >>,B<C< Tk >>,B<C< Sys::Hostname::Long>>,B<C< Crypt::CBC >>,B<C< Crypt::Blowfish>>,B<C< Log::Logger>>,B<C< XML::Simple>>,B<C< Data::Dumper>>.

A number of my own B<C< GUS::* >> packages are already embeded in both the client and server scripts. These do not add much that is truly novel but exist as separate packages for the sake of authorial convenience.

=head2 For Unix

Nothing here presentes itself as a difficulty. Required external dependencies are available from the expected sources: B<C</usr/pkgsrc>> for NetBSD and/or CPAN for Perl. I cannot say for Linux, since I have yet to try it. If any report a problem for Linux, I would very like to help work it out and document the solution here.

=head2 For Win32

No especial problems here either, except that some things are not where most folks expect to find them.

=over 4

=item Cryptography for ActiveState Perl 5.8

The Crypt::* family of modules is not fully maintained by ActiveState who fears a lowering brow the US alphabet agencies. Happily, folks in more freedom-loving countries have ammended this lack. Just perform these steps in the ActiveState PPM window.

ppm> help repository

ppm> repository add "Lincoln Stein" http://stein.cshl.org/ppm

ppm> repository add "Randy Kobes" http://theoryx5.uwinnipeg.ca/ppms

=back

=head2 Companion XML-RPC Server

Unless the companion Perl script B< C<gus_xml-rpc_server.pl> > running on some other network-attached PC, this client GUI will lack any server to communicate with. Refer to documentation for the server at this URL: L<http://starling.us/tet/gus_perl/gus_xml-rpc_pl/gus_xml-rpc_server.html>.

For testing purposes, of course, client and server may both be run on a single PC.

=head2 Auxilliary Perl Scripts

For use with theB<C< execute_script >> method. Refer to documentation of the companion XML-RPC server for a complete list of these.

=head2 Auxilliary Text Files

At startup the client only knows its own URL. That of course assumes the companion XML-RPC server to be running on the same PC. Other than for testing purposes this is clearly rather silly. To be useful then, create your own list of URLs storing these in a text file. Refer to the pull-down help menu for an example.

=head1 AUTHOR

Gan Uesli Starling <F<gan@starling.us>>

=head1 COPYRIGHT

Copyright (c) 2005-2006, Gan Uesli Starling. All rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=head1 SCRIPT CATEGORIES

Network

=cut