Improve test coverage

lib/App/ClusterSSH.pm

@@ -642,7 +642,7 @@ sub open_client_windows(@) {
         my $server = $server_object->get_hostname();
         my $master = $server_object->get_master();
 
-        my $given_server_name = $server_object->get_givenname();
+        my $given_server_name = $server_object->get_hostname();
 
         # see if we can find the hostname - if not, drop it
         my $realname = $server_object->get_realname();

lib/App/ClusterSSH/Base.pm

@@ -12,6 +12,7 @@ use Exception::Class (
     },
     'App::ClusterSSH::Exception::Cluster',
     'App::ClusterSSH::Exception::LoadFile',
+    'App::ClusterSSH::Exception::Helper',
 );
 
 # Don't use SVN revision as it can cause problems
@@ -85,10 +86,7 @@ sub loc {
 
 sub set_lang {
     my ( $self, $lang ) = @_;
-    $language = $lang;
+    $self->debug( 6, $self->loc( 'Setting language to "[_1]"', $lang ), );
-    if ($self) {
-        $self->debug( 6, $self->loc( 'Setting language to "[_1]"', $lang ), );
-    }
     return $self;
 }
 
@@ -184,10 +182,10 @@ sub load_file {
         );
     }
 
-    if ( !$args{type} || $args{type} !~ m/cluster|config/ ) {
+    if ( !$args{type} ) {
         croak(
             App::ClusterSSH::Exception->throw(
-                error => '"type" arg invalid'
+                error => '"type" arg not passed'
             )
         );
     }

lib/App/ClusterSSH/Helper.pm

@@ -22,6 +22,25 @@ sub new {
 sub script {
     my ( $self, $config ) = @_;
 
+    if(! defined $config || ref $config ne "HASH") {
+        croak(
+            App::ClusterSSH::Exception::Helper->throw(
+                error => 'No configuration provided or in wrong format',
+            ),
+        );
+    }
+
+    foreach my $arg ( "comms", $config->{comms}, $config->{comms} . '_args', 'command', 'auto_close'
+    ) {
+        if( !defined $config->{ $arg } ) {
+            croak(
+                App::ClusterSSH::Exception::Helper->throw(
+                    error => "Config '$arg' not provided",
+                ),
+            );
+        }
+    }
+
     my $comms          = $config->{ $config->{comms} };
     my $comms_args     = $config->{ $config->{comms} . '_args' };
     my $config_command = $config->{command};
@@ -33,57 +52,6 @@ sub script {
         : "echo Press RETURN to continue; read IGNORE"
         ;    # : "sleep $autoclose";
 
-#    # P = pipe file
-#    # s = server
-#    # u = username
-#    # p = port
-#    # m = ccon master
-#    # c = comms command
-#    # a = command args
-#    # C = command to run
-#    my $lelehelper_script = q{
-#        use strict;
-#        use warnings;
-#        use Getopt::Std;
-#        my %opts;
-#        getopts('PsupmcaC', \%opts);
-#        my $command="$opts{c} $opts{a}";
-#        open(PIPE, ">", $opts{P}) 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($opts{s} =~ m/==$/)
-#        {
-#            $opts{s} =~ s/==$//;
-#            warn("\nWARNING: failed to resolve IP address for $opts{s}.\n\n");
-#            sleep 5;
-#        }
-#        if($opts{m}) {
-#            unless("$comms" ne "console") {
-#                $opts{m} = $opts{m} ? "-M $opts{m} " : "";
-#                $opts{c} .= $opts{m};
-#            }
-#        }
-#        if($opts{u}) {
-#            unless("$comms" eq "telnet") {
-#                $opts{u} = $opts{u} ? "-l $opts{u} " : "";
-#                $opts{c} .= $opts{u};
-#            }
-#        }
-#        if("$comms" eq "telnet") {
-#            $command .= "$opts{s} $opts{p}";
-#        } else {
-#            if ($opts{p}) {
-#              $opts{c} .= "-p $opts{p} $opts{s}";
-#            } else {
-#              $opts{c} .= "$opts{s}";
-#            }
-#        }
-#        #$command .= " $command || sleep 5";
-#        warn("Running:$command\n"); # for debug purposes
-#        exec($command);
-#    };
-
     my $script = <<"    HERE";
            my \$pipe=shift;
            my \$svr=shift;

lib/App/ClusterSSH/Host.pm

@@ -7,6 +7,7 @@ use version;
 our $VERSION = version->new('0.03');
 
 use Carp;
+use Net::hostent;
 
 use base qw/ App::ClusterSSH::Base /;
 
@@ -60,11 +61,6 @@ sub new {
     return $self;
 }
 
-sub get_givenname {
-    my ($self) = @_;
-    return $self->{hostname};
-}
-
 sub get_hostname {
     my ($self) = @_;
     return $self->{hostname};
@@ -77,6 +73,9 @@ sub get_username {
 
 sub get_type {
     my ($self) = @_;
+    if($self->check_ssh_hostname) {
+        return 'ssh_alias';
+    }
     return $self->{type} || q{};
 }
 
@@ -129,22 +128,20 @@ sub get_realname {
     my ($self) = @_;
 
     if ( !$self->{realname} ) {
-        if ( $self->{type} && $self->{type} eq 'name' ) {
+        if ( $self->get_type eq 'ssh_alias' ) {
-            if ( $ssh_hostname_for{ $self->{hostname} } ) {
-                $self->{realname} = $self->{hostname};
-            }
-            else {
-                my $gethost_obj = gethostbyname( $self->{hostname} );
-
-                $self->{realname}
-                    = defined($gethost_obj)
-                    ? $gethost_obj->name()
-                    : $self->{hostname};
-            }
-        }
-        else {
             $self->{realname} = $self->{hostname};
         }
+        else {
+            my $gethost_obj = gethostbyname( $self->{hostname} );
+
+            $self->{realname}
+                = defined($gethost_obj)
+                ? $gethost_obj->name()
+                : $self->{hostname};
+        }
+    }
+    else {
+        $self->{realname} = $self->{hostname};
     }
     return $self->{realname};
 }
@@ -213,17 +210,17 @@ sub parse_host_string {
     if ( $host_string =~ s/\A(?:(.*?)@)// ) {
 
         # catch where @ is in host_string but no text before it
-        $username = $1 || q{};
+        $username = $1;
     }
 
     # check for any geometry settings
     if ( $host_string =~ s/(?:=(.*?)$)// ) {
-        $geometry = $1 || q{};
+        $geometry = $1;
     }
 
     # Check for a '/nnnn' port definition 
     if ( $host_string =~ s!(?:/(\d+)$)!! ) {
-       $port = $1 || q{};
+       $port = $1;
     }
 
     # use number of colons as a possible indicator
@@ -255,7 +252,7 @@ sub parse_host_string {
     }
     if (   $colon_count > 1
         && $colon_count < 8
-        && $host_string =~ m/:(\d+)$/xsm )
+    )
     {
         warn 'Ambiguous host string: "', $host_string, '"',   $/;
         warn 'Assuming you meant "[',    $host_string, ']"?', $/;
@@ -277,30 +274,6 @@ sub parse_host_string {
             type         => 'ipv6',
         );
     }
-    elsif ( $colon_count == 9 ) {
-        if ( $host_string =~ s/:(\d+)\A// ) {
-            $port = $1;
-        }
-
-        my $hostname = $host_string;
-
-        $self->debug(
-            5,
-            $self->loc(
-                'Default parse u=[_1] h=[_2] p=[_3] g=[_4]',
-                $username, $hostname, $port, $geometry,
-            )
-        );
-
-        return __PACKAGE__->new(
-            parse_string => $parse_string,
-            username     => $username,
-            hostname     => $hostname,
-            port         => $port,
-            geometry     => $geometry,
-            type         => 'name',
-        );
-    }
 
     # if we got this far, we didnt parse the host_string properly
     croak(

t/02base.t

@@ -136,6 +136,19 @@ is( $trap->die,     undef,    'returned ok' );
 is( $trap->stderr,  '',       'Expecting no STDERR' );
 is( $trap->stdout,  '',       'Expecting no STDOUT' );
 
+$base = undef;
+$get_config;
+my $object;
+trap {
+    $base = App::ClusterSSH::Base->new( debug => 3, parent => 'guardian' );
+};
+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,  '',         'Expecting no STDOUT' );
+is( $base->parent,  'guardian', 'Expecting no STDOUT' );
+
 trap {
     $get_config = $base->config();
 };
@@ -208,4 +221,28 @@ like(
 is( $trap->stderr, '', 'Expecting no STDERR' );
 is( $trap->stdout, '', 'Got expected STDOUT' );
 
+# basic checks - validity of config is tested elsewhere
+my %config;
+trap {
+    %config = $object->load_file;
+};
+is( $trap->leaveby, 'die', 'died ok' );
+isa_ok( $trap->die, 'App::ClusterSSH::Exception',
+    'Caught exception object OK' );
+is( $trap->die,
+    q{"filename" arg not passed},
+    'missing filename arg die message'
+);
+is( $trap->stderr, '', 'Expecting no STDERR' );
+is( $trap->stdout, '', 'Got expected STDOUT' );
+
+trap {
+    %config = $object->load_file( filename => $Bin . '/15config.t.file1' );
+};
+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' );
+
 done_testing();

t/10host.t

@@ -27,6 +27,8 @@ is( $host->get_port,     q{},        'checking set works' );
 is( $host->get_username, q{},        'username is unset' );
 is( $host->get_realname, 'hostname', 'realname set' );
 is( $host->get_geometry, q{},        'geometry set' );
+is( $host->get_master,   q{},        'master set' );
+is( $host->get_type,     q{},        'type set' );
 
 $host->set_port(2323);
 
@@ -36,6 +38,8 @@ is( $host->get_port,     2323,       'checking set works' );
 is( $host->get_username, q{},        'username is unset' );
 is( $host->get_realname, 'hostname', 'realname set' );
 is( $host->get_geometry, q{},        'geometry set' );
+is( $host->get_master,   q{},        'master set' );
+is( $host->get_type,     q{},        'type set' );
 
 $host->set_username('username');
 
@@ -44,6 +48,8 @@ is( $host->get_port,     2323,       'checking set works' );
 is( $host->get_username, 'username', 'username is unset' );
 is( $host->get_realname, 'hostname', 'realname set' );
 is( $host->get_geometry, q{},        'geometry set' );
+is( $host->get_master,   q{},        'master set' );
+is( $host->get_type,     q{},        'type set' );
 
 $host->set_geometry('100x50+100+100');
 
@@ -52,6 +58,28 @@ is( $host->get_port,     2323,             'checking set works' );
 is( $host->get_username, 'username',       'username is unset' );
 is( $host->get_realname, 'hostname',       'realname set' );
 is( $host->get_geometry, '100x50+100+100', 'geometry set' );
+is( $host->get_master,   q{},              'master set' );
+is( $host->get_type,     q{},              'type set' );
+
+$host->set_master('some_host');
+
+is( $host->get_hostname, 'hostname',       'checking set works' );
+is( $host->get_port,     2323,             'checking set works' );
+is( $host->get_username, 'username',       'username is unset' );
+is( $host->get_realname, 'hostname',       'realname set' );
+is( $host->get_geometry, '100x50+100+100', 'geometry set' );
+is( $host->get_master,   'some_host',      'master set' );
+is( $host->get_type,     q{},              'type set' );
+
+$host->set_type('something');
+
+is( $host->get_hostname, 'hostname',       'checking set works' );
+is( $host->get_port,     2323,             'checking set works' );
+is( $host->get_username, 'username',       'username is unset' );
+is( $host->get_realname, 'hostname',       'realname set' );
+is( $host->get_geometry, '100x50+100+100', 'geometry set' );
+is( $host->get_master,   'some_host',      'master set' );
+is( $host->get_type,     'something',      'type set' );
 
 $host = undef;
 is( $host, undef, 'starting afresh' );
@@ -640,7 +668,10 @@ my %parse_tests = (
         geometry => q{},
         type     => 'ipv6',
     },
-    'some.random:host|string:rubbish' => {
+    '2001:0db8:8a2e:0370:7334:2001:0db8:8a2e:0370:7334:4535:3453:3453:3455' => {
+        die      => qr{Unable to parse hostname from}ms,
+    },
+    'some random rubbish' => {
         die      => qr{Unable to parse hostname from}ms,
     },
 );
@@ -690,8 +721,24 @@ foreach my $ident ( keys(%parse_tests) ) {
             "$ident $attr: " . $host->$method
         );
     }
+
+    is( $host->check_ssh_hostname, 0, $ident . ' not from ssh' );
 }
 
+
+# check for a non-existant file
+trap {
+    $host = App::ClusterSSH::Host->new(
+        hostname   => 'ssh_test',
+        ssh_config => $Bin . '/some_bad_filename',
+    );
+};
+is( $trap->leaveby, 'return', 'returned ok' );
+is( $trap->die,     undef,    'returned ok' );
+isa_ok( $host, "App::ClusterSSH::Host" );
+is( $host, 'ssh_test', 'stringify works' );
+is( $host->check_ssh_hostname, 0, 'check_ssh_hostname ok for ssh_test', );
+
 trap {
     $host = App::ClusterSSH::Host->new(
         hostname   => 'ssh_test',
@@ -703,6 +750,7 @@ is( $trap->die,     undef,    'returned ok' );
 isa_ok( $host, "App::ClusterSSH::Host" );
 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', );
 
 for my $hostname (
     'server1',  'server2',
@@ -729,6 +777,7 @@ for my $hostname (
         'check_ssh_hostname ok for ' . $hostname );
     is( $host->get_realname, $hostname, 'realname set' );
     is( $host->get_geometry, q{},       'geometry set' );
+    is( $host->get_type, 'ssh_alias',   'geometry set' );
 }
 
 done_testing();

t/15config.t

@@ -463,6 +463,29 @@ is( $trap->stderr,
     'Expecting no STDERR'
 );
 
+note('move of .csshrc failure');
+$ENV{HOME} = tempdir( CLEANUP => 1 );
+open( $csshrc, '>', $ENV{HOME} . '/.csshrc' );
+print $csshrc "Something",$/;
+close($csshrc);
+open( $csshrc, '>', $ENV{HOME} . '/.csshrc.DISABLED' );
+print $csshrc "Something else",$/;
+close($csshrc);
+chmod(0666, $ENV{HOME} . '/.csshrc.DISABLED', $ENV{HOME} );
+$config = App::ClusterSSH::Config->new();
+trap {
+    $config->write_user_config_file();
+};
+is( $trap->leaveby, 'die', 'died ok' );
+isa_ok( $config, "App::ClusterSSH::Config" );
+is( $trap->stdout, q{}, 'Expecting no STDOUT' );
+is( $trap->stderr, q{}, 'Expecting no STDERR' );
+is( $trap->die,
+    q{Unable to create directory $HOME/.clusterssh: Permission denied} . $/,
+    'Expected die msg ' . $trap->stderr
+);
+chmod (0755 , $ENV{HOME} . '/.csshrc.DISABLED', $ENV{HOME} );
+
 note('check failure to write default config is caught');
 $ENV{HOME} = tempdir( CLEANUP => 1 );
 mkdir( $ENV{HOME} . '/.clusterssh' );

t/20helper.t

@@ -20,18 +20,87 @@ my $helper;
 $helper = App::ClusterSSH::Helper->new();
 isa_ok( $helper, 'App::ClusterSSH::Helper' );
 
-#note('check failure to write default config is caught');
+my $script;
-#$ENV{HOME} = tempdir( CLEANUP => 1 );
+
-#mkdir($ENV{HOME}.'/.clusterssh');
+trap {
-#mkdir($ENV{HOME}.'/.clusterssh/config');
+    $script = $helper->script;
-#$config = App::ClusterSSH::Config->new();
+};
-#trap {
+is( $trap->leaveby, 'die', 'returned ok' );
-#    $config->load_configs();
+is( $trap->stdout,  q{},   'Expecting no STDOUT' );
-#};
+is( $trap->stderr,  q{},   'Expecting no STDERR' );
-#is( $trap->leaveby, 'return', 'returned ok' );
+is( $trap->die, 'No configuration provided or in wrong format', 'no config' );
-#isa_ok( $config,    "App::ClusterSSH::Config" );
+
-#isa_ok( $config, "App::ClusterSSH::Config" );
+trap {
-#is( $trap->stdout, q{}, 'Expecting no STDOUT' );
+    $script = $helper->script( something => 'nothing' );
-#is( $trap->stderr, q{Unable to write default $HOME/.clusterssh/config: Is a directory}.$/, 'Expecting no STDERR' );
+};
+is( $trap->leaveby, 'die', 'returned ok' );
+is( $trap->stdout,  q{},   'Expecting no STDOUT' );
+is( $trap->stderr,  q{},   'Expecting no STDERR' );
+is( $trap->die, 'No configuration provided or in wrong format',
+    'bad format' );
+
+trap {
+    $script = $helper->script( { something => 'nothing' } );
+};
+is( $trap->leaveby, 'die', 'returned ok' );
+is( $trap->stdout,  q{},   'Expecting no STDOUT' );
+
+# ignore stderr here as it will complain about missing xxx_arg var
+#is( $trap->stderr, q{}, 'Expecting no STDERR' );
+is( $trap->die, q{Config 'comms' not provided}, 'missing arg' );
+
+trap {
+    $script = $helper->script( { comms => 'method' } );
+};
+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' not provided}, 'missing arg' );
+
+trap {
+    $script = $helper->script( { comms => 'method', method => 'binary', } );
+};
+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' );
+
+trap {
+    $script = $helper->script(
+        {   comms       => 'method',
+            method      => 'binary',
+            method_args => 'rubbish',
+            command     => 'echo',
+            auto_close  => 0,
+        }
+    );
+};
+is( $trap->leaveby, 'return', 'returned ok' );
+is( $trap->stdout,  q{},   'Expecting no STDOUT' );
+is( $trap->stderr,  q{},   'Expecting no STDERR' );
+is( $trap->die, undef,     'not died' );
+
+trap {
+    $script = $helper->script(
+        {   comms       => 'method',
+            method      => 'binary',
+            method_args => 'rubbish',
+            command     => 'echo',
+            auto_close  => 5,
+        }
+    );
+};
+is( $trap->leaveby, 'return', 'returned ok' );
+is( $trap->stdout,  q{},   'Expecting no STDOUT' );
+is( $trap->stderr,  q{},   'Expecting no STDERR' );
+is( $trap->die, undef,     'not died' );
+
+trap {
+    eval { $script };
+};
+is( $trap->leaveby, 'return', 'returned ok' );
+is( $trap->stdout,  q{},   'Expecting no STDOUT' );
+is( $trap->stderr,  q{},   'Expecting no STDERR' );
+is( $trap->die, undef,     'not died' );
 
 done_testing();

t/30cluster.t

@@ -88,6 +88,34 @@ is( scalar $cluster1->get_tag('default'),
     'Count correct'
 );
 
+my $tags;
+trap {
+    $tags = $cluster1->get_tag('does_not_exist');
+};
+is( $trap->leaveby, 'return', 'non-existant tag returns correctly' );
+is( $trap->stdout,  '',       'no stdout for non-existant get_tag' );
+is( $trap->stderr,  '',       'no stderr for non-existant get_tag' );
+is( $tags,          undef,    'non-existant tag returns undef' );
+
+@default_expected = sort 
+    qw/ default people tag1 tag2 tag3 tag10 tag20 tag30 tag40 tag50 /;
+trap {
+    @default = $cluster1->list_tags;
+};
+is($trap->leaveby, 'return', 'list_tags returned okay');
+is( $trap->stdout,  '',       'no stdout for non-existant get_tag' );
+is( $trap->stderr,  '',       'no stderr for non-existant get_tag' );
+is_deeply( \@default, \@default_expected, 'tag list correct' );
+
+my $count;
+trap {
+    $count = $cluster1->list_tags;
+};
+is($trap->leaveby, 'return', 'list_tags returned okay');
+is( $trap->stdout,  '',       'no stdout for non-existant get_tag' );
+is( $trap->stderr,  '',       'no stderr for non-existant get_tag' );
+is_deeply( $count, 10, 'tag list count correct' );
+
 # now checks against running an external command
 
 my @external_expected;
@@ -157,6 +185,22 @@ like(
 is( $trap->stdout, '', 'External command: no stdout from perl code' );
 is( $trap->stderr, '', 'External command: no stderr from perl code' );
 
+# check reading of cluster files
+trap {
+    $cluster1->get_cluster_entries( $Bin . '/30cluster.file3' );
+};
+is( $trap->leaveby, 'return', 'exit okay on get_cluster_entries' );
+is( $trap->stdout,  '',       'no stdout for get_cluster_entries' );
+is( $trap->stderr,  '',       'no stderr for get_cluster_entries' );
+
+# check reading of tag files
+trap {
+    $cluster1->get_tag_entries( $Bin . '/30cluster.tag1' );
+};
+is( $trap->leaveby, 'return', 'exit okay on get_tag_entries' );
+is( $trap->stdout,  '',       'no stdout for get_tag_entries' );
+is( $trap->stderr,  '',       'no stderr for get_tag_entries' );
+
 done_testing();
 
 sub test_expected {