mirror of
https://github.com/duncs/clusterssh.git
synced 2025-07-03 09:53:23 +00:00
4266c2a06e
Previous change "Take into account WM decorations when tiling (Github pull request #66) (thanks to Andrew Stevenson)" has caused problems on some systems but improved tiling on others, so make the algorithm configurable to use the original one (default) or the new style. To be revisited when all the window handling code is moved into a separate module
591 lines
16 KiB
Perl
591 lines
16 KiB
Perl
package App::ClusterSSH::Config;
|
|
|
|
use strict;
|
|
use warnings;
|
|
|
|
use version;
|
|
our $VERSION = version->new('0.02');
|
|
|
|
use Carp;
|
|
use Try::Tiny;
|
|
|
|
use FindBin qw($Script);
|
|
use File::Copy;
|
|
|
|
use base qw/ App::ClusterSSH::Base /;
|
|
use App::ClusterSSH::Cluster;
|
|
|
|
my $clusters;
|
|
my %old_clusters;
|
|
my @app_specific = (qw/ command title comms method parent /);
|
|
|
|
# list of config items to not write out when writing the default config
|
|
my @ignore_default_config = (qw/ user /);
|
|
|
|
my %default_config = (
|
|
terminal => "xterm",
|
|
terminal_args => "",
|
|
terminal_title_opt => "-T",
|
|
terminal_colorize => 1,
|
|
terminal_bg_style => 'dark',
|
|
terminal_allow_send_events => "-xrm '*.VT100.allowSendEvents:true'",
|
|
terminal_font => "6x13",
|
|
terminal_size => "80x24",
|
|
|
|
use_hotkeys => "yes",
|
|
key_quit => "Alt-q",
|
|
key_addhost => "Control-Shift-plus",
|
|
key_clientname => "Alt-n",
|
|
key_history => "Alt-h",
|
|
key_localname => "Alt-l",
|
|
key_retilehosts => "Alt-r",
|
|
key_macros_enable => "Alt-p",
|
|
key_paste => "Control-v",
|
|
key_username => "Alt-u",
|
|
mouse_paste => "Button-2",
|
|
auto_quit => "yes",
|
|
auto_close => 5,
|
|
use_natural_sort => 0,
|
|
window_tiling => "yes",
|
|
window_tiling_direction => "right",
|
|
console_position => "",
|
|
|
|
screen_reserve_top => 0,
|
|
screen_reserve_bottom => 60,
|
|
screen_reserve_left => 0,
|
|
screen_reserve_right => 0,
|
|
|
|
terminal_reserve_top => 5,
|
|
terminal_reserve_bottom => 0,
|
|
terminal_reserve_left => 5,
|
|
terminal_reserve_right => 0,
|
|
|
|
terminal_decoration_height => 10,
|
|
terminal_decoration_width => 8,
|
|
|
|
console => 'console',
|
|
console_args => '',
|
|
rsh => 'rsh',
|
|
rsh_args => "",
|
|
telnet => 'telnet',
|
|
telnet_args => "",
|
|
ssh => 'ssh',
|
|
ssh_args => "",
|
|
sftp => 'sftp',
|
|
sftp_args => "",
|
|
|
|
extra_tag_file => '',
|
|
extra_cluster_file => '',
|
|
external_cluster_command => '',
|
|
|
|
unmap_on_redraw => "no", # Debian #329440
|
|
|
|
show_history => 0,
|
|
history_width => 40,
|
|
history_height => 10,
|
|
|
|
command => q{},
|
|
hide_menu => 0,
|
|
max_host_menu_items => 30,
|
|
|
|
macros_enabled => 'yes',
|
|
macro_servername => '%s',
|
|
macro_hostname => '%h',
|
|
macro_username => '%u',
|
|
macro_newline => '%n',
|
|
macro_version => '%v',
|
|
|
|
max_addhost_menu_cluster_items => 6,
|
|
menu_send_autotearoff => 0,
|
|
menu_host_autotearoff => 0,
|
|
|
|
unique_servers => 0,
|
|
use_all_a_records => 0,
|
|
|
|
send_menu_xml_file => $ENV{HOME} . '/.clusterssh/send_menu',
|
|
|
|
auto_wm_decoration_offsets => "no", # Debian #842965
|
|
|
|
# don't set username here as takes precendence over ssh config
|
|
user => '',
|
|
);
|
|
|
|
sub new {
|
|
my ( $class, %args ) = @_;
|
|
|
|
my $self = $class->SUPER::new(%default_config);
|
|
|
|
( my $comms = $Script ) =~ s/^c//;
|
|
|
|
$comms = 'telnet' if ( $comms eq 'tel' );
|
|
$comms = 'console' if ( $comms eq 'con' );
|
|
$comms = 'ssh' if ( $comms eq 'lusterssh' );
|
|
$comms = 'sftp' if ( $comms eq 'sftp' );
|
|
|
|
# list of allowed comms methods
|
|
if ( 'ssh rsh telnet sftp console' !~ m/\b$comms\b/ ) {
|
|
$self->{comms} = 'ssh';
|
|
}
|
|
else {
|
|
$self->{comms} = $comms;
|
|
}
|
|
|
|
$self->{title} = uc($Script);
|
|
|
|
$clusters = App::ClusterSSH::Cluster->new();
|
|
|
|
return $self->validate_args(%args);
|
|
}
|
|
|
|
sub validate_args {
|
|
my ( $self, %args ) = @_;
|
|
|
|
my @unknown_config = ();
|
|
|
|
foreach my $config ( sort( keys(%args) ) ) {
|
|
if ( grep /$config/, @app_specific ) {
|
|
|
|
# $self->{$config} ||= 'unknown';
|
|
next;
|
|
}
|
|
|
|
if ( exists $self->{$config} ) {
|
|
$self->{$config} = $args{$config};
|
|
}
|
|
else {
|
|
push( @unknown_config, $config );
|
|
}
|
|
}
|
|
|
|
if (@unknown_config) {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
unknown_config => \@unknown_config,
|
|
error => $self->loc(
|
|
'Unknown configuration parameters: [_1]' . $/,
|
|
join( ',', @unknown_config )
|
|
)
|
|
)
|
|
);
|
|
}
|
|
|
|
if ( !$self->{comms} ) {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc( 'Invalid variable: comms' . $/ ),
|
|
),
|
|
);
|
|
}
|
|
|
|
if ( !$self->{ $self->{comms} } ) {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc(
|
|
'Invalid variable: [_1]' . $/,
|
|
$self->{comms}
|
|
),
|
|
),
|
|
);
|
|
}
|
|
|
|
# check the terminal has been found correctly
|
|
# looking for the terminal should not be fatal
|
|
if ( !-e $self->{terminal} ) {
|
|
eval { $self->{terminal} = $self->find_binary( $self->{terminal} ); };
|
|
if ($@) {
|
|
warn $@->message;
|
|
}
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub parse_config_file {
|
|
my ( $self, $config_file ) = @_;
|
|
|
|
$self->debug( 2, 'Loading in config file: ', $config_file );
|
|
|
|
# if ( !-e $config_file || !-r $config_file ) {
|
|
# croak(
|
|
# App::ClusterSSH::Exception::Config->throw(
|
|
# error => $self->loc(
|
|
# 'File [_1] does not exist or cannot be read' . $/,
|
|
# $config_file
|
|
# ),
|
|
# ),
|
|
# );
|
|
# }
|
|
#
|
|
# open( CFG, $config_file ) or die("Couldnt open $config_file: $!");
|
|
# my $l;
|
|
# my %read_config;
|
|
# 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 ) {
|
|
# $read_config{$key} = $value;
|
|
# $self->debug( 3, "$key=$value" );
|
|
# }
|
|
# }
|
|
# close(CFG);
|
|
|
|
my %read_config;
|
|
%read_config
|
|
= $self->load_file( type => 'config', filename => $config_file );
|
|
|
|
# grab any clusters from the config before validating it
|
|
if ( $read_config{clusters} ) {
|
|
$self->debug( 3, "Picked up clusters defined in $config_file" );
|
|
foreach my $cluster ( sort split / /, $read_config{clusters} ) {
|
|
if ( $read_config{$cluster} ) {
|
|
$clusters->register_tag( $cluster,
|
|
split( / /, $read_config{$cluster} ) );
|
|
$old_clusters{$cluster} = $read_config{$cluster};
|
|
delete( $read_config{$cluster} );
|
|
}
|
|
}
|
|
delete( $read_config{clusters} );
|
|
}
|
|
|
|
# tidy up entries, just in case
|
|
$read_config{terminal_font} =~ s/['"]//g
|
|
if ( $read_config{terminal_font} );
|
|
|
|
$self->validate_args(%read_config);
|
|
}
|
|
|
|
sub load_configs {
|
|
my ( $self, @configs ) = @_;
|
|
|
|
for my $config (
|
|
'/etc/csshrc',
|
|
$ENV{HOME} . '/.csshrc',
|
|
$ENV{HOME} . '/.clusterssh/config',
|
|
)
|
|
{
|
|
$self->parse_config_file($config) if ( -e $config );
|
|
}
|
|
|
|
# write out default config file if necesasry
|
|
try {
|
|
$self->write_user_config_file();
|
|
}
|
|
catch {
|
|
warn $_, $/;
|
|
};
|
|
|
|
# Attempt to load in provided config files. Also look for anything
|
|
# relative to config directory
|
|
for my $config (@configs) {
|
|
next unless ($config); # can be null when passed from Getopt::Long
|
|
$self->parse_config_file($config) if ( -e $config );
|
|
|
|
my $file = $ENV{HOME} . '/.clusterssh/config_' . $config;
|
|
$self->parse_config_file($file) if ( -e $file );
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
sub write_user_config_file {
|
|
my ($self) = @_;
|
|
|
|
# attempt to move the old config file to one side
|
|
if ( -f "$ENV{HOME}/.csshrc" ) {
|
|
eval { move( "$ENV{HOME}/.csshrc", "$ENV{HOME}/.csshrc.DISABLED" ) };
|
|
|
|
if ($@) {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc(
|
|
'Unable to move [_1] to [_2]: [_3]' . $/,
|
|
'$HOME/.csshrc', '$HOME/.csshrc.DISABLED', $@
|
|
),
|
|
)
|
|
);
|
|
}
|
|
else {
|
|
warn(
|
|
$self->loc(
|
|
'Moved [_1] to [_2]' . $/, '$HOME/.csshrc',
|
|
'$HOME/.csshrc.DISABLED'
|
|
),
|
|
);
|
|
}
|
|
}
|
|
|
|
return if ( -f "$ENV{HOME}/.clusterssh/config" );
|
|
|
|
if ( !-d "$ENV{HOME}/.clusterssh" ) {
|
|
if ( !mkdir("$ENV{HOME}/.clusterssh") ) {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc(
|
|
'Unable to create directory [_1]: [_2]' . $/,
|
|
'$HOME/.clusterssh', $!
|
|
),
|
|
),
|
|
);
|
|
|
|
}
|
|
}
|
|
|
|
# Debian #673507 - migrate clusters prior to writing ~/.clusterssh/config
|
|
# in order to update the extra_cluster_file property
|
|
if (%old_clusters) {
|
|
if ( open( my $fh, ">", "$ENV{HOME}/.clusterssh/clusters" ) ) {
|
|
print $fh '# '
|
|
. $self->loc('Tag definitions moved from old .csshrc file'),
|
|
$/;
|
|
foreach ( sort( keys(%old_clusters) ) ) {
|
|
print $fh $_, ' ', join( ' ', $old_clusters{$_} ), $/;
|
|
}
|
|
close($fh);
|
|
}
|
|
else {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc(
|
|
'Unable to write [_1]: [_2]' . $/,
|
|
'$HOME/.clusterssh/clusters',
|
|
$!
|
|
),
|
|
),
|
|
);
|
|
}
|
|
}
|
|
|
|
if ( open( CONFIG, ">", "$ENV{HOME}/.clusterssh/config" ) ) {
|
|
foreach ( sort( keys(%$self) ) ) {
|
|
my $comment = '';
|
|
if ( grep /$_/, @ignore_default_config ) {
|
|
$comment = '#';
|
|
}
|
|
print CONFIG ${comment}, $_, '=', $self->{$_}, $/;
|
|
}
|
|
close(CONFIG);
|
|
warn(
|
|
$self->loc(
|
|
'Created new configuration file within [_1]' . $/,
|
|
'$HOME/.clusterssh/'
|
|
)
|
|
);
|
|
}
|
|
else {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc(
|
|
'Unable to write default [_1]: [_2]' . $/,
|
|
'$HOME/.clusterssh/config', $!
|
|
),
|
|
),
|
|
);
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
# search given directories for the given file
|
|
sub search_dirs {
|
|
my ( $self, $file, @directories ) = @_;
|
|
|
|
my $path;
|
|
|
|
foreach my $dir (@directories) {
|
|
$self->debug( 3, "Looking for $file in $dir" );
|
|
|
|
if ( -f $dir . '/' . $file && -x $dir . '/' . $file ) {
|
|
$path = $dir . '/' . $file;
|
|
$self->debug( 2, "Found at $path" );
|
|
last;
|
|
}
|
|
}
|
|
|
|
return $path;
|
|
}
|
|
|
|
# could use File::Which for some of this but we also search a few other places
|
|
# just in case $PATH isnt set up right
|
|
sub find_binary {
|
|
my ( $self, $binary ) = @_;
|
|
|
|
if ( !$binary ) {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc('argument not provided') . $/,
|
|
),
|
|
);
|
|
}
|
|
|
|
$self->debug( 2, "Looking for $binary" );
|
|
|
|
# if not found, strip the path and look again
|
|
if ( $binary =~ m!^/! ) {
|
|
if ( -f $binary ) {
|
|
$self->debug( 2, "Already have full path to in $binary" );
|
|
return $binary;
|
|
}
|
|
else {
|
|
$self->debug( 2, "Full path for $binary incorrect; searching" );
|
|
$binary =~ s!^.*/!!;
|
|
}
|
|
}
|
|
|
|
my $path;
|
|
if ( !-x $binary || substr( $binary, 0, 1 ) ne '/' ) {
|
|
$path = $self->search_dirs( $binary, split( /:/, $ENV{PATH} ) );
|
|
|
|
# if it is on $PATH then no need to qualitfy the path to it
|
|
# keep it as it is
|
|
if ($path) {
|
|
return $binary;
|
|
}
|
|
else {
|
|
$path = $self->search_dirs(
|
|
$binary, qw!
|
|
/bin
|
|
/sbin
|
|
/usr/sbin
|
|
/usr/bin
|
|
/usr/local/bin
|
|
/usr/local/sbin
|
|
/opt/local/bin
|
|
/opt/local/sbin
|
|
!
|
|
);
|
|
}
|
|
|
|
}
|
|
else {
|
|
$self->debug( 2, "Already configured OK" );
|
|
$path = $binary;
|
|
}
|
|
if ( !$path || !-f $path || !-x $path ) {
|
|
croak(
|
|
App::ClusterSSH::Exception::Config->throw(
|
|
error => $self->loc(
|
|
'"[_1]" binary not found - please amend $PATH or the cssh config file'
|
|
. $/,
|
|
$binary
|
|
),
|
|
),
|
|
);
|
|
}
|
|
|
|
chomp($path);
|
|
return $path;
|
|
}
|
|
|
|
sub dump {
|
|
my ( $self, $no_exit, ) = @_;
|
|
|
|
$self->debug( 3, 'Dumping config to STDOUT' );
|
|
print( '# Configuration dump produced by "cssh -d"', $/ );
|
|
|
|
foreach my $key ( sort keys %$self ) {
|
|
my $comment = '';
|
|
if ( grep /$key/, @app_specific ) {
|
|
next;
|
|
}
|
|
if ( grep /$key/, @ignore_default_config ) {
|
|
$comment = '#';
|
|
}
|
|
print $comment, $key, '=', $self->{$key}, $/;
|
|
}
|
|
|
|
$self->exit if ( !$no_exit );
|
|
}
|
|
|
|
#use overload (
|
|
# q{""} => sub {
|
|
# my ($self) = @_;
|
|
# return $self->{hostname};
|
|
# },
|
|
# fallback => 1,
|
|
#);
|
|
|
|
1;
|
|
|
|
=pod
|
|
|
|
=head1 NAME
|
|
|
|
ClusterSSH::Config - Object representing application configuration
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Object representing application configuration
|
|
|
|
=head1 METHODS
|
|
|
|
=over 4
|
|
|
|
=item $host=ClusterSSH::Config->new ({ })
|
|
|
|
Create a new configuration object.
|
|
|
|
=item $config->parse_config_file('<filename>');
|
|
|
|
Read in configuration from given filename
|
|
|
|
=item $config->validate_args();
|
|
|
|
Validate and apply all configuration loaded at this point
|
|
|
|
=item $path = $config->search_dirs('<name>', @seaarch_directories);
|
|
|
|
Search the given directories for the name given. Return undef if not found.
|
|
|
|
=item $path = $config->find_binary('<name>');
|
|
|
|
Locate the binary <name> and return the full path. Doesn't just search
|
|
$PATH in case the environment isn't set up correctly
|
|
|
|
=item $config->load_configs(@extra);
|
|
|
|
Load up configuration from known locations (warn if .csshrc file found) and
|
|
load in option files as necessary.
|
|
|
|
=item $config->write_user_config_file();
|
|
|
|
Write out default $HOME/.clusterssh/config file (before option config files
|
|
are loaded).
|
|
|
|
=item $config->dump()
|
|
|
|
Write currently defined configuration to STDOUT
|
|
|
|
=back
|
|
|
|
=head1 AUTHOR
|
|
|
|
Duncan Ferguson, C<< <duncan_j_ferguson at yahoo.co.uk> >>
|
|
|
|
=head1 LICENSE AND COPYRIGHT
|
|
|
|
Copyright 1999-2016 Duncan Ferguson.
|
|
|
|
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;
|