amassivus/clusterssh
1
0
Fork 0
mirror of https://github.com/duncs/clusterssh.git synced 2025-07-03 09:53:23 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Ensure code is run through 'perltidy -pbp -nst -nse'

Browse source
This commit is contained in:
Duncan Ferguson 2014-09-19 23:33:08 +01:00
parent d9446aa28a
commit f8ed9da353
13 changed files with 184 additions and 156 deletions
Download patch file Download diff file Expand all files Collapse all files

7
Build.PL
View file

@ -83,15 +83,14 @@ my $build = $class->new(
'Test::Differences' => 0, 'Test::Differences' => 0,
'CPAN::Changes' => 0.27, 'CPAN::Changes' => 0.27,
'File::Slurp' => 0, 'File::Slurp' => 0,
'Test::PerlTidy' => 0,
}, },
configure_requires => { 'Module::Build' => 0, }, configure_requires => { 'Module::Build' => 0, },
add_to_cleanup => ['App-ClusterSSH-*'], add_to_cleanup => ['App-ClusterSSH-*'],
create_makefile_pl => 'traditional', create_makefile_pl => 'traditional',
script_files => 'bin', script_files => 'bin',
get_options => { changes => { type => '=s' }, }, get_options => { changes => { type => '=s' }, },
PL_files => { PL_files => { 'bin_PL/_build_docs' => [], },
'bin_PL/_build_docs' => [],
},
); );
$build->create_build_script; $build->create_build_script;

2
MANIFEST
View file

@ -46,5 +46,7 @@ t/external_cluster_command
THANKS THANKS
t/manifest.t t/manifest.t
TODO TODO
t/perltidy.t
t/perltidyrc
t/pod-coverage.t t/pod-coverage.t
t/pod.t t/pod.t

59
Makefile.PL
View file

@ -1,36 +1,27 @@
# Note: this file was auto-generated by Module::Build::Compat version 0.4003 # Note: this file was auto-generated by Module::Build::Compat version 0.4003
use ExtUtils::MakeMaker; use ExtUtils::MakeMaker;
WriteMakefile WriteMakefile(
( 'NAME' => 'App::ClusterSSH',
'NAME' => 'App::ClusterSSH', 'VERSION_FROM' => 'lib/App/ClusterSSH.pm',
'VERSION_FROM' => 'lib/App/ClusterSSH.pm', 'PREREQ_PM' => {
'PREREQ_PM' => { 'CPAN::Changes' => '0.27',
'CPAN::Changes' => '0.27', 'Exception::Class' => '1.31',
'Exception::Class' => '1.31', 'File::Slurp' => 0,
'File::Slurp' => 0, 'File::Temp' => 0,
'File::Temp' => 0, 'File::Which' => 0,
'File::Which' => 0, 'Locale::Maketext' => 0,
'Locale::Maketext' => 0, 'Readonly' => 0,
'Readonly' => 0, 'Test::Differences' => 0,
'Test::Differences' => 0, 'Test::DistManifest' => 0,
'Test::DistManifest' => 0, 'Test::Pod' => 0,
'Test::Pod' => 0, 'Test::Pod::Coverage' => 0,
'Test::Pod::Coverage' => 0, 'Test::Trap' => 0,
'Test::Trap' => 0, 'Tk' => '800.022',
'Tk' => '800.022', 'Try::Tiny' => 0,
'Try::Tiny' => 0, 'X11::Protocol' => '0.56',
'X11::Protocol' => '0.56', 'version' => '0'
'version' => '0' },
}, 'INSTALLDIRS' => 'site',
'INSTALLDIRS' => 'site', 'EXE_FILES' => [ 'bin/ccon', 'bin/crsh', 'bin/cssh', 'bin/ctel' ],
'EXE_FILES' => [ 'PL_FILES' => { 'bin_PL/_build_docs' => [] }
'bin/ccon', );
'bin/crsh',
'bin/cssh',
'bin/ctel'
],
'PL_FILES' => {
'bin_PL/_build_docs' => []
}
)
;

8
lib/App/ClusterSSH.pm
View file

@ -518,7 +518,7 @@ sub send_text($@) {
my $macro_servername = $self->config->{macro_servername}; my $macro_servername = $self->config->{macro_servername};
my $servername = $svr; my $servername = $svr;
$servername =~ s/\s+//; $servername =~ s/\s+//;
$text =~ s/$macro_servername/$servername/xsmg; $text =~ s/$macro_servername/$servername/xsmg;
} }
$text =~ s/%h/hostname()/xsmeg; $text =~ s/%h/hostname()/xsmeg;
@ -592,7 +592,7 @@ sub send_text_to_all_servers {
} }
sub send_variable_text_to_all_servers($&) { sub send_variable_text_to_all_servers($&) {
my($self, $code) = @_; my ( $self, $code ) = @_;
foreach my $svr ( keys(%servers) ) { foreach my $svr ( keys(%servers) ) {
$self->send_text( $svr, $code->($svr) ) $self->send_text( $svr, $code->($svr) )
@ -1881,8 +1881,8 @@ sub populate_send_menu {
-label => 'Random Number', -label => 'Random Number',
-command => sub { -command => sub {
$self->send_variable_text_to_all_servers( $self->send_variable_text_to_all_servers(
sub { int(rand(1024)) } sub { int( rand(1024) ) } ),
), ;
}, },
); );
} }

19
lib/App/ClusterSSH/Cluster.pm
View file

@ -51,9 +51,8 @@ sub get_tag_entries {
sub list_external_clusters { sub list_external_clusters {
my ( $self, ) = @_; my ( $self, ) = @_;
my @list = $self->_run_external_clusters('-L'); my @list = $self->_run_external_clusters('-L');
return return wantarray
wantarray
? sort @list ? sort @list
: scalar @list; : scalar @list;
} }
@ -69,8 +68,12 @@ sub _run_external_clusters {
my $external_command = $self->parent->config->{external_cluster_command}; my $external_command = $self->parent->config->{external_cluster_command};
if(!$external_command || ! -x $external_command) { if ( !$external_command || !-x $external_command ) {
$self->debug( 1, 'Cannot run external cluster command: ', $external_command || ''); $self->debug(
1,
'Cannot run external cluster command: ',
$external_command || ''
);
return; return;
} }
@ -184,8 +187,7 @@ sub get_tag {
join( ' ', sort @{ $self->{tags}->{$tag} } ) join( ' ', sort @{ $self->{tags}->{$tag} } )
); );
return return wantarray
wantarray
? sort @{ $self->{tags}->{$tag} } ? sort @{ $self->{tags}->{$tag} }
: scalar @{ $self->{tags}->{$tag} }; : scalar @{ $self->{tags}->{$tag} };
} }
@ -196,8 +198,7 @@ sub get_tag {
sub list_tags { sub list_tags {
my ($self) = @_; my ($self) = @_;
return return wantarray
wantarray
? sort keys( %{ $self->{tags} } ) ? sort keys( %{ $self->{tags} } )
: scalar keys( %{ $self->{tags} } ); : scalar keys( %{ $self->{tags} } );
} }

63
lib/App/ClusterSSH/Getopt.pm
View file

@ -212,7 +212,9 @@ sub add_common_options {
); );
$self->add_option( $self->add_option(
spec => 'unique-servers|u', spec => 'unique-servers|u',
help => $self->loc('Toggle connecting to each host only once when a hostname has been specified multiple times.'), help => $self->loc(
'Toggle connecting to each host only once when a hostname has been specified multiple times.'
),
); );
$self->add_option( $self->add_option(
spec => 'use-all-a-records|A', spec => 'use-all-a-records|A',
@ -271,7 +273,7 @@ sub getopts {
pod2usage( -verbose => 1 ) if ( $options->{'h'} || $options->{help} ); pod2usage( -verbose => 1 ) if ( $options->{'h'} || $options->{help} );
pod2usage( -verbose => 2 ) if ( $options->{H} || $options->{man} ); pod2usage( -verbose => 2 ) if ( $options->{H} || $options->{man} );
# record what was given on the command line in case this # record what was given on the command line in case this
# object is ever dumped out # object is ever dumped out
$self->{options_parsed} = $options; $self->{options_parsed} = $options;
@ -302,12 +304,13 @@ sub getopts {
no warnings 'redefine'; no warnings 'redefine';
*$accessor = sub { *$accessor = sub {
return $options->{$acc} || $default; return $options->{$acc} || $default;
# defined $options->{$acc} ? $options->{$acc}
# : defined $self->{command_options}->{$acc}->{default} # defined $options->{$acc} ? $options->{$acc}
# ? $self->{command_options}->{$acc}->{default} # : defined $self->{command_options}->{$acc}->{default}
# : undef; # ? $self->{command_options}->{$acc}->{default}
# : undef;
}; };
my $accessor_default=$accessor.'_default'; my $accessor_default = $accessor . '_default';
*$accessor_default = sub { return $default; }; *$accessor_default = sub { return $default; };
} }
} }
@ -326,14 +329,14 @@ sub getopts {
= !$self->parent->config->{unique_servers} || 0; = !$self->parent->config->{unique_servers} || 0;
} }
$self->parent->config->{title} = $self->title if ( $self->title ); $self->parent->config->{title} = $self->title if ( $self->title );
$self->parent->config->{port} = $self->port if ( $self->port ); $self->parent->config->{port} = $self->port if ( $self->port );
# note, need to check if these actions can be performed as they are # note, need to check if these actions can be performed as they are
# not common acorss all communiction methods # not common acorss all communiction methods
$self->parent->config->{command} = $self->action $self->parent->config->{command} = $self->action
if ( $self->can('action') && $self->action ); if ( $self->can('action') && $self->action );
$self->parent->config->{user} = $self->username $self->parent->config->{user} = $self->username
if ( $self->can('username') && $self->username ); if ( $self->can('username') && $self->username );
$self->parent->config->{terminal_font} = $self->font if ( $self->font ); $self->parent->config->{terminal_font} = $self->font if ( $self->font );
@ -361,7 +364,7 @@ sub getopts {
sub output { sub output {
my (@text) = @_; my (@text) = @_;
confess if( exists $text[1] && !$text[1]); confess if ( exists $text[1] && !$text[1] );
print @text, $/, $/; print @text, $/, $/;
} }
@ -395,7 +398,8 @@ This tool is intended for (but not limited to) cluster administration where the
Connections are opened using [_1] which must be correctly installed and configured. Connections are opened using [_1] which must be correctly installed and configured.
Extra caution should be taken when editing files as lines may not necessarily be in the same order; assuming line 5 is the same across all servers and modifying that is dangerous. It's better to search for the specific line to be changed and double-check all terminals are as expected before changes are committed.}, $self->parent->config->{comms} Extra caution should be taken when editing files as lines may not necessarily be in the same order; assuming line 5 is the same across all servers and modifying that is dangerous. It's better to search for the specific line to be changed and double-check all terminals are as expected before changes are committed.},
$self->parent->config->{comms}
); );
output '=head2 ', $self->loc('Further Notes'); output '=head2 ', $self->loc('Further Notes');
@ -431,8 +435,9 @@ Extra caution should be taken when editing files as lines may not necessarily be
[_1] [_1]
This will test the mechanisms used to open windows to hosts. This could be due to either the [_2] terminal option which enables [_3] (some terminals do not require this option, other terminals have another method for enabling it - see your terminal documentation) or the configuration of [_4].}, This will test the mechanisms used to open windows to hosts. This could be due to either the [_2] terminal option which enables [_3] (some terminals do not require this option, other terminals have another method for enabling it - see your terminal documentation) or the configuration of [_4].},
"C<< $Script -e {single host name} >>", 'C<-xrm>', 'C<AllowSendEvents>', "C<< $Script -e {single host name} >>", 'C<-xrm>',
'C<'.$self->parent->config->{comms}.'>', 'C<AllowSendEvents>',
'C<' . $self->parent->config->{comms} . '>',
); );
output '=back'; output '=back';
@ -490,39 +495,37 @@ would replace the <Alt-n> with the client's name in each window.}
); );
output '=item ', $self->parent->config->{key_localname}; output '=item ', $self->parent->config->{key_localname};
output $self->loc( output $self->loc(
q{Paste in the hostname of the server cssh is ebing run on} q{Paste in the hostname of the server cssh is ebing run on});
);
output '=item ', $self->parent->config->{key_quit}; output '=item ', $self->parent->config->{key_quit};
output $self->loc( output $self->loc(
'Quit the program and close all connections and windows.'); 'Quit the program and close all connections and windows.');
output '=item ', $self->parent->config->{key_retilehosts}; output '=item ', $self->parent->config->{key_retilehosts};
output $self->loc(q{Retile all the client windows.}); output $self->loc(q{Retile all the client windows.});
output '=item ', $self->parent->config->{key_username}; output '=item ', $self->parent->config->{key_username};
output $self->loc( output $self->loc(q{Paste in the username for the connection});
q{Paste in the username for the connection}
);
output '=back'; output '=back';
output '=head1 ' . $self->loc('EXAMPLES'); output '=head1 ' . $self->loc('EXAMPLES');
output '=over'; output '=over';
output '=item ', $self->loc(q{Open up a session to 3 servers}); output '=item ', $self->loc(q{Open up a session to 3 servers});
output q{S<$ }.$Script.q{ server1 server2 server3>}; output q{S<$ } . $Script . q{ server1 server2 server3>};
output '=item ', output '=item ',
$self->loc( $self->loc(
q{Open up a session to a cluster of servers identified by the tag 'farm1' and give the controlling window a specific title, where the tag is defined in one of the default configuration files} q{Open up a session to a cluster of servers identified by the tag 'farm1' and give the controlling window a specific title, where the tag is defined in one of the default configuration files}
); );
output q{S<$ }.$Script.q{ -T 'Web Farm Cluster 1' farm1>}; output q{S<$ } . $Script . q{ -T 'Web Farm Cluster 1' farm1>};
output '=item ', output '=item ',
$self->loc( $self->loc(
q{Connect to different servers using different login names. NOTE: this can also be achieved by setting up appropriate options in the configuration files. Do not close the console when the last terminal exits.} q{Connect to different servers using different login names. NOTE: this can also be achieved by setting up appropriate options in the configuration files. Do not close the console when the last terminal exits.}
); );
output q{S<$ }.$Script.q{ -Q user1@server1 admin@server2>}; output q{S<$ } . $Script . q{ -Q user1@server1 admin@server2>};
output '=item ', output '=item ',
$self->loc( $self->loc(
q{Open up a cluster defined in a non-default configuration file}); q{Open up a cluster defined in a non-default configuration file});
output q{S<$ }.$Script.q{ -c $HOME/cssh.extra_clusters db_cluster>}; output q{S<$ } . $Script . q{ -c $HOME/cssh.extra_clusters db_cluster>};
output '=item ', $self->loc(q{Connect on port 2022 instead of the default port}); output '=item ',
output q{S<$ }.$Script.q{ -p 2022 server1 server2>}; $self->loc(q{Connect on port 2022 instead of the default port});
output q{S<$ } . $Script . q{ -p 2022 server1 server2>};
output '=back'; output '=back';
output '=head1 ' . $self->loc('FILES'); output '=head1 ' . $self->loc('FILES');
@ -796,9 +799,7 @@ B<NOTE:> Any "generic" change to the method (e.g., specifying the ssh port to us
); );
output '=item use_hotkeys = 1'; output '=item use_hotkeys = 1';
output $self->loc( output $self->loc( q{Setting to [_1] will disable all hotkeys.}, 'C<0>' );
q{Setting to [_1] will disable all hotkeys.},
'C<0>' );
output '=item user = $LOGNAME'; output '=item user = $LOGNAME';
output $self->loc( output $self->loc(
@ -912,7 +913,8 @@ B<NOTE:> Any "generic" change to the method (e.g., specifying the ssh port to us
[_2] [_2]
This performs two tests to confirm cssh is able to work properly with the settings provided within the [_3] file (or internal defaults). This performs two tests to confirm cssh is able to work properly with the settings provided within the [_3] file (or internal defaults).
}, $Script, 'C<< '.$Script.' -e [user@]<hostname>[:port] >>', 'F<$HOME/.clusterssh/config>' }, $Script, 'C<< ' . $Script . ' -e [user@]<hostname>[:port] >>',
'F<$HOME/.clusterssh/config>'
); );
output '=over'; output '=over';
@ -921,7 +923,8 @@ This performs two tests to confirm cssh is able to work properly with the settin
q{Test the terminal window works with the options provided}); q{Test the terminal window works with the options provided});
output '=item 2'; output '=item 2';
output $self->loc( output $self->loc(
q{Test [_1] works to a host with the configured arguments}, $self->parent->config->{comms}); q{Test [_1] works to a host with the configured arguments},
$self->parent->config->{comms} );
output '=back'; output '=back';
output $self->loc(q{Configuration options to watch for in ssh are}); output $self->loc(q{Configuration options to watch for in ssh are});

12
lib/App/ClusterSSH/Helper.pm
View file

@ -22,7 +22,10 @@ sub new {
sub script { sub script {
my ( $self, $config ) = @_; my ( $self, $config ) = @_;
if(! defined $config || ! ref $config || ref $config ne "App::ClusterSSH::Config") { if ( !defined $config
|| !ref $config
|| ref $config ne "App::ClusterSSH::Config" )
{
croak( croak(
App::ClusterSSH::Exception::Helper->throw( App::ClusterSSH::Exception::Helper->throw(
error => 'No configuration provided or in wrong format', error => 'No configuration provided or in wrong format',
@ -30,9 +33,10 @@ sub script {
); );
} }
foreach my $arg ( "comms", $config->{comms}, $config->{comms} . '_args', 'command', 'auto_close' foreach my $arg ( "comms", $config->{comms}, $config->{comms} . '_args',
) { 'command', 'auto_close' )
if( !defined $config->{ $arg } ) { {
if ( !defined $config->{$arg} ) {
croak( croak(
App::ClusterSSH::Exception::Helper->throw( App::ClusterSSH::Exception::Helper->throw(
error => "Config '$arg' not provided", error => "Config '$arg' not provided",

28
lib/App/ClusterSSH/Host.pm
View file

@ -73,7 +73,7 @@ sub get_username {
sub get_type { sub get_type {
my ($self) = @_; my ($self) = @_;
if($self->check_ssh_hostname) { if ( $self->check_ssh_hostname ) {
return 'ssh_alias'; return 'ssh_alias';
} }
return $self->{type} || q{}; return $self->{type} || q{};
@ -165,7 +165,10 @@ sub parse_host_string {
{ {
$self->debug( $self->debug(
5, 5,
$self->loc( 'bracketed IPv6: u=[_1] h=[_2] p=[_3] g=[_4]', $1, $2, $3, $4 ), $self->loc(
'bracketed IPv6: u=[_1] h=[_2] p=[_3] g=[_4]',
$1, $2, $3, $4
),
); );
return __PACKAGE__->new( return __PACKAGE__->new(
parse_string => $parse_string, parse_string => $parse_string,
@ -188,8 +191,12 @@ sub parse_host_string {
}xms }xms
) )
{ {
$self->debug( 5, $self->debug(
$self->loc( 'std IPv4: u=[_1] h=[_2] p=[_3] g=[_4]', $1, $2, $3, $4 ), 5,
$self->loc(
'std IPv4: u=[_1] h=[_2] p=[_3] g=[_4]',
$1, $2, $3, $4
),
); );
return __PACKAGE__->new( return __PACKAGE__->new(
parse_string => $parse_string, parse_string => $parse_string,
@ -218,9 +225,9 @@ sub parse_host_string {
$geometry = $1; $geometry = $1;
} }
# Check for a '/nnnn' port definition # Check for a '/nnnn' port definition
if ( $host_string =~ s!(?:/(\d+)$)!! ) { if ( $host_string =~ s!(?:/(\d+)$)!! ) {
$port = $1; $port = $1;
} }
# use number of colons as a possible indicator # use number of colons as a possible indicator
@ -230,7 +237,7 @@ sub parse_host_string {
# if its 8 then assumed full IPv6 address with a port # if its 8 then assumed full IPv6 address with a port
# also catch localhost address here # also catch localhost address here
if ( $colon_count == 7 || $colon_count == 8 || $host_string eq '::1' ) { if ( $colon_count == 7 || $colon_count == 8 || $host_string eq '::1' ) {
if( $colon_count == 8) { if ( $colon_count == 8 ) {
$host_string =~ s/(?::(\d+?))$//; $host_string =~ s/(?::(\d+?))$//;
$port = $1; $port = $1;
} }
@ -251,8 +258,7 @@ sub parse_host_string {
); );
} }
if ( $colon_count > 1 if ( $colon_count > 1
&& $colon_count < 8 && $colon_count < 8 )
)
{ {
warn 'Ambiguous host string: "', $host_string, '"', $/; warn 'Ambiguous host string: "', $host_string, '"', $/;
warn 'Assuming you meant "[', $host_string, ']"?', $/; warn 'Assuming you meant "[', $host_string, ']"?', $/;
@ -260,8 +266,8 @@ sub parse_host_string {
$self->debug( $self->debug(
5, 5,
$self->loc( $self->loc(
'Ambiguous IPv6 u=[_1] h=[_2] p=[_3] g=[_4]', $username, 'Ambiguous IPv6 u=[_1] h=[_2] p=[_3] g=[_4]',
$host_string, $port, $geometry, $username, $host_string, $port, $geometry,
) )
); );

40
t/02base.t
View file

@ -21,10 +21,10 @@ diag('testing output') if ( $ENV{TEST_VERBOSE} );
trap { trap {
$base->output('testing'); $base->output('testing');
}; };
is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->leaveby, 'return', 'returned ok' );
is( $trap->die, undef, 'returned ok' ); is( $trap->die, undef, 'returned ok' );
is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stderr, '', 'Expecting no STDERR' );
is( $trap->stdout =~ tr/\n//, 1, 'got correct number of print lines' ); is( $trap->stdout =~ tr/\n//, 1, 'got correct number of print lines' );
like( $trap->stdout, qr/\Atesting\n\Z/xsm, like( $trap->stdout, qr/\Atesting\n\Z/xsm,
'checking for expected print output' ); 'checking for expected print output' );
@ -68,10 +68,10 @@ trap {
$base = App::ClusterSSH::Base->new( debug => 6, ); $base = App::ClusterSSH::Base->new( debug => 6, );
}; };
isa_ok( $base, 'App::ClusterSSH::Base' ); isa_ok( $base, 'App::ClusterSSH::Base' );
is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->leaveby, 'return', 'returned ok' );
is( $trap->die, undef, 'returned ok' ); is( $trap->die, undef, 'returned ok' );
is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stderr, '', 'Expecting no STDERR' );
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
like( like(
$trap->stdout, $trap->stdout,
qr/^Setting\slanguage\sto\s"en"/xsm, qr/^Setting\slanguage\sto\s"en"/xsm,
@ -83,10 +83,10 @@ trap {
$base = App::ClusterSSH::Base->new( debug => 6, lang => 'en' ); $base = App::ClusterSSH::Base->new( debug => 6, lang => 'en' );
}; };
isa_ok( $base, 'App::ClusterSSH::Base' ); isa_ok( $base, 'App::ClusterSSH::Base' );
is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->leaveby, 'return', 'returned ok' );
is( $trap->die, undef, 'returned ok' ); is( $trap->die, undef, 'returned ok' );
is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stderr, '', 'Expecting no STDERR' );
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
like( like(
$trap->stdout, $trap->stdout,
qr/^Setting\slanguage\sto\s"en"/xsm, qr/^Setting\slanguage\sto\s"en"/xsm,
@ -98,10 +98,10 @@ trap {
$base = App::ClusterSSH::Base->new( debug => 6, lang => 'rubbish' ); $base = App::ClusterSSH::Base->new( debug => 6, lang => 'rubbish' );
}; };
isa_ok( $base, 'App::ClusterSSH::Base' ); isa_ok( $base, 'App::ClusterSSH::Base' );
is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->leaveby, 'return', 'returned ok' );
is( $trap->die, undef, 'returned ok' ); is( $trap->die, undef, 'returned ok' );
is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stderr, '', 'Expecting no STDERR' );
is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' ); is( $trap->stdout =~ tr/\n//, 1, 'got new() debug output lines' );
like( like(
$trap->stdout, $trap->stdout,
qr/^Setting\slanguage\sto\s"rubbish"/xsm, qr/^Setting\slanguage\sto\s"rubbish"/xsm,
@ -113,10 +113,10 @@ trap {
$base = App::ClusterSSH::Base->new( debug => 7, ); $base = App::ClusterSSH::Base->new( debug => 7, );
}; };
isa_ok( $base, 'App::ClusterSSH::Base' ); isa_ok( $base, 'App::ClusterSSH::Base' );
is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->leaveby, 'return', 'returned ok' );
is( $trap->die, undef, 'returned ok' ); is( $trap->die, undef, 'returned ok' );
is( $trap->stderr, '', 'Expecting no STDERR' ); is( $trap->stderr, '', 'Expecting no STDERR' );
is( $trap->stdout =~ tr/\n//, 3, 'got new() debug output lines' ); is( $trap->stdout =~ tr/\n//, 3, 'got new() debug output lines' );
like( like(
$trap->stdout, $trap->stdout,
qr/^Setting\slanguage\sto\s"en".Arguments\sto\sApp::ClusterSSH::Base->new.*debug\s=>\s7,$/xsm, qr/^Setting\slanguage\sto\s"en".Arguments\sto\sApp::ClusterSSH::Base->new.*debug\s=>\s7,$/xsm,

35
t/10host.t
View file

@ -668,12 +668,9 @@ my %parse_tests = (
geometry => q{}, geometry => q{},
type => 'ipv6', type => 'ipv6',
}, },
'2001:0db8:8a2e:0370:7334:2001:0db8:8a2e:0370:7334:4535:3453:3453:3455' => { '2001:0db8:8a2e:0370:7334:2001:0db8:8a2e:0370:7334:4535:3453:3453:3455'
die => qr{Unable to parse hostname from}ms, => { die => qr{Unable to parse hostname from}ms, },
}, 'some random rubbish' => { die => qr{Unable to parse hostname from}ms, },
'some random rubbish' => {
die => qr{Unable to parse hostname from}ms,
},
); );
foreach my $ident ( keys(%parse_tests) ) { foreach my $ident ( keys(%parse_tests) ) {
@ -684,23 +681,32 @@ foreach my $ident ( keys(%parse_tests) ) {
if ( $parse_tests{$ident}{die} ) { if ( $parse_tests{$ident}{die} ) {
is( $trap->leaveby, 'die', $ident . ' died correctly' ); is( $trap->leaveby, 'die', $ident . ' died correctly' );
like( $trap->die, $parse_tests{$ident}{die}, $ident . ' died correctly' ); like(
$trap->die,
$parse_tests{$ident}{die},
$ident . ' died correctly'
);
next; next;
} }
is( $trap->leaveby, 'return', $ident . ' returned correctly' ); is( $trap->leaveby, 'return', $ident . ' returned correctly' );
is( $host, $parse_tests{$ident}{hostname}, 'stringify works on: '.$ident ); is( $host,
$parse_tests{$ident}{hostname},
'stringify works on: ' . $ident
);
isa_ok( $host, "App::ClusterSSH::Host" ); isa_ok( $host, "App::ClusterSSH::Host" );
for my $trap_type (qw/ die /) { for my $trap_type (qw/ die /) {
if ( ! $parse_tests{$ident}{$trap_type} ) { if ( !$parse_tests{$ident}{$trap_type} ) {
is( $trap->$trap_type, is( $trap->$trap_type,
$parse_tests{$ident}{$trap_type}, $parse_tests{$ident}{$trap_type},
"$ident $trap_type" "$ident $trap_type"
); );
} else { }
like( $trap->$trap_type, else {
like(
$trap->$trap_type,
$parse_tests{$ident}{$trap_type}, $parse_tests{$ident}{$trap_type},
"$ident $trap_type" "$ident $trap_type"
); );
@ -725,7 +731,6 @@ foreach my $ident ( keys(%parse_tests) ) {
is( $host->check_ssh_hostname, 0, $ident . ' not from ssh' ); is( $host->check_ssh_hostname, 0, $ident . ' not from ssh' );
} }
# check for a non-existant file # check for a non-existant file
trap { trap {
$host = App::ClusterSSH::Host->new( $host = App::ClusterSSH::Host->new(
@ -775,9 +780,9 @@ for my $hostname (
is( $host, $hostname, 'stringify works' ); is( $host, $hostname, 'stringify works' );
is( $host->check_ssh_hostname, 1, is( $host->check_ssh_hostname, 1,
'check_ssh_hostname ok for ' . $hostname ); 'check_ssh_hostname ok for ' . $hostname );
is( $host->get_realname, $hostname, 'realname set' ); is( $host->get_realname, $hostname, 'realname set' );
is( $host->get_geometry, q{}, 'geometry set' ); is( $host->get_geometry, q{}, 'geometry set' );
is( $host->get_type, 'ssh_alias', 'geometry set' ); is( $host->get_type, 'ssh_alias', 'geometry set' );
} }
done_testing(); done_testing();

36
t/20helper.t
View file

@ -14,7 +14,7 @@ use Readonly;
package App::ClusterSSH::Config; package App::ClusterSSH::Config;
sub new { sub new {
my ($class, %args) = @_; my ( $class, %args ) = @_;
my $self = {%args}; my $self = {%args};
return bless $self, $class; return bless $self, $class;
} }
@ -51,7 +51,7 @@ is( $trap->die, 'No configuration provided or in wrong format',
my $mock_config = App::ClusterSSH::Config->new(); my $mock_config = App::ClusterSSH::Config->new();
trap { trap {
$script = $helper->script( $mock_config ); $script = $helper->script($mock_config);
}; };
is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->leaveby, 'die', 'returned ok' );
is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' );
@ -62,16 +62,16 @@ is( $trap->die, q{Config 'comms' not provided}, 'missing arg' );
$mock_config->{comms} = 'method'; $mock_config->{comms} = 'method';
trap { trap {
$script = $helper->script( $mock_config ); $script = $helper->script($mock_config);
}; };
is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->leaveby, 'die', 'returned ok' );
is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' );
is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->stderr, q{}, 'Expecting no STDERR' );
is( $trap->die, q{Config 'method' not provided}, 'missing arg' ); is( $trap->die, q{Config 'method' not provided}, 'missing arg' );
$mock_config->{method} = 'binary'; $mock_config->{method} = 'binary';
trap { trap {
$script = $helper->script( $mock_config ); $script = $helper->script($mock_config);
}; };
is( $trap->leaveby, 'die', 'returned ok' ); is( $trap->leaveby, 'die', 'returned ok' );
is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' );
@ -79,22 +79,22 @@ 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->{method_args} = 'rubbish';
$mock_config->{command} = 'echo'; $mock_config->{command} = 'echo';
$mock_config->{auto_close} = 5; $mock_config->{auto_close} = 5;
trap { trap {
$script = $helper->script( $mock_config ); $script = $helper->script($mock_config);
}; };
is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->leaveby, 'return', 'returned ok' );
is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' );
is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->stderr, q{}, 'Expecting no STDERR' );
is( $trap->die, undef, 'not died' ); is( $trap->die, undef, 'not died' );
trap { trap {
eval { $script }; eval {$script};
}; };
is( $trap->leaveby, 'return', 'returned ok' ); is( $trap->leaveby, 'return', 'returned ok' );
is( $trap->stdout, q{}, 'Expecting no STDOUT' ); is( $trap->stdout, q{}, 'Expecting no STDOUT' );
is( $trap->stderr, q{}, 'Expecting no STDERR' ); is( $trap->stderr, q{}, 'Expecting no STDERR' );
is( $trap->die, undef, 'not died' ); is( $trap->die, undef, 'not died' );
done_testing(); done_testing();

15
t/30cluster.t
View file

@ -109,7 +109,8 @@ $expected{tag20} = [ 'host10', ];
$expected{tag30} = [ 'host10', ]; $expected{tag30} = [ 'host10', ];
$expected{tag40} = [ 'host20', 'host30', ]; $expected{tag40} = [ 'host20', 'host30', ];
$expected{tag50} = [ 'host30', ]; $expected{tag50} = [ 'host30', ];
$cluster1->read_tag_file( $Bin . '/30cluster.tag1' ); test_expected( 'tag 1', %expected ); $cluster1->read_tag_file( $Bin . '/30cluster.tag1' );
test_expected( 'tag 1', %expected );
$cluster1->read_cluster_file( $Bin . '/30cluster.file3' ); $cluster1->read_cluster_file( $Bin . '/30cluster.file3' );
my @default_expected = (qw/ host7 host8 host9 /); my @default_expected = (qw/ host7 host8 host9 /);
@ -158,17 +159,16 @@ my @external_expected;
# text fetching external clusters when no command set or runnable # text fetching external clusters when no command set or runnable
#$mock_object->{external_cluster_command} = '/tmp/doesnt_exist'; #$mock_object->{external_cluster_command} = '/tmp/doesnt_exist';
trap { trap {
@external_expected = $cluster1->_run_external_clusters(); @external_expected = $cluster1->_run_external_clusters();
}; };
is( $trap->leaveby, 'return', 'non-existant tag returns correctly' ); is( $trap->leaveby, 'return', 'non-existant tag returns correctly' );
is( $trap->stdout, '', 'no stdout for non-existant get_tag' ); is( $trap->stdout, '', 'no stdout for non-existant get_tag' );
is( $trap->stderr, '', 'no stderr for non-existant get_tag' ); is( $trap->stderr, '', 'no stderr for non-existant get_tag' );
is( $tags, undef, 'non-existant tag returns undef' ); is( $tags, undef, 'non-existant tag returns undef' );
@external_expected = $cluster1->list_external_clusters(); @external_expected = $cluster1->list_external_clusters();
is_deeply( \@external_expected, [], is_deeply( \@external_expected, [], 'External command doesnt exist' );
'External command doesnt exist' is( scalar $cluster1->list_external_clusters,
); 0, 'External command failed tag count' );
is( scalar $cluster1->list_external_clusters, 0, 'External command failed tag count');
$mock_object->{external_cluster_command} = "$Bin/external_cluster_command"; $mock_object->{external_cluster_command} = "$Bin/external_cluster_command";
@ -178,7 +178,8 @@ is_deeply(
[qw/ tag100 tag200 tag300 tag400 /], [qw/ tag100 tag200 tag300 tag400 /],
'External command no args' 'External command no args'
); );
is( scalar $cluster1->list_external_clusters, 4, 'External command tag count'); is( scalar $cluster1->list_external_clusters,
4, 'External command tag count' );
@external_expected = $cluster1->get_external_clusters(); @external_expected = $cluster1->get_external_clusters();
is_deeply( \@external_expected, [], 'External command no args' ); is_deeply( \@external_expected, [], 'External command no args' );

16
t/perltidy.t Normal file
View file

@ -0,0 +1,16 @@
#!perl -T
use strict;
use warnings;
use Test::More;
use FindBin qw($Bin);
eval "use Test::PerlTidy";
plan skip_all => "Test::PerlTidy required for testing code" if $@;
# Please see t/perltidyrc for the authors normal perltidy options
run_tests(
perltidyrc => $Bin . '/perltidyrc',
exclude => [ '_build/', 'blib/' ]
);