mirror of
https://github.com/duncs/clusterssh.git
synced 2025-04-21 17:09:06 +00:00
Compare commits
No commits in common. "master" and "v4.15" have entirely different histories.
27 changed files with 190 additions and 271 deletions
68
.github/workflows/dzil_tester.yml
vendored
68
.github/workflows/dzil_tester.yml
vendored
|
@ -1,68 +0,0 @@
|
|||
name: CI test builds
|
||||
|
||||
on:
|
||||
push:
|
||||
branches: '*'
|
||||
pull_request:
|
||||
branches: '*'
|
||||
|
||||
jobs:
|
||||
perl-job:
|
||||
runs-on: ubuntu-latest
|
||||
strategy:
|
||||
fail-fast: false
|
||||
matrix:
|
||||
perl-version:
|
||||
- 'devel'
|
||||
- 'latest'
|
||||
- '5.40'
|
||||
- '5.38'
|
||||
- '5.36'
|
||||
- '5.34'
|
||||
- '5.32'
|
||||
- '5.30'
|
||||
- '5.28'
|
||||
- '5.26'
|
||||
- '5.24'
|
||||
- '5.22'
|
||||
- '5.20'
|
||||
- '5.18'
|
||||
- '5.16'
|
||||
include:
|
||||
- perl-version: '5.38'
|
||||
os: ubuntu-latest
|
||||
coverage: true
|
||||
container:
|
||||
image: perldocker/perl-tester:${{ matrix.perl-version }}
|
||||
|
||||
name: Perl ${{ matrix.perl-version }}
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@main
|
||||
- name: Amend PATH
|
||||
run: echo "${GITHUB_WORKSPACE}/t/bin" >> $GITHUB_PATH
|
||||
- name: Current env
|
||||
run: env
|
||||
- name: Perl info
|
||||
run: perl -V
|
||||
- name: CPAN test modules
|
||||
run: cpanm -n Pod::Coverage::TrustPod Test::Perl::Critic Test::Pod::Coverage Test::Pod Test::Trap
|
||||
- name: CPAN build modules
|
||||
run: cpanm -n Tk X11::Protocol X11::Protocol::Other
|
||||
- name: Initial Build
|
||||
run: perl Build.PL
|
||||
- name: Build the MANIFEST
|
||||
run: perl Build manifest
|
||||
- name: Test suite
|
||||
if: ${{ !matrix.coverage }}
|
||||
run: perl Build test
|
||||
env:
|
||||
RELEASE_TESTING: 1
|
||||
AUTHOR_TESTING: 1
|
||||
- name: Coverage tests
|
||||
if: ${{ matrix.coverage }}
|
||||
run: perl Build test
|
||||
env:
|
||||
COVERAGE: 1
|
||||
RELEASE_TESTING: 1
|
||||
AUTHOR_TESTING: 1
|
32
.travis.yml
Normal file
32
.travis.yml
Normal file
|
@ -0,0 +1,32 @@
|
|||
language: perl
|
||||
perl:
|
||||
- blead
|
||||
- dev
|
||||
# No clean build due to removal of '.' from lib path
|
||||
# - 5.26
|
||||
- 5.24
|
||||
- 5.22
|
||||
- 5.20
|
||||
- 5.18
|
||||
- 5.16
|
||||
- 5.14
|
||||
- 5.12
|
||||
- 5.10
|
||||
# stopping builds; is anyone really still using this version?
|
||||
# - 5.8
|
||||
matrix:
|
||||
include:
|
||||
- perl: 5.24
|
||||
env: COVERAGE=1
|
||||
allow_failures:
|
||||
- perl: blead
|
||||
- perl: blead-thr
|
||||
- perl: dev
|
||||
sudo: false
|
||||
env:
|
||||
global:
|
||||
- RELEASE_TESTING=1
|
||||
- AUTHOR_TESTING=1
|
||||
before_install:
|
||||
- eval $(curl https://travis-perl.github.io/init) --auto
|
||||
- cpanm -n -f Pod::Coverage::TrustPod Test::Perl::Critic Test::Pod::Coverage Test::Pod
|
5
Build.PL
5
Build.PL
|
@ -3,8 +3,7 @@ use lib 'inc';
|
|||
require Module::Build;
|
||||
|
||||
my %module_build_args = (
|
||||
module_name => 'App::ClusterSSH',
|
||||
dist_abstract => "Cluster administration tool",
|
||||
module_name => 'App::ClusterSSH',
|
||||
##{ $plugin->get_prereqs(1) ##}
|
||||
##{ $plugin->get_default('share_dir') ##}
|
||||
script_files => [
|
||||
|
@ -12,7 +11,7 @@ my %module_build_args = (
|
|||
'bin/ccon', 'bin/crsh',
|
||||
'bin/ctel', 'bin/clusterssh_bash_completion.dist'
|
||||
],
|
||||
PL_files => {
|
||||
PL_files => {
|
||||
'bin_PL/_build_docs' => [
|
||||
'bin/cssh', 'bin/csftp',
|
||||
'bin/ccon', 'bin/crsh',
|
||||
|
|
12
Changes
12
Changes
|
@ -1,17 +1,5 @@
|
|||
Revision history for {{$dist->name}}
|
||||
|
||||
4.18 2024-10-19 Duncan Ferguson <duncan_ferguson@user.sf.net>
|
||||
- Re-release due to poor release upload to CPAN
|
||||
|
||||
4.17 2024-10-16 Duncan Ferguson <duncan_ferguson@user.sf.net>
|
||||
- Swap the hostname lookup macro from DNS to using the system hostname (Github issue #158)
|
||||
- Swap from using Travis-CI to Github Actions
|
||||
- Fix tests on perl 5.38 and 5.40 (Github Issue #153)
|
||||
|
||||
4.16 2020-06-20 Duncan Ferguson <duncan_ferguson@user.sf.net>
|
||||
- Further fix for 'resolve_names' error when adding hosts via the UI
|
||||
- Fix missing space separator for ssh_args (thanks to Petr Vorel)
|
||||
|
||||
4.15 2020-05-18 Duncan Ferguson <duncan_ferguson@user.sf.net>
|
||||
- Include all utilies within each man page
|
||||
- Add in 'command_pre' and 'command_post' configuration options
|
||||
|
|
2
README
2
README
|
@ -2,7 +2,7 @@ NAME
|
|||
cssh - Cluster administration tool
|
||||
|
||||
VERSION
|
||||
This documentation is for version: 4.18
|
||||
This documentation is for version: 4.15
|
||||
|
||||
SYNOPSIS
|
||||
cssh [-a '<command>'] [-K <seconds>] [-q] [-c '<filename>'] [-x <cols>]
|
||||
|
|
1
THANKS
1
THANKS
|
@ -48,4 +48,3 @@ Bill Rushmore
|
|||
Ankit Vadehra
|
||||
Azenet
|
||||
Markus Frosch (lazyfrosch)
|
||||
Petr Vorel
|
||||
|
|
|
@ -6,42 +6,41 @@ use warnings;
|
|||
use FindBin qw($Bin $Script);
|
||||
use File::Basename;
|
||||
|
||||
my $bindir = "bin";
|
||||
my $bindir="bin";
|
||||
|
||||
if ( !-d $bindir ) {
|
||||
if(! -d $bindir) {
|
||||
mkdir $bindir || die "Could not mkdir $bindir: $!";
|
||||
}
|
||||
|
||||
print "Using perl binary: $^X", $/;
|
||||
print "Using perl version $^V", $/;
|
||||
print "Using perl binary: $^X",$/;
|
||||
print "Using perl version $^V",$/;
|
||||
|
||||
for my $dest (@ARGV) {
|
||||
my $source = $Bin . '/' . basename($dest);
|
||||
my $source=$Bin.'/'.basename($dest);
|
||||
|
||||
next if ( $source =~ m/$Script/ );
|
||||
next if ( $source =~ m/\.x$/ );
|
||||
next if($source =~ m/$Script/);
|
||||
next if($source =~ m/\.x$/);
|
||||
|
||||
print "Generating: $source", $/;
|
||||
print "Generating: $source",$/;
|
||||
|
||||
if ( -f $dest ) {
|
||||
chmod( 0755, $dest ) || die "Could not chmod $dest for removing: $!";
|
||||
if(-f $dest) {
|
||||
chmod(0755, $dest) || die "Could not chmod $dest for removing: $!";
|
||||
}
|
||||
|
||||
open( my $sfh, '<', $source )
|
||||
|| die "Could not open $source for reading: $!";
|
||||
open( my $dfh, '>', $dest ) || die "Could not open $dest for writing: $!";
|
||||
print $dfh $_ while (<$sfh>);
|
||||
open(my $sfh, '<', $source) || die "Could not open $source for reading: $!";
|
||||
open(my $dfh, '>', $dest ) || die "Could not open $dest for writing: $!";
|
||||
print $dfh $_ while(<$sfh>);
|
||||
close($sfh);
|
||||
|
||||
if ( $source !~ m/clusterssh_bash_completion.dist/ ) {
|
||||
if($source !~ m/clusterssh_bash_completion.dist/) {
|
||||
print $dfh "\n\n__END__\n\n";
|
||||
|
||||
my $pod = qx{ $^X $source --generate-pod };
|
||||
die "Failed to generate pod" if ($?);
|
||||
my $pod= qx{ $^X $source --generate-pod };
|
||||
die "Failed to generate pod" if($?);
|
||||
print $dfh $pod;
|
||||
}
|
||||
|
||||
close($dfh);
|
||||
|
||||
chmod( 0555, $dest ) || die "Could not chmod $dest: $!";
|
||||
chmod(0555, $dest) || die "Could not chmod $dest: $!";
|
||||
}
|
||||
|
|
|
@ -15,9 +15,7 @@ my $app = App::ClusterSSH->new();
|
|||
|
||||
$app->add_option(
|
||||
spec => 'master|M=s',
|
||||
help => $app->loc(
|
||||
"The console client program polls master as the primary server, rather than the default set at compile time (typically ``console'')."
|
||||
),
|
||||
help => $app->loc("The console client program polls master as the primary server, rather than the default set at compile time (typically ``console'')."),
|
||||
);
|
||||
|
||||
$app->run();
|
||||
|
|
|
@ -1,12 +1,11 @@
|
|||
use warnings;
|
||||
use strict;
|
||||
|
||||
package App::ClusterSSH;
|
||||
|
||||
# ABSTRACT: Cluster administration tool
|
||||
# ABSTRACT: Cluster administration tool
|
||||
|
||||
use version; our $VERSION = version->new('4.18');
|
||||
use version; our $VERSION = version->new('4.15');
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
|
@ -41,7 +40,7 @@ use App::ClusterSSH::Window;
|
|||
use FindBin qw($Script);
|
||||
|
||||
use POSIX ":sys_wait_h";
|
||||
use POSIX qw/:sys_wait_h strftime mkfifo/;
|
||||
use POSIX qw/:sys_wait_h strftime mkfifo/;
|
||||
use File::Temp qw/:POSIX/;
|
||||
use Fcntl;
|
||||
use File::Basename;
|
||||
|
@ -486,6 +485,7 @@ sub run {
|
|||
|
||||
1;
|
||||
|
||||
|
||||
=item REAPER
|
||||
|
||||
=item add_host_by_name
|
||||
|
@ -593,7 +593,7 @@ slash_slash_equal($a, 0) is equivalent to $a //= 0
|
|||
|
||||
=item window
|
||||
|
||||
Method to access associated window module
|
||||
Method to access assosiated window module
|
||||
|
||||
=item write_default_user_config
|
||||
|
||||
|
|
|
@ -304,13 +304,15 @@ sub parent {
|
|||
sub sort {
|
||||
my $self = shift;
|
||||
|
||||
my $sort = sub { sort @_ };
|
||||
|
||||
return $sort
|
||||
unless ref( $self->config() ) eq "HASH"
|
||||
&& $self->config()->{'use_natural_sort'};
|
||||
|
||||
# if the user has asked for natural sorting we need to include an extra
|
||||
# module
|
||||
my $config = $self->config();
|
||||
|
||||
# Make sure the configuration object has been set correctly before
|
||||
# referencing anything
|
||||
if ( ref $config eq "HASH" && $config->{'use_natural_sort'} ) {
|
||||
if ( $self->config()->{'use_natural_sort'} ) {
|
||||
eval { Module::Load::load('Sort::Naturally'); };
|
||||
if ($@) {
|
||||
warn(
|
||||
|
@ -318,17 +320,16 @@ sub sort {
|
|||
);
|
||||
}
|
||||
else {
|
||||
my $sort = sub { Sort::Naturally::nsort(@_) };
|
||||
return $sort;
|
||||
$sort = sub { Sort::Naturally::nsort(@_) };
|
||||
}
|
||||
}
|
||||
|
||||
my $sort = sub { sort @_ };
|
||||
return $sort;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
These extra methods are provided on the object
|
||||
|
|
|
@ -87,7 +87,7 @@ sub _run_external_clusters {
|
|||
|
||||
$self->debug( 3, 'Running tags through external command' );
|
||||
$self->debug( 4, 'External command: ', $external_command );
|
||||
$self->debug( 3, 'Args ', join( ',', @args ) );
|
||||
$self->debug( 3, 'Args ', join( ',', @args ) );
|
||||
|
||||
my $command = "$external_command @args";
|
||||
|
||||
|
|
|
@ -114,11 +114,10 @@ my %default_config = (
|
|||
macro_user_3 => '%3',
|
||||
macro_user_4 => '%4',
|
||||
|
||||
macro_user_1_command => '',
|
||||
macro_user_2_command => '',
|
||||
macro_user_3_command => '',
|
||||
macro_user_4_command => '',
|
||||
hostname_override => '',
|
||||
macro_user_1_command => '',
|
||||
macro_user_2_command => '',
|
||||
macro_user_3_command => '',
|
||||
macro_user_4_command => '',
|
||||
|
||||
max_addhost_menu_cluster_items => 6,
|
||||
menu_send_autotearoff => 0,
|
||||
|
@ -298,7 +297,7 @@ sub parse_config_file {
|
|||
|
||||
# Look at the user macros and if not set remove the hotkey for them
|
||||
for my $i (qw/ 1 2 3 4 /) {
|
||||
if ( !$self->{"macro_user_${i}_command"} ) {
|
||||
if ( ! $self->{"macro_user_${i}_command"} ) {
|
||||
delete $self->{"key_user_${i}"};
|
||||
}
|
||||
}
|
||||
|
@ -315,7 +314,7 @@ sub load_configs {
|
|||
$ENV{HOME} . '/.clusterssh/config',
|
||||
)
|
||||
{
|
||||
$self->parse_config_file($config) if ( -e $config && !-d _ );
|
||||
$self->parse_config_file($config) if ( -e $config );
|
||||
}
|
||||
|
||||
# write out default config file if necesasry
|
||||
|
@ -330,22 +329,10 @@ sub load_configs {
|
|||
# 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 && !-d _ );
|
||||
$self->parse_config_file($config) if ( -e $config );
|
||||
|
||||
my $file = $ENV{HOME} . '/.clusterssh/config_' . $config;
|
||||
$self->parse_config_file($file) if ( -e $file && !-d _ );
|
||||
}
|
||||
|
||||
# Override confuration via environment variable using cssh_ prefix
|
||||
# eg: terminal_size => cssh_terminal_size
|
||||
foreach my $config_key ( sort( keys(%default_config) ) ) {
|
||||
my $env_config_key = "cssh_" . $config_key;
|
||||
if ( exists $ENV{ uc($env_config_key) } ) {
|
||||
$env_config_key = uc($env_config_key);
|
||||
}
|
||||
if ( exists $ENV{$env_config_key} ) {
|
||||
$self->{$config_key} = $ENV{$env_config_key};
|
||||
}
|
||||
$self->parse_config_file($file) if ( -e $file );
|
||||
}
|
||||
|
||||
return $self;
|
||||
|
|
|
@ -95,7 +95,7 @@ sub add_option {
|
|||
}
|
||||
$desc .= " $arg" if ($arg);
|
||||
$short .= " $arg" if ( $short && $arg );
|
||||
$long .= " $arg" if ( $long && $arg );
|
||||
$long .= " $arg" if ( $long && $arg );
|
||||
}
|
||||
$args{option_desc} = $desc;
|
||||
$args{option_short} = $short;
|
||||
|
@ -426,7 +426,7 @@ sub output {
|
|||
sub _generate_pod {
|
||||
my ($self) = @_;
|
||||
|
||||
output $/, "=pod";
|
||||
output $/ , "=pod";
|
||||
output '=head1 ', $self->loc('NAME');
|
||||
output "$Script - ", $self->loc("Cluster administration tool");
|
||||
output '=head1 ', $self->loc('VERSION');
|
||||
|
@ -448,22 +448,22 @@ sub _generate_pod {
|
|||
|
||||
output '=head1 ', $self->loc('RELATED');
|
||||
output $self->loc(
|
||||
q{Also see the individual man pages for each of these utilities});
|
||||
q{Also see the individual man pages for each of these utilities} );
|
||||
|
||||
my %utils = (
|
||||
ctel => 'telnet',
|
||||
cssh => 'ssh',
|
||||
crsh => 'rsh',
|
||||
csftp => 'sftp',
|
||||
ccon => 'console',
|
||||
ctel => 'telnet',
|
||||
cssh => 'ssh',
|
||||
crsh => 'rsh',
|
||||
csftp => 'sftp',
|
||||
ccon => 'console',
|
||||
);
|
||||
|
||||
output '=over';
|
||||
|
||||
for my $util ( sort grep { !/$Script/ } keys %utils ) {
|
||||
output "=item $util - "
|
||||
. $self->loc( q{Use '[_1]' as the communication method},
|
||||
$utils{$util} );
|
||||
for my $util (sort grep { !/$Script/ } keys %utils) {
|
||||
output "=item $util - ".$self->loc(
|
||||
q{Use '[_1]' as the communication method}, $utils{$util}
|
||||
);
|
||||
}
|
||||
|
||||
output '=back';
|
||||
|
@ -585,9 +585,7 @@ would replace the <Alt-n> with the client's name in each window.}
|
|||
output '=item ', $self->parent->config->{key_user_2} || 'Alt-2';
|
||||
output '=item ', $self->parent->config->{key_user_3} || 'Alt-3';
|
||||
output '=item ', $self->parent->config->{key_user_4} || 'Alt-4';
|
||||
output $self->loc(
|
||||
q{Run the matching user defined macro on the server and send the output to the client}
|
||||
);
|
||||
output $self->loc(q{Run the matching user defined macro on the server and send the output to the client});
|
||||
|
||||
output '=back';
|
||||
|
||||
|
@ -712,8 +710,7 @@ command_post= | ct
|
|||
|
||||
would allow for using Python virtual envronments and then piping all shell output through C<chromaterm> for syntax highlighting. Note: you must use appropriate command separators/terminators to keep the meaning of the command pipline (such as C<;> and C<|> between commands).
|
||||
|
||||
These are not put through macro parsing.}
|
||||
);
|
||||
These are not put through macro parsing.});
|
||||
output '=item comms = ' . $self->parent->config->{comms};
|
||||
output $self->loc(
|
||||
'Sets the default communication method (initially taken from the name of the program, but can be overridden here).'
|
||||
|
@ -816,8 +813,7 @@ If the external command is given a C<-L> option it should output a list of tags
|
|||
output '=item key_user_4 = Alt-4';
|
||||
output $self->loc(
|
||||
q{Default key sequence to send user defined macros to client. If the matching [_2] macro is undefined, the sequence is passed straight to the terminal. See [_1] for more information.},
|
||||
'L<KEY SHORTCUTS>',
|
||||
'L<macro_user_1>'
|
||||
'L<KEY SHORTCUTS>', 'L<macro_user_1>'
|
||||
);
|
||||
|
||||
output '=item macro_servername = %s';
|
||||
|
@ -856,9 +852,7 @@ If the external command is given a C<-L> option it should output a list of tags
|
|||
},
|
||||
);
|
||||
|
||||
output $self->loc(
|
||||
"The following environment variables are set in the shell of the macro process"
|
||||
);
|
||||
output $self->loc("The following environment variables are set in the shell of the macro process");
|
||||
output '=over';
|
||||
output '=item C<CSSH_SERVERNAME>';
|
||||
output '=item C<CSSH_HOSTNAME>';
|
||||
|
|
|
@ -71,9 +71,9 @@ sub script {
|
|||
my \$user=shift;
|
||||
my \$port=shift;
|
||||
my \$mstr=shift;
|
||||
my \$command="$command_pre $comms $comms_args ";
|
||||
my \$command="$command_pre $comms $comms_args";
|
||||
open(PIPE, ">", \$pipe) or die("Failed to open pipe: \$!\\n");
|
||||
print PIPE "\$\$:\$ENV{WINDOWID}"
|
||||
print PIPE "\$\$:\$ENV{WINDOWID}"
|
||||
or die("Failed to write to pipe: $!\\n");
|
||||
close(PIPE) or die("Failed to close pipe: $!\\n");
|
||||
if(\$svr =~ m/==\$/)
|
||||
|
|
|
@ -381,7 +381,7 @@ Set specific details about the host after its been created.
|
|||
=item get_realname
|
||||
|
||||
If the server name provided is not an IP address (either IPv4 or IPv6)
|
||||
attempt to resolve it and return the discovered names.
|
||||
attempt to resolve it and retun the discovered names.
|
||||
|
||||
=item get_givenname
|
||||
|
||||
|
|
|
@ -21,6 +21,7 @@ use base 'App::ClusterSSH::L10N';
|
|||
|
||||
1;
|
||||
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
No method are exported. See L<Locale::Maketext>.
|
||||
|
|
|
@ -28,12 +28,8 @@ sub import {
|
|||
my ($class) = @_;
|
||||
|
||||
# If we are building or in test here, just exit
|
||||
# as the build servers will not have Tk installed
|
||||
if ( $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING} ) {
|
||||
print STDERR
|
||||
"skipping initialisation; AUTHOR_TESTING or RELEASE_TESTING are set\n";
|
||||
return;
|
||||
}
|
||||
# as travis build servers will not have Tk installed
|
||||
return if $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING};
|
||||
|
||||
# Find what windows module we should be using and just overlay it into
|
||||
# this object
|
||||
|
|
|
@ -10,8 +10,8 @@ use English qw( -no_match_vars );
|
|||
use base qw/ App::ClusterSSH::Base /;
|
||||
use vars qw/ %keysymtocode %keycodetosym /;
|
||||
|
||||
use Sys::Hostname qw/ hostname /;
|
||||
use File::Temp qw/:POSIX/;
|
||||
use Net::Domain qw(hostfqdn);
|
||||
use File::Temp qw/:POSIX/;
|
||||
use Fcntl;
|
||||
use POSIX ":sys_wait_h";
|
||||
use POSIX qw/:sys_wait_h strftime mkfifo/;
|
||||
|
@ -27,14 +27,14 @@ use X11::Protocol::Constants qw/ Shift Mod5 ShiftMask /;
|
|||
use X11::Protocol::WM 29;
|
||||
use X11::Keysyms '%keysymtocode', 'MISCELLANY', 'XKB_KEYS', '3270', 'LATIN1',
|
||||
'LATIN2', 'LATIN3', 'LATIN4', 'KATAKANA', 'ARABIC', 'CYRILLIC', 'GREEK',
|
||||
'TECHNICAL', 'SPECIAL', 'PUBLISHING', 'APL', 'HEBREW', 'THAI', 'KOREAN';
|
||||
'TECHNICAL', 'SPECIAL', 'PUBLISHING', 'APL', 'HEBREW', 'THAI', 'KOREAN';
|
||||
|
||||
# Module to contain all Tk specific functionality
|
||||
|
||||
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 %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 $xdisplay;
|
||||
my %keyboardmap;
|
||||
my $sysconfigdir = "/etc";
|
||||
|
@ -185,8 +185,8 @@ sub open_client_windows(@) {
|
|||
$servers{$server}{realname} = $realname;
|
||||
$servers{$server}{username} = $self->config->{user};
|
||||
$servers{$server}{username} = $username if ($username);
|
||||
$servers{$server}{username} = $username || '';
|
||||
$servers{$server}{port} = $port || '';
|
||||
$servers{$server}{username} = $username || '';
|
||||
$servers{$server}{port} = $port || '';
|
||||
$servers{$server}{master} = $self->config->{mstr} || '';
|
||||
$servers{$server}{master} = $master if ($master);
|
||||
|
||||
|
@ -348,8 +348,7 @@ sub add_host_by_name() {
|
|||
if ( $menus{host_entry} ) {
|
||||
$self->debug( 2, "host=", $menus{host_entry} );
|
||||
my @names
|
||||
= $self->parent->resolve_names(
|
||||
split( /\s+/, $menus{host_entry} ) );
|
||||
= $self->parent->resolve_names( split( /\s+/, $menus{host_entry} ) );
|
||||
$self->debug( 0, 'Opening to: ', join( ' ', @names ) ) if (@names);
|
||||
$self->open_client_windows(@names);
|
||||
}
|
||||
|
@ -357,7 +356,7 @@ sub add_host_by_name() {
|
|||
if ( defined $menus{listbox} && $menus{listbox}->curselection() ) {
|
||||
my @hosts = $menus{listbox}->get( $menus{listbox}->curselection() );
|
||||
$self->debug( 2, "host=", join( ' ', @hosts ) );
|
||||
$self->open_client_windows( $self->parent->resolve_names(@hosts) );
|
||||
$self->open_client_windows( $self->resolve_names(@hosts) );
|
||||
}
|
||||
|
||||
$self->build_hosts_menu();
|
||||
|
@ -436,9 +435,8 @@ sub load_keyboard_map() {
|
|||
|
||||
# keyboard layout contains the keycode at $modifier level
|
||||
if (defined(
|
||||
$keyboardmap{
|
||||
$keycodetosym{ $keyboard[$i][$modifier] }
|
||||
}
|
||||
$keyboardmap{ $keycodetosym{ $keyboard[$i][$modifier]
|
||||
} }
|
||||
)
|
||||
)
|
||||
{
|
||||
|
@ -603,7 +601,7 @@ sub substitute_macros {
|
|||
}
|
||||
{
|
||||
my $macro_hostname = $self->config->{macro_hostname};
|
||||
my $hostname = $self->config->{hostname_override} || hostname();
|
||||
my $hostname = hostfqdn();
|
||||
$text =~ s!$macro_hostname!$hostname!xsmg;
|
||||
$ENV{CSSH_HOSTNAME} = $hostname;
|
||||
}
|
||||
|
@ -629,48 +627,46 @@ sub substitute_macros {
|
|||
$ENV{CSSH_CONNECTION_PORT} = $servers{$svr}{port};
|
||||
|
||||
# Set up environment variables in the macro environment
|
||||
for my $i (qw/ 1 2 3 4 /) {
|
||||
my $macro_user_command = 'macro_user_' . $i . '_command';
|
||||
my $macro_user = $self->config->{ 'macro_user_' . $i };
|
||||
for my $i (qw/ 1 2 3 4 / ) {
|
||||
my $macro_user_command = 'macro_user_'.$i.'_command';
|
||||
my $macro_user = $self->config->{'macro_user_'.$i};
|
||||
|
||||
next unless $text =~ $macro_user;
|
||||
if ( !$self->config->{$macro_user_command} ) {
|
||||
if( ! $self->config->{ $macro_user_command } ) {
|
||||
$text =~ s/$macro_user//xsmg;
|
||||
next;
|
||||
}
|
||||
|
||||
my $cmd = $self->config->{$macro_user_command};
|
||||
my $cmd = $self->config->{ $macro_user_command };
|
||||
|
||||
local $SIG{CHLD} = undef;
|
||||
|
||||
my $stderr_fh = gensym;
|
||||
my $stdout_fh = gensym;
|
||||
my $child_pid = eval { open3( undef, $stdout_fh, $stderr_fh, $cmd ) };
|
||||
my $child_pid = eval { open3(undef, $stdout_fh, $stderr_fh, $cmd) };
|
||||
|
||||
if ( my $err = $@ ) {
|
||||
|
||||
# error message is hardcoded into open3 - tidy it up a little for our users
|
||||
$err =~ s/ at .*//;
|
||||
$err =~ s/open3: //;
|
||||
if (my $err=$@) {
|
||||
# error message is hardcoded into open3 - tidy it up a little for our users
|
||||
$err=~ s/ at .*//;
|
||||
$err=~ s/open3: //;
|
||||
$err =~ s/( failed)/' $1/;
|
||||
$err =~ s/(exec of) /$1 '/;
|
||||
warn "Macro failure for '$macro_user_command': $err";
|
||||
next;
|
||||
}
|
||||
waitpid( $child_pid, 0 );
|
||||
waitpid($child_pid, 0);
|
||||
my $cmd_rc = $? >> 8;
|
||||
|
||||
my @stdout = <$stdout_fh>;
|
||||
my @stderr = <$stderr_fh>;
|
||||
|
||||
if ( $cmd_rc > 0 || @stderr ) {
|
||||
warn "Macro failure for '$macro_user_command'", $/;
|
||||
if ( $cmd_rc > 0 || @stderr ){
|
||||
warn "Macro failure for '$macro_user_command'",$/;
|
||||
warn "Exited with error output:: @stderr" if @stderr;
|
||||
warn "Exited with non-zero return code: $cmd_rc", $/ if $cmd_rc;
|
||||
}
|
||||
else {
|
||||
} else {
|
||||
#$self->send_text_to_all_servers( $stdout );
|
||||
return join( '', @stdout );
|
||||
return join('', @stdout);
|
||||
}
|
||||
}
|
||||
|
||||
|
@ -1208,8 +1204,7 @@ sub setup_repeat() {
|
|||
|
||||
for ($cmd) {
|
||||
if (m/^open$/) {
|
||||
my @new_hosts
|
||||
= $self->parent->resolve_names(@tags);
|
||||
my @new_hosts = $self->resolve_names(@tags);
|
||||
$self->open_client_windows(@new_hosts);
|
||||
$self->build_hosts_menu();
|
||||
last;
|
||||
|
@ -1280,18 +1275,11 @@ sub setup_repeat() {
|
|||
### Window and menu definitions ###
|
||||
|
||||
sub create_windows() {
|
||||
my ($self) = @_;
|
||||
my ($screen_height) = $xdisplay->{height_in_pixels};
|
||||
my ($screen_width) = $xdisplay->{width_in_pixels};
|
||||
my ($self) = @_;
|
||||
$self->debug( 2, "create_windows: started" );
|
||||
|
||||
$windows{main_window}
|
||||
= MainWindow->new( -title => "ClusterSSH", -class => 'cssh', );
|
||||
if ( $screen_height * $screen_width >= 8294400 ) # display 4k or bigger
|
||||
{
|
||||
$windows{main_window}->optionAdd( '*font', 'Nimbus 14' )
|
||||
; # better for 4k displays
|
||||
}
|
||||
$windows{main_window}->withdraw; # leave withdrawn until needed
|
||||
|
||||
if ( defined( $self->config->{console_position} )
|
||||
|
@ -1570,7 +1558,7 @@ sub key_event {
|
|||
my $keycode = $Tk::event->k;
|
||||
my $keysymdec = $Tk::event->N;
|
||||
my $keysym = $Tk::event->K;
|
||||
my $state = $Tk::event->s || 0;
|
||||
my $state = $Tk::event->s || 0;
|
||||
|
||||
$menus{entrytext} = "";
|
||||
|
||||
|
|
46
t/02base.t
46
t/02base.t
|
@ -21,10 +21,10 @@ diag('testing output') if ( $ENV{TEST_VERBOSE} );
|
|||
trap {
|
||||
$base->stdout_output('testing');
|
||||
};
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got correct number of print lines' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got correct number of print lines' );
|
||||
like( $trap->stdout, qr/\Atesting\n\Z/xsm,
|
||||
'checking for expected print output' );
|
||||
|
||||
|
@ -68,10 +68,10 @@ trap {
|
|||
$base = App::ClusterSSH::Base->new( debug => 6, );
|
||||
};
|
||||
isa_ok( $base, 'App::ClusterSSH::Base' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
|
||||
like(
|
||||
$trap->stdout,
|
||||
qr/^Setting\slanguage\sto\s"en"/xsm,
|
||||
|
@ -83,10 +83,10 @@ trap {
|
|||
$base = App::ClusterSSH::Base->new( debug => 6, lang => 'en' );
|
||||
};
|
||||
isa_ok( $base, 'App::ClusterSSH::Base' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
|
||||
like(
|
||||
$trap->stdout,
|
||||
qr/^Setting\slanguage\sto\s"en"/xsm,
|
||||
|
@ -98,10 +98,10 @@ trap {
|
|||
$base = App::ClusterSSH::Base->new( debug => 6, lang => 'rubbish' );
|
||||
};
|
||||
isa_ok( $base, 'App::ClusterSSH::Base' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
|
||||
like(
|
||||
$trap->stdout,
|
||||
qr/^Setting\slanguage\sto\s"rubbish"/xsm,
|
||||
|
@ -114,10 +114,10 @@ trap {
|
|||
$base = App::ClusterSSH::Base->new( debug => 7, );
|
||||
};
|
||||
isa_ok( $base, 'App::ClusterSSH::Base' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 3, 'got new() debug output lines' );
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->stdout =~ tr/\n//, 3, 'got new() debug output lines' );
|
||||
like(
|
||||
$trap->stdout,
|
||||
qr/^Setting\slanguage\sto\s"en".Arguments\sto\sApp::ClusterSSH::Base->new.*debug\s=>\s7,$/xsm,
|
||||
|
@ -246,8 +246,8 @@ trap {
|
|||
is( $trap->leaveby, 'die', 'died ok' );
|
||||
isa_ok( $trap->die, 'App::ClusterSSH::Exception',
|
||||
'Caught exception object OK' );
|
||||
is( $trap->die, q{"type" arg not passed}, 'missing type arg die message' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
is( $trap->die, q{"type" arg not passed}, 'missing type arg die message' );
|
||||
is( $trap->stderr, '', 'Expecting no STDERR' );
|
||||
|
||||
my $get_options;
|
||||
|
||||
|
@ -341,7 +341,7 @@ trap {
|
|||
# $trap->quiet("No errors getting 'sort'");
|
||||
is( $trap->leaveby, 'return', 'returned ok' );
|
||||
is( $trap->die, undef, 'returned ok' );
|
||||
is( ref($sort), 'CODE', "got results from sort" );
|
||||
is( ref($sort), 'CODE', "got results from sort" );
|
||||
@sorted = $sort->( 4, 8, 1, 5, 3 );
|
||||
@expected = ( 1, 3, 4, 5, 8 );
|
||||
is_deeply( \@sorted, \@expected, "simple sort results okay" );
|
||||
|
|
|
@ -188,7 +188,7 @@ is( $trap->stderr, '', 'Expecting no STDERR' );
|
|||
is( $trap->die, undef, 'Expecting no die message' );
|
||||
is( $getopts->option1, 8, 'default value overridden' );
|
||||
|
||||
@ARGV = ( '--option1', '--option2', 'string', '--option3', '10' );
|
||||
@ARGV = ( '--option1', '--option2', 'string', '--option3', '10' );
|
||||
$getopts = App::ClusterSSH::Getopt->new( parent => $mock_object );
|
||||
trap {
|
||||
$getopts->add_option( spec => 'hidden', hidden => 1, no_acessor => 1, );
|
||||
|
@ -295,7 +295,7 @@ $getopts->add_option(
|
|||
default => 'default string'
|
||||
);
|
||||
$getopts->add_option( spec => 'another_long_opt|n=i', );
|
||||
$getopts->add_option( spec => 'a=s', help => 'short option only', );
|
||||
$getopts->add_option( spec => 'a=s', help => 'short option only', );
|
||||
$getopts->add_option( spec => 'long', help => 'long option only', );
|
||||
trap {
|
||||
$getopts->getopts;
|
||||
|
@ -380,8 +380,8 @@ is( $mock_object->{show_history}, 0, 'show_history set right' );
|
|||
is( $mock_object->{use_all_a_records}, 1, 'use_all_a_records set right' );
|
||||
|
||||
@ARGV = (
|
||||
'--unique-servers', '--title', 'title', '-p', '22', '--autoquit',
|
||||
'--tile', '--show-history', '-A',
|
||||
'--unique-servers', '--title', 'title', '-p', '22', '--autoquit',
|
||||
'--tile', '--show-history', '-A',
|
||||
);
|
||||
$getopts = App::ClusterSSH::Getopt->new( parent => $mock_object, );
|
||||
trap {
|
||||
|
@ -425,7 +425,7 @@ TODO: {
|
|||
is( $trap->die, undef, 'Expecting no die message' );
|
||||
}
|
||||
|
||||
@ARGV = ( '--rows', 5, '--cols', 10 );
|
||||
@ARGV = ( '--rows', 5, '--cols', 10 );
|
||||
$getopts = App::ClusterSSH::Getopt->new( parent => $mock_object, );
|
||||
trap {
|
||||
$getopts->getopts;
|
||||
|
|
|
@ -754,7 +754,7 @@ is( $trap->leaveby, 'return', 'returned ok' );
|
|||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stdout, '', 'No unexpected STDOUT' );
|
||||
isa_ok( $host, "App::ClusterSSH::Host" );
|
||||
is( $host, 'ssh_test', 'stringify works' );
|
||||
is( $host, 'ssh_test', 'stringify works' );
|
||||
is( $host->check_ssh_hostname, 0, 'check_ssh_hostname ok for ssh_test', );
|
||||
|
||||
trap {
|
||||
|
@ -767,9 +767,9 @@ is( $trap->leaveby, 'return', 'returned ok' );
|
|||
is( $trap->die, undef, 'returned ok' );
|
||||
is( $trap->stdout, '', 'No unexpected STDOUT' );
|
||||
isa_ok( $host, "App::ClusterSSH::Host" );
|
||||
is( $host, 'ssh_test', 'stringify works' );
|
||||
is( $host, 'ssh_test', 'stringify works' );
|
||||
is( $host->check_ssh_hostname, 0, 'check_ssh_hostname ok for ssh_test', );
|
||||
is( $host->get_type, q{}, 'hostname type is correct for ssh_test', );
|
||||
is( $host->get_type, q{}, 'hostname type is correct for ssh_test', );
|
||||
|
||||
for my $ssh_file (qw/ 10host_ssh_config 10host_ssh_include/) {
|
||||
my @hosts = (
|
||||
|
|
|
@ -18,7 +18,7 @@ BEGIN {
|
|||
use Test::More;
|
||||
use Test::Trap;
|
||||
use File::Which qw(which);
|
||||
use File::Temp qw(tempdir);
|
||||
use File::Temp qw(tempdir);
|
||||
use Test::Differences;
|
||||
|
||||
use Readonly;
|
||||
|
@ -101,8 +101,6 @@ Readonly::Hash my %default_config => {
|
|||
history_width => 40,
|
||||
history_height => 10,
|
||||
|
||||
hostname_override => '',
|
||||
|
||||
command => q{},
|
||||
command_pre => q{},
|
||||
command_post => q{},
|
||||
|
@ -537,7 +535,7 @@ SKIP: {
|
|||
chmod( 0755, $ENV{HOME} . '/.csshrc.DISABLED', $ENV{HOME} );
|
||||
}
|
||||
|
||||
note('check failure to write default config is caught when loading config');
|
||||
note('check failure to write default config is caught');
|
||||
$ENV{HOME} = tempdir( CLEANUP => 1 );
|
||||
mkdir( $ENV{HOME} . '/.clusterssh' );
|
||||
mkdir( $ENV{HOME} . '/.clusterssh/config' );
|
||||
|
@ -582,7 +580,6 @@ fillscreen=no
|
|||
hide_menu=0
|
||||
history_height=10
|
||||
history_width=40
|
||||
hostname_override=
|
||||
key_addhost=Control-Shift-plus
|
||||
key_clientname=Alt-n
|
||||
key_history=Alt-h
|
||||
|
|
|
@ -12,7 +12,7 @@ use lib "$Bin/../lib";
|
|||
use Test::More;
|
||||
use Test::Trap;
|
||||
use File::Which qw(which);
|
||||
use File::Temp qw(tempdir);
|
||||
use File::Temp qw(tempdir);
|
||||
|
||||
use Readonly;
|
||||
|
||||
|
@ -81,7 +81,7 @@ trap {
|
|||
is( $trap->leaveby, 'die', 'returned ok' );
|
||||
is( $trap->stdout, q{}, 'Expecting no STDOUT' );
|
||||
is( $trap->stderr, q{}, 'Expecting no STDERR' );
|
||||
is( $trap->die, q{Config 'method_args' not provided}, 'missing arg' );
|
||||
is( $trap->die, q{Config 'method_args' not provided}, 'missing arg' );
|
||||
|
||||
$mock_config->{method_args} = 'rubbish';
|
||||
$mock_config->{command} = 'echo';
|
||||
|
|
|
@ -3,6 +3,6 @@
|
|||
# small 'fake' script to allow xterm to be found when performing tests
|
||||
# on systems that do not have it
|
||||
|
||||
warn "$_=$ENV{$_}", $/ for ( sort keys %ENV ) if ( $ENV{TEST_VERBOSE} );
|
||||
warn "$_=$ENV{$_}",$/ for (sort keys %ENV) if ( $ENV{TEST_VERBOSE} );;
|
||||
|
||||
exit 0
|
||||
|
|
|
@ -30,7 +30,7 @@ if ( $opt->{x} ) {
|
|||
|
||||
# '-L' means list out available tags
|
||||
if ( $opt->{L} ) {
|
||||
print join( ' ', sort keys %tag_lookup ), $/;
|
||||
print join(' ', sort keys %tag_lookup), $/;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
|
|
|
@ -2,10 +2,18 @@ use strict;
|
|||
use warnings;
|
||||
use Test::More;
|
||||
|
||||
eval "use Test::Pod::Coverage 1.00";
|
||||
plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage"
|
||||
# Ensure a recent version of Test::Pod::Coverage
|
||||
my $min_tpc = 1.08;
|
||||
eval "use Test::Pod::Coverage $min_tpc";
|
||||
plan skip_all =>
|
||||
"Test::Pod::Coverage $min_tpc required for testing POD coverage"
|
||||
if $@;
|
||||
|
||||
plan skip_all => "Skipping coverage tests" unless $ENV{COVERAGE};
|
||||
# Test::Pod::Coverage doesn't require a minimum Pod::Coverage version,
|
||||
# but older versions don't recognize some common documentation styles
|
||||
my $min_pc = 0.18;
|
||||
eval "use Pod::Coverage $min_pc";
|
||||
plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage"
|
||||
if $@;
|
||||
|
||||
all_pod_coverage_ok();
|
||||
|
|
26
t/range.t
26
t/range.t
|
@ -13,19 +13,19 @@ require_ok('App::ClusterSSH::Range')
|
|||
|| BAIL_OUT('Failed to use App::ClusterSSH::Range');
|
||||
|
||||
my %tests = (
|
||||
'a' => 'a',
|
||||
'c{a,b}' => 'ca cb',
|
||||
'd{a,b,c}' => 'da db dc',
|
||||
'e{0}' => 'e0',
|
||||
'f{0..3}' => 'f0 f1 f2 f3',
|
||||
'g{0..2,4}' => 'g0 g1 g2 g4',
|
||||
'h{0..2,4..6}' => 'h0 h1 h2 h4 h5 h6',
|
||||
'i{0..1,a}' => 'i0 i1 ia',
|
||||
'j{0..2,a,b,c}' => 'j0 j1 j2 ja jb jc',
|
||||
'k{4..6,a..c}' => 'k4 k5 k6 ka kb kc',
|
||||
'l{0..2,7..9,e..g}' => 'l0 l1 l2 l7 l8 l9 le lf lg',
|
||||
'm{0,1}' => 'm0 m1',
|
||||
'n0..2}' => 'n0..2}',
|
||||
'a' => 'a',
|
||||
'c{a,b}' => 'ca cb',
|
||||
'd{a,b,c}' => 'da db dc',
|
||||
'e{0}' => 'e0',
|
||||
'f{0..3}' => 'f0 f1 f2 f3',
|
||||
'g{0..2,4}' => 'g0 g1 g2 g4',
|
||||
'h{0..2,4..6}' => 'h0 h1 h2 h4 h5 h6',
|
||||
'i{0..1,a}' => 'i0 i1 ia',
|
||||
'j{0..2,a,b,c}' => 'j0 j1 j2 ja jb jc',
|
||||
'k{4..6,a..c}' => 'k4 k5 k6 ka kb kc',
|
||||
'l{0..2,7..9,e..g}' => 'l0 l1 l2 l7 l8 l9 le lf lg',
|
||||
'm{0,1}' => 'm0 m1',
|
||||
'n0..2}' => 'n0..2}',
|
||||
'host{a,b}-test{1,2}' =>
|
||||
'hosta-test1 hosta-test2 hostb-test1 hostb-test2',
|
||||
|
||||
|
|
Loading…
Add table
Reference in a new issue