mirror of
https://github.com/duncs/clusterssh.git
synced 2025-07-01 17:11:14 +00:00
2381 lines
69 KiB
Perl
2381 lines
69 KiB
Perl
package App::ClusterSSH;
|
|
|
|
use 5.008.004;
|
|
use warnings;
|
|
use strict;
|
|
use version; our $VERSION = version->new('4.00_11');
|
|
|
|
use Carp;
|
|
|
|
use base qw/ App::ClusterSSH::Base /;
|
|
use App::ClusterSSH::Host;
|
|
|
|
use POSIX ":sys_wait_h";
|
|
use Pod::Usage;
|
|
use Getopt::Long qw(:config no_ignore_case bundling no_auto_abbrev);
|
|
use POSIX qw/:sys_wait_h strftime mkfifo/;
|
|
use File::Temp qw/:POSIX/;
|
|
use Fcntl;
|
|
use Tk 800.022;
|
|
use Tk::Xlib;
|
|
use Tk::ROText;
|
|
require Tk::Dialog;
|
|
require Tk::LabEntry;
|
|
use X11::Protocol;
|
|
use X11::Protocol::Constants qw/ Shift Mod5 ShiftMask /;
|
|
use vars qw/ %keysymtocode %keycodetosym /;
|
|
use X11::Keysyms '%keysymtocode', 'MISCELLANY', 'XKB_KEYS', '3270', 'LATIN1',
|
|
'LATIN2', 'LATIN3', 'LATIN4', 'KATAKANA', 'ARABIC', 'CYRILLIC', 'GREEK',
|
|
'TECHNICAL', 'SPECIAL', 'PUBLISHING', 'APL', 'HEBREW', 'THAI', 'KOREAN';
|
|
use File::Basename;
|
|
use Net::hostent;
|
|
use Carp;
|
|
use Sys::Hostname;
|
|
use English;
|
|
use Socket;
|
|
|
|
# Notes on general order of processing
|
|
#
|
|
# parse cmd line options for extra config files
|
|
# load system configuration files
|
|
# load cfg files from options
|
|
# overlay rest of cmd line args onto options
|
|
# record all clusters
|
|
# parse givwen tags/hostnames and resolve to connections
|
|
# open terminals
|
|
# optionally open console if required
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
|
|
my $self = $class->SUPER::new(%args);
|
|
|
|
# catch and reap any zombies
|
|
$SIG{CHLD} = \&REAPER;
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub REAPER {
|
|
my $kid;
|
|
do {
|
|
$kid = waitpid( -1, WNOHANG );
|
|
logmsg( 2, "REAPER currently returns: $kid" );
|
|
} until ( $kid == -1 || $kid == 0 );
|
|
}
|
|
|
|
# Command line options list
|
|
my @options_spec = (
|
|
'debug:+',
|
|
'd', # backwards compatibility - DEPRECATED
|
|
'D', # backwards compatibility - DEPRECATED
|
|
'version|v',
|
|
'help|h|?',
|
|
'man|H',
|
|
'action|a=s',
|
|
'cluster-file|c=s',
|
|
'config-file|C=s',
|
|
'evaluate|e=s',
|
|
'tile|g',
|
|
'no-tile|G',
|
|
'username|l=s',
|
|
'master|M=s',
|
|
'options|o=s',
|
|
'port|p=i',
|
|
'autoquit|q',
|
|
'no-autoquit|Q',
|
|
'history|s',
|
|
'term-args|t=s',
|
|
'title|T=s',
|
|
'output-config|u',
|
|
'font|f=s',
|
|
'list|L',
|
|
'use_all_a_records|A',
|
|
);
|
|
my %options;
|
|
my %config;
|
|
my %clusters; # hash for resolving cluster names
|
|
my %windows; # hash for all window definitions
|
|
my %menus; # hash for all menu definitions
|
|
my @servers; # array of servers provided on cmdline
|
|
my %servers; # hash of server cx info
|
|
my $helper_script = "";
|
|
my $xdisplay;
|
|
my %keyboardmap;
|
|
my $sysconfigdir = "/etc";
|
|
my %ssh_hostnames;
|
|
|
|
$keysymtocode{unknown_sym} = 0xFFFFFF; # put in a default "unknown" entry
|
|
$keysymtocode{EuroSign}
|
|
= 0x20AC; # Euro sign - missing from X11::Protocol::Keysyms
|
|
|
|
# and also map it the other way
|
|
%keycodetosym = reverse %keysymtocode;
|
|
|
|
# Set up UTF-8 on STDOUT
|
|
binmode STDOUT, ":utf8";
|
|
|
|
#use bytes;
|
|
|
|
### all sub-routines ###
|
|
|
|
# Pick a color based on a string.
|
|
sub pick_color {
|
|
my ($string) = @_;
|
|
my @components = qw(AA BB CC EE);
|
|
my $color = 0;
|
|
for ( my $i = 0; $i < length($string); $i++ ) {
|
|
$color += ord( substr( $string, $i, 1 ) );
|
|
}
|
|
|
|
srand($color);
|
|
my $ans = '\\#';
|
|
$ans .= $components[ int( 4 * rand() ) ];
|
|
$ans .= $components[ int( 4 * rand() ) ];
|
|
$ans .= $components[ int( 4 * rand() ) ];
|
|
return $ans;
|
|
}
|
|
|
|
# close a specific host session
|
|
sub terminate_host($) {
|
|
my $svr = shift;
|
|
logmsg( 2, "Killing session for $svr" );
|
|
if ( !$servers{$svr} ) {
|
|
logmsg( 2, "Session for $svr not found" );
|
|
return;
|
|
}
|
|
|
|
logmsg( 2, "Killing process $servers{$svr}{pid}" );
|
|
kill( 9, $servers{$svr}{pid} ) if kill( 0, $servers{$svr}{pid} );
|
|
delete( $servers{$svr} );
|
|
}
|
|
|
|
# catch_all exit routine that should always be used
|
|
sub exit_prog() {
|
|
logmsg( 3, "Exiting via normal routine" );
|
|
|
|
# for each of the client windows, send a kill
|
|
|
|
# to make sure we catch all children, even when they havnt
|
|
# finished starting or received teh kill signal, do it like this
|
|
while (%servers) {
|
|
foreach my $svr ( keys(%servers) ) {
|
|
terminate_host($svr);
|
|
}
|
|
}
|
|
exit 0;
|
|
}
|
|
|
|
# output function according to debug level
|
|
# $1 = log level (0 to 3)
|
|
# $2 .. $n = list to pass to print
|
|
sub logmsg($@) {
|
|
my $level = shift;
|
|
|
|
if ( $level > 6 ) {
|
|
croak('requested debug level should not be above 6');
|
|
}
|
|
|
|
if ( $level <= $options{debug} ) {
|
|
print( strftime( "%H:%M:%S: ", localtime ) )
|
|
if ( $options{debug} > 1 );
|
|
print @_, $/;
|
|
}
|
|
}
|
|
|
|
# set some application defaults
|
|
sub load_config_defaults() {
|
|
$config{terminal} = "xterm";
|
|
$config{terminal_args} = "";
|
|
$config{terminal_title_opt} = "-T";
|
|
$config{terminal_colorize} = 1;
|
|
$config{terminal_bg_style} = 'dark';
|
|
$config{terminal_allow_send_events}
|
|
= "-xrm '*.VT100.allowSendEvents:true'";
|
|
$config{terminal_font} = "6x13";
|
|
$config{terminal_size} = "80x24";
|
|
$config{use_hotkeys} = "yes";
|
|
$config{key_quit} = "Control-q";
|
|
$config{key_addhost} = "Control-Shift-plus";
|
|
$config{key_clientname} = "Alt-n";
|
|
$config{key_history} = "Alt-h";
|
|
$config{key_retilehosts} = "Alt-r";
|
|
$config{key_paste} = "Control-v";
|
|
$config{mouse_paste} = "Button-2";
|
|
$config{auto_quit} = "yes";
|
|
$config{window_tiling} = "yes";
|
|
$config{window_tiling_direction} = "right";
|
|
$config{console_position} = "";
|
|
|
|
$config{screen_reserve_top} = 0;
|
|
$config{screen_reserve_bottom} = 60;
|
|
$config{screen_reserve_left} = 0;
|
|
$config{screen_reserve_right} = 0;
|
|
|
|
$config{terminal_reserve_top} = 5;
|
|
$config{terminal_reserve_bottom} = 0;
|
|
$config{terminal_reserve_left} = 5;
|
|
$config{terminal_reserve_right} = 0;
|
|
|
|
$config{terminal_decoration_height} = 10;
|
|
$config{terminal_decoration_width} = 8;
|
|
|
|
( $config{comms} = basename($0) ) =~ s/^.//;
|
|
$config{comms} =~ s/.pl$//; # for when testing directly out of cvs
|
|
$config{method} = $config{comms};
|
|
|
|
$config{title} = "C" . uc( $config{comms} );
|
|
|
|
$config{comms} = "telnet" if ( $config{comms} eq "tel" );
|
|
|
|
$config{comms} = "console" if ( $config{comms} eq "con" );
|
|
|
|
$config{ $config{comms} } = $config{comms};
|
|
|
|
$config{ssh_args} = " -x -o ConnectTimeout=10"
|
|
if ( $config{ $config{comms} } =~ /ssh$/ );
|
|
$config{rsh_args} = "";
|
|
|
|
$config{telnet_args} = "";
|
|
|
|
$config{console_args} = "";
|
|
|
|
$config{extra_cluster_file} = "";
|
|
|
|
$config{unmap_on_redraw} = "no"; # Debian #329440
|
|
|
|
$config{show_history} = 0;
|
|
$config{history_width} = 40;
|
|
$config{history_height} = 10;
|
|
|
|
$config{command} = q{};
|
|
$config{max_host_menu_items} = 30;
|
|
|
|
$config{max_addhost_menu_cluster_items} = 6;
|
|
$config{menu_send_autotearoff} = 0;
|
|
$config{menu_host_autotearoff} = 0;
|
|
|
|
$config{send_menu_xml_file} = $ENV{HOME} . '/.csshrc_send_menu';
|
|
|
|
$config{use_all_a_records} = 0;
|
|
}
|
|
|
|
# load in config file settings
|
|
sub parse_config_file($) {
|
|
my $config_file = shift;
|
|
logmsg( 2, "Reading in from config file $config_file" );
|
|
return if ( !-e $config_file || !-r $config_file );
|
|
|
|
open( CFG, $config_file ) or die("Couldnt open $config_file: $!");
|
|
my $l;
|
|
while ( defined( $l = <CFG> ) ) {
|
|
next
|
|
if ( $l =~ /^\s*$/ || $l =~ /^#/ )
|
|
; # ignore blank lines & commented lines
|
|
$l =~ s/#.*//; # remove comments from remaining lines
|
|
$l =~ s/\s*$//; # remove trailing whitespace
|
|
|
|
# look for continuation lines
|
|
chomp $l;
|
|
if ( $l =~ s/\\\s*$// ) {
|
|
$l .= <CFG>;
|
|
redo unless eof(CFG);
|
|
}
|
|
|
|
next unless $l =~ m/\s*(\S+)\s*=\s*(.*)\s*/;
|
|
my ( $key, $value ) = ( $1, $2 );
|
|
if ( defined $key && defined $value ) {
|
|
$config{$key} = $value;
|
|
logmsg( 3, "$key=$value" );
|
|
}
|
|
}
|
|
close(CFG);
|
|
|
|
# tidy up entries, just in case
|
|
$config{terminal_font} =~ s/['"]//g;
|
|
}
|
|
|
|
sub find_binary($) {
|
|
my $binary = shift;
|
|
|
|
logmsg( 2, "Looking for $binary" );
|
|
my $path;
|
|
if ( !-x $binary || substr( $binary, 0, 1 ) ne '/' ) {
|
|
|
|
# search the users $PATH and then a few other places to find the binary
|
|
# just in case $PATH isnt set up right
|
|
foreach (
|
|
split( /:/, $ENV{PATH} ), qw!
|
|
/bin
|
|
/sbin
|
|
/usr/sbin
|
|
/usr/bin
|
|
/usr/local/bin
|
|
/usr/local/sbin
|
|
/opt/local/bin
|
|
/opt/local/sbin
|
|
!
|
|
)
|
|
{
|
|
logmsg( 3, "Looking in $_" );
|
|
|
|
if ( -f $_ . '/' . $binary && -x $_ . '/' . $binary ) {
|
|
$path = $_ . '/' . $binary;
|
|
logmsg( 2, "Found at $path" );
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
else {
|
|
logmsg( 2, "Already configured OK" );
|
|
$path = $binary;
|
|
}
|
|
if ( !$path || !-f $path || !-x $path ) {
|
|
warn(
|
|
"Terminal binary not found ($binary) - please amend \$PATH or the cssh config file\n"
|
|
);
|
|
die unless ( $options{'output-config'} );
|
|
}
|
|
|
|
chomp($path);
|
|
return $path;
|
|
}
|
|
|
|
# make sure our config is sane (i.e. binaries found) and get some extra bits
|
|
sub check_config() {
|
|
|
|
# check we have xterm on our path
|
|
logmsg( 2, "Checking path to xterm" );
|
|
$config{terminal} = find_binary( $config{terminal} );
|
|
|
|
# check we have comms method on our path
|
|
logmsg( 2, "Checking path to $config{comms}" );
|
|
$config{ $config{comms} } = find_binary( $config{ $config{comms} } );
|
|
|
|
# make sure comms in an accepted value
|
|
die
|
|
"FATAL: Only ssh, rsh, telnet, and console/conserver protocols are currently supported (comms=$config{comms})\n"
|
|
if ( $config{comms} !~ /^(:?[rs]sh|telnet|console)$/ );
|
|
|
|
# Set any extra config options given on command line
|
|
$config{title} = $options{title} if ( $options{title} );
|
|
|
|
$config{auto_quit} = "yes" if $options{autoquit};
|
|
$config{auto_quit} = "no" if $options{'no-autoquit'};
|
|
|
|
# backwards compatibility & tidyup
|
|
if ( $config{always_tile} ) {
|
|
if ( !$config{window_tiling} ) {
|
|
if ( $config{always_tile} eq "never" ) {
|
|
$config{window_tiling} = "no";
|
|
}
|
|
else {
|
|
$config{window_tiling} = "yes";
|
|
}
|
|
}
|
|
delete( $config{always_tile} );
|
|
}
|
|
$config{window_tiling} = "yes" if $options{tile};
|
|
$config{window_tiling} = "no" if $options{'no-tile'};
|
|
|
|
$config{user} = $options{username} if ( $options{username} );
|
|
$config{port} = $options{port} if ( $options{port} );
|
|
|
|
$config{mstr} = $options{master} if ( $options{master} );
|
|
|
|
$config{terminal_args} = $options{'term-args'}
|
|
if ( $options{'term-args'} );
|
|
|
|
if ( $config{terminal_args} =~ /-class (\w+)/ ) {
|
|
$config{terminal_allow_send_events}
|
|
= "-xrm '$1.VT100.allowSendEvents:true'";
|
|
}
|
|
|
|
$config{internal_previous_state} = ""; # set to default
|
|
|
|
# option font overrides config file font setting
|
|
$config{terminal_font} = $options{font} if ( $options{font} );
|
|
get_font_size();
|
|
|
|
$config{extra_cluster_file} =~ s/\s+//g;
|
|
|
|
$config{ssh_args} = $options{options} if ( $options{options} );
|
|
|
|
$config{show_history} = 1 if $options{'show-history'};
|
|
|
|
$config{command} = $options{action} if ( $options{action} );
|
|
|
|
if ( $options{use_all_a_records} ) {
|
|
$config{use_all_a_records} = !$config{use_all_a_records} || 0;
|
|
}
|
|
}
|
|
|
|
sub load_configfile() {
|
|
parse_config_file( $sysconfigdir . '/csshrc' );
|
|
parse_config_file( $ENV{HOME} . '/.csshrc' );
|
|
if ( $options{'config-file'} ) {
|
|
parse_config_file( $options{'config-file'} );
|
|
}
|
|
check_config();
|
|
}
|
|
|
|
# dump out the config to STDOUT
|
|
sub dump_config {
|
|
my $noexit = shift;
|
|
|
|
logmsg( 3, "Dumping config to STDOUT" );
|
|
|
|
print("# Configuration dump produced by 'cssh -u'\n");
|
|
|
|
foreach ( sort( keys(%config) ) ) {
|
|
next
|
|
if ( $_ =~ /^internal/ && $options{debug} == 0 )
|
|
; # do not output internal vars
|
|
print "$_=$config{$_}\n";
|
|
}
|
|
exit_prog if ( !$noexit );
|
|
}
|
|
|
|
sub list_tags {
|
|
print( 'Available cluster tags:', $/ );
|
|
print "\t", $_, $/ foreach ( sort( keys(%clusters) ) );
|
|
exit_prog;
|
|
}
|
|
|
|
sub check_ssh_hostnames {
|
|
return unless ( $config{method} eq "ssh" );
|
|
|
|
my $ssh_config = "$ENV{HOME}/.ssh/config";
|
|
|
|
if ( -r $ssh_config && open( SSHCFG, "<", $ssh_config ) ) {
|
|
while (<SSHCFG>) {
|
|
next unless (m/^\s*host\s+([\w\.-]+)/i);
|
|
|
|
# account for multiple declarations of hosts
|
|
$ssh_hostnames{$_} = 1 foreach ( split( /\s+/, $1 ) );
|
|
}
|
|
close(SSHCFG);
|
|
}
|
|
|
|
if ( $options{debug} > 1 ) {
|
|
if (%ssh_hostnames) {
|
|
logmsg( 2, "Parsed these ssh config hosts:" );
|
|
logmsg( 2, "- $_" ) foreach ( sort( keys(%ssh_hostnames) ) );
|
|
}
|
|
else {
|
|
logmsg( 2, "No hostnames parsed from user ssh config file" );
|
|
}
|
|
}
|
|
}
|
|
|
|
sub evaluate_commands {
|
|
my ( $return, $user, $port, $host );
|
|
|
|
# break apart the given host string to check for user or port configs
|
|
print "{evaluate}=$options{evaluate}\n";
|
|
$user = $1 if ( $options{evaluate} =~ s/^(.*)@// );
|
|
$port = $1 if ( $options{evaluate} =~ s/:(\w+)$// );
|
|
$host = $options{evaluate};
|
|
|
|
$user = $user ? "-l $user" : "";
|
|
if ( $config{comms} eq "telnet" ) {
|
|
$port = $port ? " $port" : "";
|
|
}
|
|
else {
|
|
$port = $port ? "-p $port" : "";
|
|
}
|
|
|
|
print STDERR "Testing terminal - running command:\n";
|
|
|
|
my $terminal_command
|
|
= "$config{terminal} $config{terminal_allow_send_events} -e \"$^X\" \"-e\" 'print \"Working\\n\" ; sleep 5'";
|
|
|
|
print STDERR $terminal_command, $/;
|
|
|
|
system($terminal_command);
|
|
print STDERR "\nTesting comms - running command:\n";
|
|
|
|
my $comms_command = $config{ $config{comms} } . " "
|
|
. $config{ $config{comms} . "_args" };
|
|
|
|
if ( $config{comms} eq "telnet" ) {
|
|
$comms_command .= " $host $port";
|
|
}
|
|
else {
|
|
$comms_command .= " $user $port $host echo Working";
|
|
}
|
|
|
|
print STDERR $comms_command, $/;
|
|
|
|
system($comms_command);
|
|
|
|
exit_prog;
|
|
}
|
|
|
|
sub load_keyboard_map() {
|
|
|
|
# load up the keyboard map to convert keysyms to keyboardmap
|
|
my $min = $xdisplay->{min_keycode};
|
|
my $count = $xdisplay->{max_keycode} - $min;
|
|
my @keyboard = $xdisplay->GetKeyboardMapping( $min, $count );
|
|
|
|
# @keyboard arry
|
|
# 0 = plain key
|
|
# 1 = with shift
|
|
# 2 = with Alt-GR
|
|
# 3 = with shift + AltGr
|
|
# 4 = same as 2 - control/alt?
|
|
# 5 = same as 3 - shift-control-alt?
|
|
|
|
logmsg( 1, "Loading keymaps and keycodes" );
|
|
|
|
foreach ( 0 .. $#keyboard ) {
|
|
if ( defined $keyboard[$_][3] ) {
|
|
if ( defined( $keycodetosym{ $keyboard[$_][3] } ) ) {
|
|
$keyboardmap{ $keycodetosym{ $keyboard[$_][3] } }
|
|
= 'sa' . ( $_ + $min );
|
|
}
|
|
else {
|
|
logmsg( 2, "Unknown keycode ", $keyboard[$_][3] )
|
|
if ( $keyboard[$_][3] != 0 );
|
|
}
|
|
}
|
|
if ( defined $keyboard[$_][2] ) {
|
|
if ( defined( $keycodetosym{ $keyboard[$_][2] } ) ) {
|
|
$keyboardmap{ $keycodetosym{ $keyboard[$_][2] } }
|
|
= 'a' . ( $_ + $min );
|
|
}
|
|
else {
|
|
logmsg( 2, "Unknown keycode ", $keyboard[$_][2] )
|
|
if ( $keyboard[$_][2] != 0 );
|
|
}
|
|
}
|
|
if ( defined $keyboard[$_][1] ) {
|
|
if ( defined( $keycodetosym{ $keyboard[$_][1] } ) ) {
|
|
$keyboardmap{ $keycodetosym{ $keyboard[$_][1] } }
|
|
= 's' . ( $_ + $min );
|
|
}
|
|
else {
|
|
logmsg( 2, "Unknown keycode ", $keyboard[$_][1] )
|
|
if ( $keyboard[$_][1] != 0 );
|
|
}
|
|
}
|
|
if ( defined $keyboard[$_][0] ) {
|
|
if ( defined( $keycodetosym{ $keyboard[$_][0] } ) ) {
|
|
$keyboardmap{ $keycodetosym{ $keyboard[$_][0] } }
|
|
= 'n' . ( $_ + $min );
|
|
}
|
|
else {
|
|
logmsg( 2, "Unknown keycode ", $keyboard[$_][0] )
|
|
if ( $keyboard[$_][0] != 0 );
|
|
}
|
|
}
|
|
|
|
# dont know these two key combs yet...
|
|
#$keyboardmap{ $keycodetosym { $keyboard[$_][4] } } = $_ + $min;
|
|
#$keyboardmap{ $keycodetosym { $keyboard[$_][5] } } = $_ + $min;
|
|
}
|
|
|
|
#print "$_ => $keyboardmap{$_}\n" foreach(sort(keys(%keyboardmap)));
|
|
#print "keysymtocode: $keysymtocode{o}\n";
|
|
#die;
|
|
}
|
|
|
|
sub get_keycode_state($) {
|
|
my $keysym = shift;
|
|
$keyboardmap{$keysym} =~ m/^(\D+)(\d+)$/;
|
|
my ( $state, $code ) = ( $1, $2 );
|
|
|
|
logmsg( 2, "keyboardmap=:", $keyboardmap{$keysym}, ":" );
|
|
logmsg( 2, "state=$state, code=$code" );
|
|
|
|
SWITCH: for ($state) {
|
|
/^n$/ && do {
|
|
$state = 0;
|
|
last SWITCH;
|
|
};
|
|
/^s$/ && do {
|
|
$state = Shift();
|
|
last SWITCH;
|
|
};
|
|
/^a$/ && do {
|
|
$state = Mod5();
|
|
last SWITCH;
|
|
};
|
|
/^sa$/ && do {
|
|
$state = Shift() + Mod5();
|
|
last SWITCH;
|
|
};
|
|
|
|
die("Should never reach here");
|
|
}
|
|
|
|
logmsg( 2, "returning state=:$state: code=:$code:" );
|
|
|
|
return ( $state, $code );
|
|
}
|
|
|
|
# read in all cluster definitions
|
|
sub get_clusters() {
|
|
|
|
# first, read in global file
|
|
my $cluster_file = '/etc/clusters';
|
|
|
|
logmsg( 3, "Logging for $cluster_file" );
|
|
|
|
if ( -f $cluster_file ) {
|
|
logmsg( 2, "Loading clusters in from $cluster_file" );
|
|
open( CLUSTERS, $cluster_file ) || die("Couldnt read $cluster_file");
|
|
my $l;
|
|
while ( defined( $l = <CLUSTERS> ) ) {
|
|
next
|
|
if ( $l =~ /^\s*$/ || $l =~ /^#/ )
|
|
; # ignore blank lines & commented lines
|
|
chomp $l;
|
|
if ( $l =~ s/\\\s*$// ) {
|
|
$l .= <CLUSTER>;
|
|
redo unless eof(CLUSTERS);
|
|
}
|
|
my @line = split( /\s/, $l );
|
|
|
|
#s/^([\w-]+)\s*//; # remote first word and stick into $1
|
|
|
|
logmsg(
|
|
3,
|
|
"cluster $line[0] = ",
|
|
join( " ", @line[ 1 .. $#line ] )
|
|
);
|
|
$clusters{ $line[0] } = join( " ", @line[ 1 .. $#line ] )
|
|
; # Now bung in rest of line
|
|
}
|
|
close(CLUSTERS);
|
|
}
|
|
|
|
# Now get any definitions out of %config
|
|
logmsg( 2, "Looking for csshrc" );
|
|
if ( $config{clusters} ) {
|
|
logmsg( 2, "Loading clusters in from csshrc" );
|
|
|
|
foreach ( split( /\s+/, $config{clusters} ) ) {
|
|
if ( !$config{$_} ) {
|
|
warn(
|
|
"WARNING: missing cluster definition in .csshrc file ($_)"
|
|
);
|
|
}
|
|
else {
|
|
logmsg( 3, "cluster $_ = $config{$_}" );
|
|
$clusters{$_} = $config{$_};
|
|
}
|
|
}
|
|
}
|
|
|
|
# and any clusters defined within the config file or on the command line
|
|
if ( $config{extra_cluster_file} || $options{'cluster-file'} ) {
|
|
|
|
# check for multiple entries and push it through glob to catch ~'s
|
|
foreach my $item ( split( /,/, $config{extra_cluster_file} ),
|
|
$options{'cluster-file'} )
|
|
{
|
|
next unless ($item);
|
|
|
|
# cater for people using '$HOME'
|
|
$item =~ s/\$HOME/$ENV{HOME}/;
|
|
foreach my $file ( glob($item) ) {
|
|
if ( !-r $file ) {
|
|
warn("Unable to read cluster file '$file': $!\n");
|
|
next;
|
|
}
|
|
logmsg( 2, "Loading clusters in from '$file'" );
|
|
|
|
open( CLUSTERS, $file ) || die("Couldnt read '$file': $!\n");
|
|
my $l;
|
|
while ( defined( $l = <CLUSTERS> ) ) {
|
|
next if ( $l =~ /^\s*$/ || $l =~ /^#/ );
|
|
chomp $l;
|
|
if ( $l =~ s/\\\s*$// ) {
|
|
$l .= <CLUSTER>;
|
|
redo unless eof(CLUSTERS);
|
|
}
|
|
|
|
my @line = split( /\s/, $l );
|
|
logmsg(
|
|
3,
|
|
"cluster $line[0] = ",
|
|
join( " ", @line[ 1 .. $#line ] )
|
|
);
|
|
$clusters{ $line[0] } = join( " ", @line[ 1 .. $#line ] )
|
|
; # Now bung in rest of line
|
|
}
|
|
}
|
|
|
|
}
|
|
}
|
|
|
|
logmsg( 2, "Finished loading clusters" );
|
|
}
|
|
|
|
sub resolve_names(@) {
|
|
logmsg( 2, 'Resolving cluster names: started' );
|
|
my @servers = @_;
|
|
|
|
foreach (@servers) {
|
|
my $dirty = $_;
|
|
my $username = q{};
|
|
logmsg( 3, 'Checking tag ', $_ );
|
|
|
|
if ( $dirty =~ s/^(.*)@// ) {
|
|
$username = $1;
|
|
}
|
|
if ( $config{use_all_a_records}
|
|
&& $dirty !~ m/^(\d{1,3}\.?){4}$/
|
|
&& !defined( $clusters{$dirty} ) )
|
|
{
|
|
my $hostobj = gethostbyname($dirty);
|
|
if ( defined($hostobj) ) {
|
|
my @alladdrs = map { inet_ntoa($_) } @{ $hostobj->addr_list };
|
|
if ( $#alladdrs > 0 ) {
|
|
$clusters{$dirty} = join ' ', @alladdrs;
|
|
logmsg( 3, 'Expanded to ', $clusters{$dirty} );
|
|
}
|
|
else {
|
|
logmsg( 3, 'Only one A record' );
|
|
}
|
|
}
|
|
}
|
|
if ( $clusters{$dirty} ) {
|
|
logmsg( 3, '... it is a cluster' );
|
|
foreach my $node ( split( / /, $clusters{$dirty} ) ) {
|
|
if ($username) {
|
|
$node =~ s/^(.*)@//;
|
|
$node = $username . '@' . $node;
|
|
}
|
|
push( @servers, $node );
|
|
}
|
|
$_ = q{};
|
|
}
|
|
}
|
|
|
|
# now clean the array up
|
|
@servers = grep { $_ !~ m/^$/ } @servers;
|
|
|
|
logmsg( 3, 'leaving with ', $_ ) foreach (@servers);
|
|
logmsg( 2, 'Resolving cluster names: completed' );
|
|
return (@servers);
|
|
}
|
|
|
|
sub change_main_window_title() {
|
|
my $number = keys(%servers);
|
|
$windows{main_window}->title( $config{title} . " [$number]" );
|
|
}
|
|
|
|
sub show_history() {
|
|
if ( $config{show_history} ) {
|
|
$windows{history}->packForget();
|
|
$config{show_history} = 0;
|
|
}
|
|
else {
|
|
$windows{history}->pack(
|
|
-fill => "x",
|
|
-expand => 1,
|
|
);
|
|
$config{show_history} = 1;
|
|
}
|
|
}
|
|
|
|
sub update_display_text($) {
|
|
my $char = shift;
|
|
|
|
return if ( !$config{show_history} );
|
|
|
|
logmsg( 2, "Dropping :$char: into display" );
|
|
|
|
SWITCH: {
|
|
foreach ($char) {
|
|
/^Return$/ && do {
|
|
$windows{history}->insert( 'end', "\n" );
|
|
last SWITCH;
|
|
};
|
|
|
|
/^BackSpace$/ && do {
|
|
$windows{history}->delete('end - 2 chars');
|
|
last SWITCH;
|
|
};
|
|
|
|
/^(:?Shift|Control|Alt)_(:?R|L)$/ && do {
|
|
last SWITCH;
|
|
};
|
|
|
|
length($char) > 1 && do {
|
|
$windows{history}
|
|
->insert( 'end', chr( $keysymtocode{$char} ) )
|
|
if ( $keysymtocode{$char} );
|
|
last SWITCH;
|
|
};
|
|
|
|
do {
|
|
$windows{history}->insert( 'end', $char );
|
|
last SWITCH;
|
|
};
|
|
}
|
|
}
|
|
}
|
|
|
|
sub send_text($@) {
|
|
my $svr = shift;
|
|
my $text = join( "", @_ );
|
|
|
|
logmsg( 2, "servers{$svr}{wid}=$servers{$svr}{wid}" );
|
|
logmsg( 3, "Sending to '$svr' text:$text:" );
|
|
|
|
# command macro substitution
|
|
|
|
# $svr contains a trailing space here, so ensure its stripped off
|
|
{
|
|
my $servername = $svr;
|
|
$servername =~ s/\s+//;
|
|
$text =~ s/%s/$servername/xsm;
|
|
}
|
|
$text =~ s/%h/hostname()/xsme;
|
|
|
|
# use connection username, else default to current username
|
|
{
|
|
my $username = $servers{$svr}{username};
|
|
$username ||= getpwuid($UID);
|
|
$text =~ s/%u/$username/xsm;
|
|
}
|
|
$text =~ s/%n/\n/xsm;
|
|
|
|
foreach my $char ( split( //, $text ) ) {
|
|
next if ( !defined($char) );
|
|
my $ord = ord($char);
|
|
$ord = 65293 if ( $ord == 10 ); # convert 'Return' to sym
|
|
|
|
if ( !defined( $keycodetosym{$ord} ) ) {
|
|
warn("Unknown character in xmodmap keytable: $char ($ord)\n");
|
|
next;
|
|
}
|
|
my $keysym = $keycodetosym{$ord};
|
|
my $keycode = $keysymtocode{$keysym};
|
|
|
|
logmsg( 2, "Looking for char :$char: with ord :$ord:" );
|
|
logmsg( 2, "Looking for keycode :$keycode:" );
|
|
logmsg( 2, "Looking for keysym :$keysym:" );
|
|
logmsg( 2, "Looking for keyboardmap :", $keyboardmap{$keysym}, ":" );
|
|
my ( $state, $code ) = get_keycode_state($keysym);
|
|
logmsg( 2, "Got state :$state: code :$code:" );
|
|
|
|
for my $event (qw/KeyPress KeyRelease/) {
|
|
logmsg( 2, "sending event=$event code=:$code: state=:$state:" );
|
|
$xdisplay->SendEvent(
|
|
$servers{$svr}{wid},
|
|
0,
|
|
$xdisplay->pack_event_mask($event),
|
|
$xdisplay->pack_event(
|
|
'name' => $event,
|
|
'detail' => $code,
|
|
'state' => $state,
|
|
'time' => time(),
|
|
'event' => $servers{$svr}{wid},
|
|
'root' => $xdisplay->root(),
|
|
'same_screen' => 1,
|
|
),
|
|
);
|
|
}
|
|
}
|
|
$xdisplay->flush();
|
|
}
|
|
|
|
sub send_text_to_all_servers {
|
|
my $text = join( '', @_ );
|
|
|
|
foreach my $svr ( keys(%servers) ) {
|
|
send_text( $svr, $text )
|
|
if ( $servers{$svr}{active} == 1 );
|
|
}
|
|
}
|
|
|
|
sub send_resizemove($$$$$) {
|
|
my ( $win, $x_pos, $y_pos, $x_siz, $y_siz ) = @_;
|
|
|
|
logmsg( 3,
|
|
"Moving window $win to x:$x_pos y:$y_pos (size x:$x_siz y:$y_siz)" );
|
|
|
|
#logmsg( 2, "resize move normal: ", $xdisplay->atom('WM_NORMAL_HINTS') );
|
|
#logmsg( 2, "resize move size: ", $xdisplay->atom('WM_SIZE_HINTS') );
|
|
|
|
# set the window to have "user" set size & position, rather than "program"
|
|
$xdisplay->req(
|
|
'ChangeProperty',
|
|
$win,
|
|
$xdisplay->atom('WM_NORMAL_HINTS'),
|
|
$xdisplay->atom('WM_SIZE_HINTS'),
|
|
32,
|
|
'Replace',
|
|
|
|
# create data struct on fly to set bitwise flags
|
|
pack( 'LLLLL' . 'x[L]' x 12, 1 | 2, $x_pos, $y_pos, $x_siz, $y_siz ),
|
|
);
|
|
|
|
$xdisplay->req(
|
|
'ConfigureWindow',
|
|
$win,
|
|
'x' => $x_pos,
|
|
'y' => $y_pos,
|
|
'width' => $x_siz,
|
|
'height' => $y_siz,
|
|
);
|
|
|
|
#$xdisplay->flush(); # dont flush here, but after all tiling worked out
|
|
}
|
|
|
|
sub setup_helper_script() {
|
|
logmsg( 2, "Setting up helper script" );
|
|
$helper_script = <<" HERE";
|
|
my \$pipe=shift;
|
|
my \$svr=shift;
|
|
my \$user=shift;
|
|
my \$port=shift;
|
|
my \$mstr=shift;
|
|
my \$command="$config{$config{comms}} $config{$config{comms}."_args"} ";
|
|
open(PIPE, ">", \$pipe) or die("Failed to open pipe: \$!\\n");
|
|
print PIPE "\$\$:\$ENV{WINDOWID}"
|
|
or die("Failed to write to pipe: $!\\n");
|
|
close(PIPE) or die("Failed to close pipe: $!\\n");
|
|
if(\$svr =~ m/==\$/)
|
|
{
|
|
\$svr =~ s/==\$//;
|
|
warn("\\nWARNING: failed to resolve IP address for \$svr.\\n\\n"
|
|
);
|
|
sleep 5;
|
|
}
|
|
if(\$mstr) {
|
|
unless("$config{comms}" ne "console") {
|
|
\$mstr = \$mstr ? "-M \$mstr " : "";
|
|
\$command .= \$mstr;
|
|
}
|
|
}
|
|
if(\$user) {
|
|
unless("$config{comms}" eq "telnet") {
|
|
\$user = \$user ? "-l \$user " : "";
|
|
\$command .= \$user;
|
|
}
|
|
}
|
|
if("$config{comms}" eq "telnet") {
|
|
\$command .= "\$svr \$port";
|
|
} else {
|
|
if (\$port) {
|
|
\$command .= "-p \$port \$svr";
|
|
} else {
|
|
\$command .= "\$svr";
|
|
}
|
|
}
|
|
\$command .= " $config{command} || sleep 5";
|
|
# warn("Running:\$command\\n"); # for debug purposes
|
|
exec(\$command);
|
|
HERE
|
|
|
|
# eval $helper_script || die ($@); # for debug purposes
|
|
logmsg( 2, $helper_script );
|
|
logmsg( 2, "Helper script done" );
|
|
}
|
|
|
|
sub open_client_windows(@) {
|
|
foreach (@_) {
|
|
next unless ($_);
|
|
|
|
my $server_object = App::ClusterSSH::Host->parse_host_string($_);
|
|
|
|
my $username = $server_object->get_username();
|
|
$username = $config{user} if ( $config{user} );
|
|
my $port = $server_object->get_port();
|
|
$port = $config{port} if ( $config{port} );
|
|
my $server = $server_object->get_hostname();
|
|
my $master = $server_object->get_master();
|
|
|
|
my $given_server_name = $server_object->get_givenname();
|
|
|
|
# see if we can find the hostname - if not, drop it
|
|
my $realname = $server_object->get_realname();
|
|
if ( !$realname ) {
|
|
my $text = "WARNING: '$_' unknown";
|
|
|
|
if (%ssh_hostnames) {
|
|
$text
|
|
.= " (unable to resolve and not in user ssh config file)";
|
|
}
|
|
|
|
warn( $text, $/ );
|
|
|
|
#next; # Debian bug 499935 - ignore warnings about hostname resolution
|
|
}
|
|
|
|
logmsg( 3, "username=$username, server=$server, port=$port" );
|
|
|
|
my $color = '';
|
|
if ( $config{terminal_colorize} ) {
|
|
my $c = pick_color($server);
|
|
if ( $config{terminal_bg_style} eq 'dark' ) {
|
|
$color = "-bg \\#000000 -fg $c";
|
|
}
|
|
else {
|
|
$color = "-fg \\#000000 -bg $c";
|
|
}
|
|
}
|
|
|
|
my $count = q{};
|
|
while ( defined( $servers{ $server . q{ } . $count } ) ) {
|
|
$count++;
|
|
}
|
|
$server .= q{ } . $count;
|
|
|
|
$servers{$server}{connect_string} = $_;
|
|
$servers{$server}{givenname} = $given_server_name;
|
|
$servers{$server}{realname} = $realname;
|
|
$servers{$server}{username} = $config{user};
|
|
$servers{$server}{username} = $username if ($username);
|
|
$servers{$server}{username} = $username || '';
|
|
$servers{$server}{port} = $port || '';
|
|
$servers{$server}{master} = $config{mstr} || '';;
|
|
$servers{$server}{master} = $master if ($master);
|
|
|
|
logmsg( 2, "Working on server $server for $_" );
|
|
|
|
$servers{$server}{pipenm} = tmpnam();
|
|
|
|
logmsg( 2, "Set temp name to: $servers{$server}{pipenm}" );
|
|
mkfifo( $servers{$server}{pipenm}, 0600 )
|
|
or die("Cannot create pipe: $!");
|
|
|
|
# NOTE: the pid is re-fetched from the xterm window (via helper_script)
|
|
# later as it changes and we need an accurate PID as it is widely used
|
|
$servers{$server}{pid} = fork();
|
|
if ( !defined( $servers{$server}{pid} ) ) {
|
|
die("Could not fork: $!");
|
|
}
|
|
|
|
if ( $servers{$server}{pid} == 0 ) {
|
|
|
|
# this is the child
|
|
# Since this is the child, we can mark any server unresolved without
|
|
# affecting the main program
|
|
$servers{$server}{realname} .= "==" if ( !$realname );
|
|
my $exec
|
|
= "$config{terminal} $color $config{terminal_args} $config{terminal_allow_send_events} $config{terminal_title_opt} '$config{title}: $servers{$server}{connect_string}' -font $config{terminal_font} -e \"$^X\" \"-e\" '$helper_script' '$servers{$server}{pipenm}' '$servers{$server}{givenname}' '$servers{$server}{username}' '$servers{$server}{port}' '$servers{$server}{master}'";
|
|
logmsg( 2, "Terminal exec line:\n$exec\n" );
|
|
exec($exec) == 0 or warn("Failed: $!");
|
|
}
|
|
}
|
|
|
|
# Now all the windows are open, get all their window id's
|
|
foreach my $server ( keys(%servers) ) {
|
|
next if ( defined( $servers{$server}{active} ) );
|
|
|
|
# sleep for a moment to give system time to come up
|
|
select( undef, undef, undef, 0.1 );
|
|
|
|
# block on open so we get the text when it comes in
|
|
unless (
|
|
sysopen(
|
|
$servers{$server}{pipehl}, $servers{$server}{pipenm},
|
|
O_RDONLY
|
|
)
|
|
)
|
|
{
|
|
warn(
|
|
"Cannot open pipe for reading when talking to $server: $!\n");
|
|
}
|
|
else {
|
|
|
|
# NOTE: read both the xterm pid and the window ID here
|
|
# get PID here as it changes from the fork above, and we need the
|
|
# correct PID
|
|
logmsg( 2, "Performing sysread" );
|
|
my $piperead;
|
|
sysread( $servers{$server}{pipehl}, $piperead, 100 );
|
|
( $servers{$server}{pid}, $servers{$server}{wid} )
|
|
= split( /:/, $piperead, 2 );
|
|
warn("Cannot determ pid of '$server' window\n")
|
|
unless $servers{$server}{pid};
|
|
warn("Cannot determ window ID of '$server' window\n")
|
|
unless $servers{$server}{wid};
|
|
logmsg( 2, "Done and closing pipe" );
|
|
|
|
close( $servers{$server}{pipehl} );
|
|
}
|
|
delete( $servers{$server}{pipehl} );
|
|
|
|
unlink( $servers{$server}{pipenm} );
|
|
delete( $servers{$server}{pipenm} );
|
|
|
|
$servers{$server}{active} = 1; # mark as active
|
|
$config{internal_activate_autoquit}
|
|
= 1; # activate auto_quit if in use
|
|
}
|
|
logmsg( 2, "All client windows opened" );
|
|
$config{internal_total} = int( keys(%servers) );
|
|
}
|
|
|
|
sub get_font_size() {
|
|
logmsg( 2, "Fetching font size" );
|
|
|
|
# get atom name<->number relations
|
|
my $quad_width = $xdisplay->atom("QUAD_WIDTH");
|
|
my $pixel_size = $xdisplay->atom("PIXEL_SIZE");
|
|
|
|
my $font = $xdisplay->new_rsrc;
|
|
$xdisplay->OpenFont( $font, $config{terminal_font} );
|
|
|
|
my %font_info;
|
|
|
|
eval { (%font_info) = $xdisplay->QueryFont($font); }
|
|
|| die( "Fatal: Unrecognised font used ($config{terminal_font}).\n"
|
|
. "Please amend \$HOME/.csshrc with a valid font (see man page).\n"
|
|
);
|
|
|
|
$config{internal_font_width} = $font_info{properties}{$quad_width};
|
|
$config{internal_font_height} = $font_info{properties}{$pixel_size};
|
|
|
|
if ( !$config{internal_font_width} || !$config{internal_font_height} ) {
|
|
die( "Fatal: Unrecognised font used ($config{terminal_font}).\n"
|
|
. "Please amend \$HOME/.csshrc with a valid font (see man page).\n"
|
|
);
|
|
}
|
|
|
|
logmsg( 2, "Done with font size" );
|
|
}
|
|
|
|
sub show_console() {
|
|
logmsg( 2, "Sending console to front" );
|
|
|
|
$config{internal_previous_state} = "mid-change";
|
|
|
|
# fudge the counter to drop a redraw event;
|
|
$config{internal_map_count} -= 4;
|
|
|
|
$xdisplay->flush();
|
|
$windows{main_window}->update();
|
|
|
|
select( undef, undef, undef, 0.2 ); #sleep for a mo
|
|
$windows{main_window}->withdraw;
|
|
|
|
# Sleep for a moment to give WM time to bring console back
|
|
select( undef, undef, undef, 0.5 );
|
|
|
|
if ( $config{menu_send_autotearoff} ) {
|
|
$menus{send}->menu->tearOffMenu()->raise;
|
|
}
|
|
|
|
if ( $config{menu_host_autotearoff} ) {
|
|
$menus{hosts}->menu->tearOffMenu()->raise;
|
|
}
|
|
|
|
$windows{main_window}->deiconify;
|
|
$windows{main_window}->raise;
|
|
$windows{main_window}->focus( -force );
|
|
$windows{text_entry}->focus( -force );
|
|
|
|
$config{internal_previous_state} = "normal";
|
|
|
|
# fvwm seems to need this (Debian #329440)
|
|
$windows{main_window}->MapWindow;
|
|
}
|
|
|
|
# leave function def open here so we can be flexible in how it called
|
|
sub retile_hosts {
|
|
my $force = shift || "";
|
|
logmsg( 2, "Retiling windows" );
|
|
|
|
if ( $config{window_tiling} ne "yes" && !$force ) {
|
|
logmsg( 3,
|
|
"Not meant to be tiling; just reshow windows as they were" );
|
|
|
|
foreach my $server ( reverse( keys(%servers) ) ) {
|
|
$xdisplay->req( 'MapWindow', $servers{$server}{wid} );
|
|
}
|
|
$xdisplay->flush();
|
|
show_console();
|
|
return;
|
|
}
|
|
|
|
# ALL SIZES SHOULD BE IN PIXELS for consistency
|
|
|
|
logmsg( 2, "Count is currently $config{internal_total}" );
|
|
|
|
if ( $config{internal_total} == 0 ) {
|
|
|
|
# If nothing to tile, done bother doing anything, just show console
|
|
show_console();
|
|
return;
|
|
}
|
|
|
|
# work out terminal pixel size from terminal size & font size
|
|
# does not include any title bars or scroll bars - purely text area
|
|
$config{internal_terminal_cols}
|
|
= ( $config{terminal_size} =~ /(\d+)x.*/ )[0];
|
|
$config{internal_terminal_width}
|
|
= ( $config{internal_terminal_cols} * $config{internal_font_width} )
|
|
+ $config{terminal_decoration_width};
|
|
|
|
$config{internal_terminal_rows}
|
|
= ( $config{terminal_size} =~ /.*x(\d+)/ )[0];
|
|
$config{internal_terminal_height}
|
|
= ( $config{internal_terminal_rows} * $config{internal_font_height} )
|
|
+ $config{terminal_decoration_height};
|
|
|
|
# fetch screen size
|
|
$config{internal_screen_height} = $xdisplay->{height_in_pixels};
|
|
$config{internal_screen_width} = $xdisplay->{width_in_pixels};
|
|
|
|
# Now, work out how many columns of terminals we can fit on screen
|
|
$config{internal_columns} = int(
|
|
( $config{internal_screen_width}
|
|
- $config{screen_reserve_left}
|
|
- $config{screen_reserve_right}
|
|
) / (
|
|
$config{internal_terminal_width}
|
|
+ $config{terminal_reserve_left}
|
|
+ $config{terminal_reserve_right}
|
|
)
|
|
);
|
|
|
|
# Work out the number of rows we need to use to fit everything on screen
|
|
$config{internal_rows} = int(
|
|
( $config{internal_total} / $config{internal_columns} ) + 0.999 );
|
|
|
|
logmsg( 2, "Screen Columns: ", $config{internal_columns} );
|
|
logmsg( 2, "Screen Rows: ", $config{internal_rows} );
|
|
|
|
# Now adjust the height of the terminal to either the max given,
|
|
# or to get everything on screen
|
|
{
|
|
my $height = int(
|
|
( ( $config{internal_screen_height}
|
|
- $config{screen_reserve_top}
|
|
- $config{screen_reserve_bottom}
|
|
) - (
|
|
$config{internal_rows} * (
|
|
$config{terminal_reserve_top}
|
|
+ $config{terminal_reserve_bottom}
|
|
)
|
|
)
|
|
) / $config{internal_rows}
|
|
);
|
|
|
|
logmsg( 2, "Terminal height=$height" );
|
|
|
|
$config{internal_terminal_height} = (
|
|
$height > $config{internal_terminal_height}
|
|
? $config{internal_terminal_height}
|
|
: $height
|
|
);
|
|
}
|
|
|
|
dump_config("noexit") if ( $options{debug} > 1 );
|
|
|
|
# now we have the info, plot first window position
|
|
my @hosts;
|
|
my ( $current_x, $current_y, $current_row, $current_col ) = 0;
|
|
if ( $config{window_tiling_direction} =~ /right/i ) {
|
|
logmsg( 2, "Tiling top left going bot right" );
|
|
@hosts = sort( keys(%servers) );
|
|
$current_x
|
|
= $config{screen_reserve_left} + $config{terminal_reserve_left};
|
|
$current_y
|
|
= $config{screen_reserve_top} + $config{terminal_reserve_top};
|
|
$current_row = 0;
|
|
$current_col = 0;
|
|
}
|
|
else {
|
|
logmsg( 2, "Tiling bot right going top left" );
|
|
@hosts = reverse( sort( keys(%servers) ) );
|
|
$current_x
|
|
= $config{screen_reserve_right}
|
|
- $config{internal_screen_width}
|
|
- $config{terminal_reserve_right}
|
|
- $config{internal_terminal_width};
|
|
$current_y
|
|
= $config{screen_reserve_bottom}
|
|
- $config{internal_screen_height}
|
|
- $config{terminal_reserve_bottom}
|
|
- $config{internal_terminal_height};
|
|
|
|
$current_row = $config{internal_rows} - 1;
|
|
$current_col = $config{internal_columns} - 1;
|
|
}
|
|
|
|
# Unmap windows (hide them)
|
|
# Move windows to new locatation
|
|
# Remap all windows in correct order
|
|
foreach my $server (@hosts) {
|
|
logmsg( 3,
|
|
"x:$current_x y:$current_y, r:$current_row c:$current_col" );
|
|
|
|
# sf tracker 3061999
|
|
# $xdisplay->req( 'UnmapWindow', $servers{$server}{wid} );
|
|
|
|
if ( $config{unmap_on_redraw} =~ /yes/i ) {
|
|
$xdisplay->req( 'UnmapWindow', $servers{$server}{wid} );
|
|
}
|
|
|
|
logmsg( 2, "Moving $server window" );
|
|
send_resizemove(
|
|
$servers{$server}{wid},
|
|
$current_x, $current_y,
|
|
$config{internal_terminal_width},
|
|
$config{internal_terminal_height}
|
|
);
|
|
|
|
$xdisplay->flush();
|
|
select( undef, undef, undef, 0.1 ); # sleep for a moment for the WM
|
|
|
|
if ( $config{window_tiling_direction} =~ /right/i ) {
|
|
|
|
# starting top left, and move right and down
|
|
$current_x
|
|
+= $config{terminal_reserve_left}
|
|
+ $config{terminal_reserve_right}
|
|
+ $config{internal_terminal_width};
|
|
|
|
$current_col += 1;
|
|
if ( $current_col == $config{internal_columns} ) {
|
|
$current_y
|
|
+= $config{terminal_reserve_top}
|
|
+ $config{terminal_reserve_bottom}
|
|
+ $config{internal_terminal_height};
|
|
$current_x = $config{screen_reserve_left}
|
|
+ $config{terminal_reserve_left};
|
|
$current_row++;
|
|
$current_col = 0;
|
|
}
|
|
}
|
|
else {
|
|
|
|
# starting bottom right, and move left and up
|
|
|
|
$current_col -= 1;
|
|
if ( $current_col < 0 ) {
|
|
$current_row--;
|
|
$current_col = $config{internal_columns};
|
|
}
|
|
}
|
|
}
|
|
|
|
# Now remap in right order to get overlaps correct
|
|
if ( $config{window_tiling_direction} =~ /right/i ) {
|
|
foreach my $server ( reverse(@hosts) ) {
|
|
logmsg( 2, "Setting focus on $server" );
|
|
$xdisplay->req( 'MapWindow', $servers{$server}{wid} );
|
|
|
|
# flush every time and wait a moment (The WMs are so slow...)
|
|
$xdisplay->flush();
|
|
select( undef, undef, undef, 0.1 ); # sleep for a mo
|
|
}
|
|
}
|
|
else {
|
|
foreach my $server (@hosts) {
|
|
logmsg( 2, "Setting focus on $server" );
|
|
$xdisplay->req( 'MapWindow', $servers{$server}{wid} );
|
|
|
|
# flush every time and wait a moment (The WMs are so slow...)
|
|
$xdisplay->flush();
|
|
select( undef, undef, undef, 0.1 ); # sleep for a mo
|
|
}
|
|
}
|
|
|
|
# and as a last item, set focus back onto the console
|
|
show_console();
|
|
}
|
|
|
|
sub capture_terminal() {
|
|
logmsg( 0, "Stub for capturing a terminal window" );
|
|
|
|
return if ( $options{debug} < 6 );
|
|
|
|
# should never see this - all experimental anyhow
|
|
|
|
foreach my $server ( keys(%servers) ) {
|
|
foreach my $data ( keys( %{ $servers{$server} } ) ) {
|
|
print "server $server key $data is $servers{$server}{$data}\n";
|
|
}
|
|
}
|
|
|
|
#return;
|
|
|
|
my %atoms;
|
|
|
|
for my $atom ( $xdisplay->req( 'ListProperties', $servers{loki}{wid} ) ) {
|
|
$atoms{ $xdisplay->atom_name($atom) }
|
|
= $xdisplay->req( 'GetProperty', $servers{loki}{wid},
|
|
$atom, "AnyPropertyType", 0, 200, 0 );
|
|
|
|
print $xdisplay->atom_name($atom), " ($atom) => ";
|
|
print "join here\n";
|
|
print join(
|
|
"\n",
|
|
$xdisplay->req(
|
|
'GetProperty', $servers{loki}{wid},
|
|
$atom, "AnyPropertyType", 0, 200, 0
|
|
)
|
|
),
|
|
"\n";
|
|
}
|
|
|
|
print "list by number\n";
|
|
for my $atom ( 1 .. 90 ) {
|
|
print "$atom: ", $xdisplay->req( 'GetAtomName', $atom ), "\n";
|
|
print join(
|
|
"\n",
|
|
$xdisplay->req(
|
|
'GetProperty', $servers{loki}{wid},
|
|
$atom, "AnyPropertyType", 0, 200, 0
|
|
)
|
|
),
|
|
"\n";
|
|
}
|
|
print "\n";
|
|
|
|
print "size hints\n";
|
|
print join(
|
|
"\n",
|
|
$xdisplay->req(
|
|
'GetProperty', $servers{loki}{wid},
|
|
42, "AnyPropertyType", 0, 200, 0
|
|
)
|
|
),
|
|
"\n";
|
|
|
|
print "atom list by name\n";
|
|
foreach ( keys(%atoms) ) {
|
|
print "atom :$_: = $atoms{$_}\n";
|
|
}
|
|
|
|
print "geom\n";
|
|
print join " ", $xdisplay->req( 'GetGeometry', $servers{loki}{wid} ), $/;
|
|
print "attrib\n";
|
|
print join " ",
|
|
$xdisplay->req( 'GetWindowAttributes', $servers{loki}{wid} ),
|
|
$/;
|
|
}
|
|
|
|
sub toggle_active_state() {
|
|
logmsg( 2, "Toggling active state of all hosts" );
|
|
|
|
foreach my $svr ( sort( keys(%servers) ) ) {
|
|
$servers{$svr}{active} = not $servers{$svr}{active};
|
|
}
|
|
}
|
|
|
|
sub close_inactive_sessions() {
|
|
logmsg( 2, "Closing all inactive sessions" );
|
|
|
|
foreach my $svr ( sort( keys(%servers) ) ) {
|
|
terminate_host($svr) if ( !$servers{$svr}{active} );
|
|
}
|
|
build_hosts_menu();
|
|
}
|
|
|
|
sub add_host_by_name() {
|
|
logmsg( 2, "Adding host to menu here" );
|
|
|
|
$windows{host_entry}->focus();
|
|
my $answer = $windows{addhost}->Show();
|
|
|
|
if ( $answer ne "Add" ) {
|
|
$menus{host_entry} = "";
|
|
return;
|
|
}
|
|
|
|
if ( $menus{host_entry} ) {
|
|
logmsg( 2, "host=", $menus{host_entry} );
|
|
open_client_windows(
|
|
resolve_names( split( /\s+/, $menus{host_entry} ) ) );
|
|
}
|
|
|
|
if ( $menus{listbox}->curselection() ) {
|
|
my @hosts = $menus{listbox}->get( $menus{listbox}->curselection() );
|
|
logmsg( 2, "host=", join( ' ', @hosts ) );
|
|
open_client_windows( resolve_names(@hosts) );
|
|
}
|
|
|
|
build_hosts_menu();
|
|
$menus{host_entry} = "";
|
|
|
|
# retile, or bring console to front
|
|
if ( $config{window_tiling} eq "yes" ) {
|
|
retile_hosts();
|
|
}
|
|
else {
|
|
show_console();
|
|
}
|
|
}
|
|
|
|
sub build_hosts_menu() {
|
|
logmsg( 2, "Building hosts menu" );
|
|
|
|
# first, empty the hosts menu from the 4th entry on
|
|
my $menu = $menus{bar}->entrycget( 'Hosts', -menu );
|
|
my $host_menu_static_items = 5;
|
|
$menu->delete( $host_menu_static_items, 'end' );
|
|
|
|
logmsg( 3, "Menu deleted" );
|
|
|
|
# add back the seperator
|
|
$menus{hosts}->separator;
|
|
|
|
logmsg( 3, "Parsing list" );
|
|
|
|
my $menu_item_counter = $host_menu_static_items;
|
|
foreach my $svr ( sort( keys(%servers) ) ) {
|
|
logmsg( 3, "Checking $svr and restoring active value" );
|
|
my $colbreak = 0;
|
|
if ( $menu_item_counter > $config{max_host_menu_items} ) {
|
|
$colbreak = 1;
|
|
$menu_item_counter = 1;
|
|
}
|
|
$menus{hosts}->checkbutton(
|
|
-label => $svr,
|
|
-variable => \$servers{$svr}{active},
|
|
-columnbreak => $colbreak,
|
|
);
|
|
$menu_item_counter++;
|
|
}
|
|
logmsg( 3, "Changing window title" );
|
|
change_main_window_title();
|
|
logmsg( 2, "Done" );
|
|
}
|
|
|
|
sub setup_repeat() {
|
|
$config{internal_count} = 0;
|
|
|
|
# if this is too fast then we end up with queued invocations
|
|
# with no time to run anything else
|
|
$windows{main_window}->repeat(
|
|
500,
|
|
sub {
|
|
$config{internal_count} = 0
|
|
if ( $config{internal_count} > 60000 ); # reset if too high
|
|
$config{internal_count}++;
|
|
my $build_menu = 0;
|
|
logmsg( 5, "Running repeat (count=$config{internal_count})" );
|
|
|
|
#logmsg( 3, "Number of servers in hash is: ", scalar( keys(%servers) ) );
|
|
|
|
foreach my $svr ( keys(%servers) ) {
|
|
if ( defined( $servers{$svr}{pid} ) ) {
|
|
if ( !kill( 0, $servers{$svr}{pid} ) ) {
|
|
$build_menu = 1;
|
|
delete( $servers{$svr} );
|
|
logmsg( 0, "$svr session closed" );
|
|
}
|
|
}
|
|
else {
|
|
warn("Lost pid of $svr; deleting\n");
|
|
delete( $servers{$svr} );
|
|
}
|
|
}
|
|
|
|
# get current number of clients
|
|
$config{internal_total} = int( keys(%servers) );
|
|
|
|
#logmsg( 3, "Number after tidy is: ", $config{internal_total} );
|
|
|
|
# get current number of clients
|
|
$config{internal_total} = int( keys(%servers) );
|
|
|
|
#logmsg( 3, "Number after tidy is: ", $config{internal_total} );
|
|
|
|
# If there are no hosts in the list and we are set to autoquit
|
|
if ( $config{internal_total} == 0
|
|
&& $config{auto_quit} =~ /yes/i )
|
|
{
|
|
|
|
# and some clients were actually opened...
|
|
if ( $config{internal_activate_autoquit} ) {
|
|
logmsg( 2, "Autoquitting" );
|
|
exit_prog;
|
|
}
|
|
}
|
|
|
|
# rebuild host menu if something has changed
|
|
build_hosts_menu() if ($build_menu);
|
|
|
|
# clean out text area, anyhow
|
|
$menus{entrytext} = "";
|
|
|
|
#logmsg( 3, "repeat completed" );
|
|
}
|
|
);
|
|
logmsg( 2, "Repeat setup" );
|
|
}
|
|
|
|
sub write_default_user_config() {
|
|
return if ( !$ENV{HOME} || -e "$ENV{HOME}/.csshrc" );
|
|
|
|
if ( open( CONFIG, ">", "$ENV{HOME}/.csshrc" ) ) {
|
|
foreach ( sort( keys(%config) ) ) {
|
|
|
|
# do not output internal vars
|
|
next if ( $_ =~ /^internal/ );
|
|
print CONFIG "$_=$config{$_}\n";
|
|
}
|
|
close(CONFIG);
|
|
}
|
|
else {
|
|
logmsg( 1, "Unable to write default $ENV{HOME}/.csshrc file" );
|
|
}
|
|
}
|
|
|
|
### Window and menu definitions ###
|
|
|
|
sub create_windows() {
|
|
logmsg( 2, "create_windows: started" );
|
|
$windows{main_window} = MainWindow->new( -title => "ClusterSSH" );
|
|
$windows{main_window}->withdraw; # leave withdrawn until needed
|
|
|
|
if ( defined( $config{console_position} )
|
|
&& $config{console_position} =~ /[+-]\d+[+-]\d+/ )
|
|
{
|
|
$windows{main_window}->geometry( $config{console_position} );
|
|
}
|
|
|
|
$menus{entrytext} = "";
|
|
$windows{text_entry} = $windows{main_window}->Entry(
|
|
-textvariable => \$menus{entrytext},
|
|
-insertborderwidth => 4,
|
|
-width => 25,
|
|
)->pack(
|
|
-fill => "x",
|
|
-expand => 1,
|
|
);
|
|
|
|
$windows{history} = $windows{main_window}->Scrolled(
|
|
"ROText",
|
|
-insertborderwidth => 4,
|
|
-width => $config{history_width},
|
|
-height => $config{history_height},
|
|
-state => 'normal',
|
|
-takefocus => 0,
|
|
);
|
|
$windows{history}->bindtags(undef);
|
|
|
|
if ( $config{show_history} ) {
|
|
$windows{history}->pack(
|
|
-fill => "x",
|
|
-expand => 1,
|
|
);
|
|
}
|
|
|
|
$windows{main_window}->bind( '<Destroy>' => \&exit_prog );
|
|
|
|
# remove all Paste events so we set them up cleanly
|
|
$windows{main_window}->eventDelete('<<Paste>>');
|
|
|
|
# Set up paste events from scratch
|
|
if ( $config{key_paste} && $config{key_paste} ne "null" ) {
|
|
$windows{main_window}
|
|
->eventAdd( '<<Paste>>' => '<' . $config{key_paste} . '>' );
|
|
}
|
|
|
|
if ( $config{mouse_paste} && $config{mouse_paste} ne "null" ) {
|
|
$windows{main_window}
|
|
->eventAdd( '<<Paste>>' => '<' . $config{mouse_paste} . '>' );
|
|
}
|
|
|
|
$windows{main_window}->bind(
|
|
'<<Paste>>' => sub {
|
|
logmsg( 2, "PASTE EVENT" );
|
|
|
|
$menus{entrytext} = "";
|
|
my $paste_text = '';
|
|
|
|
# SelectionGet is fatal if no selection is given
|
|
Tk::catch {
|
|
$paste_text = $windows{main_window}->SelectionGet;
|
|
};
|
|
|
|
if ( !length($paste_text) ) {
|
|
warn("Got empty paste event\n");
|
|
return;
|
|
}
|
|
|
|
logmsg( 2, "Got text :", $paste_text, ":" );
|
|
|
|
update_display_text($paste_text);
|
|
|
|
# now sent it on
|
|
foreach my $svr ( keys(%servers) ) {
|
|
send_text( $svr, $paste_text )
|
|
if ( $servers{$svr}{active} == 1 );
|
|
}
|
|
}
|
|
);
|
|
|
|
$windows{help} = $windows{main_window}->Dialog(
|
|
-popover => $windows{main_window},
|
|
-overanchor => "c",
|
|
-popanchor => "c",
|
|
-font => [
|
|
-family => "interface system",
|
|
-size => 10,
|
|
],
|
|
-text =>
|
|
"Cluster Administrator Console using SSH\n\nVersion: $VERSION.\n\n"
|
|
. "Bug/Suggestions to http://clusterssh.sf.net/",
|
|
);
|
|
|
|
$windows{manpage} = $windows{main_window}->DialogBox(
|
|
-popanchor => "c",
|
|
-overanchor => "c",
|
|
-title => "Cssh Documentation",
|
|
-buttons => ['Close'],
|
|
);
|
|
|
|
my $manpage = `pod2text -l -q=\"\" $0 2>/dev/null`;
|
|
if(!$manpage) {
|
|
$manpage = "Help is missing.\nSee that command 'pod2text' is installed and in PATH.";
|
|
}
|
|
$windows{mantext}
|
|
= $windows{manpage}->Scrolled( "Text", )->pack( -fill => 'both' );
|
|
$windows{mantext}->insert( 'end', $manpage );
|
|
$windows{mantext}->configure( -state => 'disabled' );
|
|
|
|
$windows{addhost} = $windows{main_window}->DialogBox(
|
|
-popover => $windows{main_window},
|
|
-popanchor => 'n',
|
|
-title => "Add Host(s) or Cluster(s)",
|
|
-buttons => [ 'Add', 'Cancel' ],
|
|
-default_button => 'Add',
|
|
);
|
|
|
|
if ( $config{max_addhost_menu_cluster_items}
|
|
&& scalar keys %clusters )
|
|
{
|
|
if ( scalar keys %clusters < $config{max_addhost_menu_cluster_items} )
|
|
{
|
|
$menus{listbox} = $windows{addhost}->Listbox(
|
|
-selectmode => 'extended',
|
|
-height => scalar keys %clusters,
|
|
)->pack();
|
|
}
|
|
else {
|
|
$menus{listbox} = $windows{addhost}->Scrolled(
|
|
'Listbox',
|
|
-scrollbars => 'e',
|
|
-selectmode => 'extended',
|
|
-height => $config{max_addhost_menu_cluster_items},
|
|
)->pack();
|
|
}
|
|
$menus{listbox}->insert( 'end', sort keys %clusters );
|
|
}
|
|
|
|
$windows{host_entry} = $windows{addhost}->add(
|
|
'LabEntry',
|
|
-textvariable => \$menus{host_entry},
|
|
-width => 20,
|
|
-label => 'Host',
|
|
-labelPack => [ -side => 'left', ],
|
|
)->pack( -side => 'left' );
|
|
logmsg( 2, "create_windows: completed" );
|
|
}
|
|
|
|
sub capture_map_events() {
|
|
|
|
# pick up on console minimise/maximise events so we can do all windows
|
|
$windows{main_window}->bind(
|
|
'<Map>' => sub {
|
|
logmsg( 3, "Entering MAP" );
|
|
|
|
my $state = $windows{main_window}->state();
|
|
logmsg( 3,
|
|
"state=$state previous=$config{internal_previous_state}" );
|
|
logmsg( 3, "Entering MAP" );
|
|
|
|
if ( $config{internal_previous_state} eq $state ) {
|
|
logmsg( 3, "repeating the same" );
|
|
}
|
|
|
|
if ( $config{internal_previous_state} eq "mid-change" ) {
|
|
logmsg( 3, "dropping out as mid-change" );
|
|
return;
|
|
}
|
|
|
|
logmsg( 3,
|
|
"state=$state previous=$config{internal_previous_state}" );
|
|
|
|
if ( $config{internal_previous_state} eq "iconic" ) {
|
|
logmsg( 3, "running retile" );
|
|
|
|
retile_hosts();
|
|
|
|
logmsg( 3, "done with retile" );
|
|
}
|
|
|
|
if ( $config{internal_previous_state} ne $state ) {
|
|
logmsg( 3, "resetting prev_state" );
|
|
$config{internal_previous_state} = $state;
|
|
}
|
|
}
|
|
);
|
|
|
|
# $windows{main_window}->bind(
|
|
# '<Unmap>' => sub {
|
|
# logmsg( 3, "Entering UNMAP" );
|
|
#
|
|
# my $state = $windows{main_window}->state();
|
|
# logmsg( 3,
|
|
# "state=$state previous=$config{internal_previous_state}" );
|
|
#
|
|
# if ( $config{internal_previous_state} eq $state ) {
|
|
# logmsg( 3, "repeating the same" );
|
|
# }
|
|
#
|
|
# if ( $config{internal_previous_state} eq "mid-change" ) {
|
|
# logmsg( 3, "dropping out as mid-change" );
|
|
# return;
|
|
# }
|
|
#
|
|
# if ( $config{internal_previous_state} eq "normal" ) {
|
|
# logmsg( 3, "withdrawing all windows" );
|
|
# foreach my $server ( reverse( keys(%servers) ) ) {
|
|
# $xdisplay->req( 'UnmapWindow', $servers{$server}{wid} );
|
|
# if ( $config{unmap_on_redraw} =~ /yes/i ) {
|
|
# $xdisplay->req( 'UnmapWindow',
|
|
# $servers{$server}{wid} );
|
|
# }
|
|
# }
|
|
# $xdisplay->flush();
|
|
# }
|
|
#
|
|
# if ( $config{internal_previous_state} ne $state ) {
|
|
# logmsg( 3, "resetting prev_state" );
|
|
# $config{internal_previous_state} = $state;
|
|
# }
|
|
# }
|
|
# );
|
|
}
|
|
|
|
# for all key event, event hotkeys so there is only 1 key binding
|
|
sub key_event {
|
|
my $event = $Tk::event->T;
|
|
my $keycode = $Tk::event->k;
|
|
my $keysymdec = $Tk::event->N;
|
|
my $keysym = $Tk::event->K;
|
|
my $state = $Tk::event->s || 0;
|
|
|
|
$menus{entrytext} = "";
|
|
|
|
logmsg( 3, "=========" );
|
|
logmsg( 3, "event =$event" );
|
|
logmsg( 3, "keysym =$keysym (state=$state)" );
|
|
logmsg( 3, "keysymdec=$keysymdec" );
|
|
logmsg( 3, "keycode =$keycode" );
|
|
logmsg( 3, "state =$state" );
|
|
logmsg( 3, "codetosym=$keycodetosym{$keysymdec}" )
|
|
if ( $keycodetosym{$keysymdec} );
|
|
logmsg( 3, "symtocode=$keysymtocode{$keysym}" );
|
|
logmsg( 3, "keyboard =$keyboardmap{ $keysym }" )
|
|
if ( $keyboardmap{$keysym} );
|
|
|
|
#warn("debug stop point here");
|
|
if ( $config{use_hotkeys} eq "yes" ) {
|
|
my $combo = $Tk::event->s . $Tk::event->K;
|
|
|
|
$combo =~ s/Mod\d-//;
|
|
|
|
logmsg( 3, "combo=$combo" );
|
|
|
|
foreach my $hotkey ( grep( /key_/, keys(%config) ) ) {
|
|
my $key = $config{$hotkey};
|
|
next if ( $key eq "null" ); # ignore disabled keys
|
|
|
|
logmsg( 3, "key=:$key:" );
|
|
if ( $combo =~ /^$key$/ ) {
|
|
if ( $event eq "KeyRelease" ) {
|
|
logmsg( 2, "Received hotkey: $hotkey" );
|
|
send_text_to_all_servers('%s')
|
|
if ( $hotkey eq "key_clientname" );
|
|
add_host_by_name()
|
|
if ( $hotkey eq "key_addhost" );
|
|
retile_hosts("force")
|
|
if ( $hotkey eq "key_retilehosts" );
|
|
show_history() if ( $hotkey eq "key_history" );
|
|
exit_prog() if ( $hotkey eq "key_quit" );
|
|
}
|
|
return;
|
|
}
|
|
}
|
|
}
|
|
|
|
# look for a <Control>-d and no hosts, so quit
|
|
exit_prog()
|
|
if ( $state =~ /Control/ && $keysym eq "d" and !%servers );
|
|
|
|
update_display_text( $keycodetosym{$keysymdec} )
|
|
if ( $event eq "KeyPress" && $keycodetosym{$keysymdec} );
|
|
|
|
# for all servers
|
|
foreach ( keys(%servers) ) {
|
|
|
|
# if active
|
|
if ( $servers{$_}{active} == 1 ) {
|
|
logmsg( 3,
|
|
"Sending event $event with code $keycode (state=$state) to window $servers{$_}{wid}"
|
|
);
|
|
|
|
$xdisplay->SendEvent(
|
|
$servers{$_}{wid},
|
|
0,
|
|
$xdisplay->pack_event_mask($event),
|
|
$xdisplay->pack_event(
|
|
'name' => $event,
|
|
'detail' => $keycode,
|
|
'state' => $state,
|
|
'time' => time(),
|
|
'event' => $servers{$_}{wid},
|
|
'root' => $xdisplay->root(),
|
|
'same_screen' => 1,
|
|
)
|
|
) || warn("Error returned from SendEvent: $!");
|
|
}
|
|
}
|
|
$xdisplay->flush();
|
|
}
|
|
|
|
sub create_menubar() {
|
|
logmsg( 2, "create_menubar: started" );
|
|
$menus{bar} = $windows{main_window}->Menu;
|
|
$windows{main_window}->configure( -menu => $menus{bar} );
|
|
|
|
$menus{file} = $menus{bar}->cascade(
|
|
-label => 'File',
|
|
-menuitems => [
|
|
[ "command",
|
|
"Show History",
|
|
-command => \&show_history,
|
|
-accelerator => $config{key_history},
|
|
],
|
|
[ "command",
|
|
"Exit",
|
|
-command => \&exit_prog,
|
|
-accelerator => $config{key_quit},
|
|
]
|
|
],
|
|
-tearoff => 0,
|
|
);
|
|
|
|
$menus{hosts} = $menus{bar}->cascade(
|
|
-label => 'Hosts',
|
|
-tearoff => 1,
|
|
-menuitems => [
|
|
[ "command",
|
|
"Retile Windows",
|
|
-command => \&retile_hosts,
|
|
-accelerator => $config{key_retilehosts},
|
|
],
|
|
|
|
# [ "command", "Capture Terminal", -command => \&capture_terminal, ],
|
|
[ "command",
|
|
"Toggle active state",
|
|
-command => \&toggle_active_state,
|
|
],
|
|
[ "command",
|
|
"Close inactive sessions",
|
|
-command => \&close_inactive_sessions,
|
|
],
|
|
[ "command",
|
|
"Add Host(s) or Cluster(s)",
|
|
-command => \&add_host_by_name,
|
|
-accelerator => $config{key_addhost},
|
|
],
|
|
'',
|
|
],
|
|
);
|
|
|
|
$menus{send} = $menus{bar}->cascade(
|
|
-label => 'Send',
|
|
-tearoff => 1,
|
|
);
|
|
|
|
populate_send_menu();
|
|
|
|
$menus{help} = $menus{bar}->cascade(
|
|
-label => 'Help',
|
|
-menuitems => [
|
|
[ 'command', "About", -command => sub { $windows{help}->Show } ],
|
|
[ 'command', "Documentation",
|
|
-command => sub { $windows{manpage}->Show }
|
|
],
|
|
],
|
|
-tearoff => 0,
|
|
);
|
|
|
|
#$windows{main_window}->bind(
|
|
#'<Key>' => \&key_event,
|
|
#);
|
|
$windows{main_window}->bind( '<KeyPress>' => \&key_event, );
|
|
$windows{main_window}->bind( '<KeyRelease>' => \&key_event, );
|
|
logmsg( 2, "create_menubar: completed" );
|
|
}
|
|
|
|
sub populate_send_menu_entries_from_xml {
|
|
my ( $menu, $menu_xml ) = @_;
|
|
|
|
foreach my $menu_ref ( @{ $menu_xml->{menu} } ) {
|
|
if ( $menu_ref->{menu} ) {
|
|
$menus{ $menu_ref->{title} }
|
|
= $menu->cascade( -label => $menu_ref->{title}, );
|
|
populate_send_menu_entries_from_xml( $menus{ $menu_ref->{title} },
|
|
$menu_ref, );
|
|
if ( $menu_ref->{detach} && $menu_ref->{detach} =~ m/y/i ) {
|
|
$menus{ $menu_ref->{title} }->menu->tearOffMenu()->raise;
|
|
}
|
|
}
|
|
else {
|
|
my $command = undef;
|
|
my $accelerator = undef;
|
|
if ( $menu_ref->{command} ) {
|
|
$command = sub {
|
|
send_text_to_all_servers( $menu_ref->{command}[0] );
|
|
};
|
|
}
|
|
if ( $menu_ref->{accelerator} ) {
|
|
$accelerator = $menu_ref->{accelerator};
|
|
}
|
|
$menu->command(
|
|
-label => $menu_ref->{title},
|
|
-command => $command,
|
|
-accelerator => $accelerator,
|
|
);
|
|
}
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub populate_send_menu {
|
|
|
|
# my @menu_items = ();
|
|
if ( !-r $config{send_menu_xml_file} ) {
|
|
logmsg( 2, 'Using default send menu' );
|
|
|
|
$menus{send}->command(
|
|
-label => 'Hostname',
|
|
-command => [ \&send_text_to_all_servers, '%s' ],
|
|
-accelerator => $config{key_clientname},
|
|
);
|
|
}
|
|
else {
|
|
logmsg(
|
|
2,
|
|
'Using xml send menu definition from ',
|
|
$config{send_menu_xml_file}
|
|
);
|
|
|
|
eval { require XML::Simple; };
|
|
die 'Cannot load XML::Simple - has it been installed? ', $@ if ($@);
|
|
|
|
my $xml = XML::Simple->new( ForceArray => 1, );
|
|
my $menu_xml = $xml->XMLin( $config{send_menu_xml_file} );
|
|
|
|
logmsg( 3, 'xml send menu: ', $/, $xml->XMLout($menu_xml) );
|
|
|
|
if ( $menu_xml->{detach} && $menu_xml->{detach} =~ m/y/i ) {
|
|
$menus{send}->menu->tearOffMenu()->raise;
|
|
}
|
|
|
|
populate_send_menu_entries_from_xml( $menus{send}, $menu_xml );
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub run {
|
|
my ($self) = @_;
|
|
### main ###
|
|
|
|
# Note: getopts returned "" if it finds any options it doesnt recognise
|
|
# so use this to print out basic help
|
|
pod2usage( -verbose => 1 )
|
|
if ( !GetOptions( \%options, @options_spec ) );
|
|
pod2usage( -verbose => 1 ) if ( $options{'?'} || $options{help} );
|
|
pod2usage( -verbose => 2 ) if ( $options{H} || $options{man} );
|
|
|
|
if ( $options{version} ) {
|
|
print "Version: $VERSION\n";
|
|
exit 0;
|
|
}
|
|
|
|
$options{debug} ||= 0;
|
|
|
|
# only get xdisplay if we got past usage and help stuff
|
|
$xdisplay = X11::Protocol->new();
|
|
|
|
if ( !$xdisplay ) {
|
|
die("Failed to get X connection\n");
|
|
}
|
|
|
|
if ( $options{d} && $options{D} ) {
|
|
$options{debug} += 3;
|
|
logmsg( 0,
|
|
'NOTE: -d and -D are deprecated - use "--debug 3" instead' );
|
|
}
|
|
elsif ( $options{d} ) {
|
|
$options{debug} += 1;
|
|
logmsg( 0, 'NOTE: -d is deprecated - use "--debug 1" instead' );
|
|
}
|
|
elsif ( $options{D} ) {
|
|
$options{debug} += 2;
|
|
logmsg( 0, 'NOTE: -D is deprecated - use "--debug 2" instead' );
|
|
}
|
|
|
|
# restrict to max level
|
|
$options{debug} = 4 if ( $options{debug} && $options{debug} > 4 );
|
|
$self->set_debug_level( $options{debug} );
|
|
|
|
logmsg( 2, "VERSION: $VERSION" );
|
|
|
|
load_config_defaults();
|
|
load_configfile();
|
|
|
|
dump_config() if ( $options{'output-config'} );
|
|
|
|
check_ssh_hostnames();
|
|
|
|
evaluate_commands() if ( $options{evaluate} );
|
|
|
|
load_keyboard_map();
|
|
|
|
get_clusters();
|
|
|
|
list_tags() if ( $options{'list'} );
|
|
|
|
if (@ARGV) {
|
|
@servers = resolve_names(@ARGV);
|
|
}
|
|
else {
|
|
if ( $clusters{default} ) {
|
|
@servers = resolve_names( split( /\s+/, $clusters{default} ) );
|
|
}
|
|
}
|
|
|
|
create_windows();
|
|
create_menubar();
|
|
|
|
change_main_window_title();
|
|
|
|
logmsg( 2, "Capture map events" );
|
|
capture_map_events();
|
|
|
|
setup_helper_script();
|
|
open_client_windows(@servers);
|
|
|
|
# Check here if we are tiling windows. Here instead of in func so
|
|
# can be tiled from console window if wanted
|
|
if ( $config{window_tiling} eq "yes" ) {
|
|
retile_hosts();
|
|
}
|
|
else {
|
|
show_console();
|
|
}
|
|
|
|
build_hosts_menu();
|
|
|
|
logmsg( 2, "Sleeping for a mo" );
|
|
select( undef, undef, undef, 0.5 );
|
|
|
|
logmsg( 2, "Sorting focus on console" );
|
|
$windows{text_entry}->focus();
|
|
|
|
logmsg( 2, "Marking main window as user positioned" );
|
|
$windows{main_window}->positionfrom('user')
|
|
; # user puts it somewhere, leave it there
|
|
|
|
logmsg( 2, "Setting up repeat" );
|
|
setup_repeat();
|
|
|
|
logmsg( 2, "Writing default user configuration" );
|
|
write_default_user_config();
|
|
|
|
# Start event loop
|
|
logmsg( 2, "Starting MainLoop" );
|
|
MainLoop();
|
|
|
|
# make sure we leave program in an expected way
|
|
exit_prog();
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
App::ClusterSSH - A container for functions of the ClusterSSH programs
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
There is nothing in this module for public consumption. See documentation
|
|
for F<cssh>, F<crsh>, F<ctel>, F<ccon>, or F<cscp> instead.
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
THis is the core for App::ClusterSSH. You should probably look at L<cssh>
|
|
instead.
|
|
|
|
=head1 SUBROUTINES/METHODS
|
|
|
|
These methods are listed here to tidy up Pod::Coverage test reports but
|
|
will most likely be moved into other modules. There are some notes within
|
|
the code until this time.
|
|
|
|
=over 2
|
|
|
|
=item REAPER
|
|
|
|
=item add_host_by_name
|
|
|
|
=item build_hosts_menu
|
|
|
|
=item capture_map_events
|
|
|
|
=item capture_terminal
|
|
|
|
=item change_main_window_title
|
|
|
|
=item check_config
|
|
|
|
=item check_ssh_hostnames
|
|
|
|
=item close_inactive_sessions
|
|
|
|
=item create_menubar
|
|
|
|
=item create_windows
|
|
|
|
=item dump_config
|
|
|
|
=item list_tags
|
|
|
|
=item evaluate_commands
|
|
|
|
=item exit_prog
|
|
|
|
=item find_binary
|
|
|
|
=item get_clusters
|
|
|
|
=item get_font_size
|
|
|
|
=item get_keycode_state
|
|
|
|
=item key_event
|
|
|
|
=item load_config_defaults
|
|
|
|
=item load_configfile
|
|
|
|
=item load_keyboard_map
|
|
|
|
=item logmsg
|
|
|
|
=item new
|
|
|
|
=item open_client_windows
|
|
|
|
=item parse_config_file
|
|
|
|
=item pick_color
|
|
|
|
=item populate_send_menu
|
|
|
|
=item populate_send_menu_entries_from_xml
|
|
|
|
=item resolve_names
|
|
|
|
=item retile_hosts
|
|
|
|
=item run
|
|
|
|
=item send_resizemove
|
|
|
|
=item send_text
|
|
|
|
=item send_text_to_all_servers
|
|
|
|
=item setup_helper_script
|
|
|
|
=item setup_repeat
|
|
|
|
=item show_console
|
|
|
|
=item show_history
|
|
|
|
=item split_hostname
|
|
|
|
=item terminate_host
|
|
|
|
=item toggle_active_state
|
|
|
|
=item update_display_text
|
|
|
|
=item write_default_user_config
|
|
|
|
=back
|
|
|
|
=head1 BUGS
|
|
|
|
Please report any bugs or feature requests to C<bug-app-clusterssh at rt.cpan.org>, or through
|
|
the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=App-ClusterSSH>. I will be notified, and then you'll
|
|
automatically be notified of progress on your bug as I make changes.
|
|
|
|
=head1 SUPPORT
|
|
|
|
You can find documentation for this module with the perldoc command.
|
|
|
|
perldoc App::ClusterSSH
|
|
|
|
You can also look for information at:
|
|
|
|
=over 4
|
|
|
|
=item * RT: CPAN's request tracker
|
|
|
|
L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=App-ClusterSSH>
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation
|
|
|
|
L<http://annocpan.org/dist/App-ClusterSSH>
|
|
|
|
=item * CPAN Ratings
|
|
|
|
L<http://cpanratings.perl.org/d/App-ClusterSSH>
|
|
|
|
=item * Search CPAN
|
|
|
|
L<http://search.cpan.org/dist/App-ClusterSSH/>
|
|
|
|
=back
|
|
|
|
=head1 ACKNOWLEDGEMENTS
|
|
|
|
Please see the THANKS file from the original distribution.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >>
|
|
|
|
=head1 COPYRIGHT & LICENSE
|
|
|
|
Copyright 1999-2010 Duncan Ferguson, all rights reserved.
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of either: the GNU General Public License as published
|
|
by the Free Software Foundation; or the Artistic License.
|
|
|
|
See http://dev.perl.org/licenses/ for more information.
|
|
|
|
=cut
|
|
|
|
1;
|