view release on metacpan or  search on metacpan

lib/Test/SSH.pm  view on Meta::CPAN

package Test::SSH;

our $VERSION = '0.08';

use strict;
use warnings;

use Carp;
use File::Glob qw(:glob);
require File::Spec;
require Test::More;

my (@extra_path, @default_user_keys, $default_user, $private_dir);

my @default_test_commands = ('true', 'exit', 'echo foo', 'date',
                             'cmd /c ver', 'cmd /c echo foo');

if ( $^O =~ /^MSWin/) {
    require Win32;
    $default_user = Win32::LoginName();
	
	my @pf;
	for my $folder (qw(PROGRAM_FILES PROGRAM_FILES_COMMON)) {
		my $dir = eval "Win32::GetFolderPath(Win32::$folder)";
		if (defined $dir) {
		    push @extra_path, File::Spec->join($dir, 'PuTTY');
		}
	}
}
else {
    @extra_path = ( map { File::Spec->join($_, 'bin'), File::Spec->join($_, 'sbin') }
                    map { File::Spec->rel2abs($_) }
                    map { bsd_glob($_, GLOB_TILDE|GLOB_NOCASE) }
                    qw( /
                        /usr
                        /usr/local
                        ~/
                        /usr/local/*ssh*
                        /usr/local/*ssh*/*
                        /opt/*SSH*
                        /opt/*SSH*/* ) );

    @default_user_keys = bsd_glob("~/.ssh/*", GLOB_TILDE);

    $default_user = getpwuid($>);

    ($private_dir) = bsd_glob("~/.libtest-ssh-perl", GLOB_TILDE|GLOB_NOCHECK);

}

@default_user_keys = grep {
    my $fh;
    open $fh, '<', $_ and <$fh> =~ /\bBEGIN\b.*\bPRIVATE\s+KEY\b/
} @default_user_keys;


my @default_path = grep { -d $_ } File::Spec->path, @extra_path;

unless (defined $private_dir) {
    require File::temp;
    $private_dir = File::Spec->join(File::Temp::tempdir(CLEANUP => 1),
                                    "libtest-ssh-perl");
}

my $default_logger = sub { Test::More::diag("Test::SSH > @_") };

my %defaults = ( backends      => [qw(Remote OpenSSH)],
                 timeout       => 10,
                 port          => 22,
                 host          => 'localhost',
                 user          => $default_user,
                 test_commands => \@default_test_commands,
                 path          => \@default_path,
                 user_keys     => \@default_user_keys,
                 private_dir   => $private_dir,
                 logger        => $default_logger,
                 run_server    => 1,
               );

sub new {
    my ($class, %opts) = @_;
    defined $opts{$_} or $opts{$_} = $defaults{$_} for keys %defaults;

    if (defined (my $target = $ENV{TEST_SSH_TARGET})) {
        $opts{requested_uri} = $target;
        $opts{run_server} = 0;
    }

    if (defined (my $password = $ENV{TEST_SSH_PASSWORD})) {
        $opts{password} = $password;
    }

    for my $be (@{delete $opts{backends}}) {
        $be =~ /^\w+$/ or croak "bad backend name '$be'";
        my $class = "Test::SSH::Backend::$be";
        eval "require $class; 1" or die;
        my $sshd = $class->new(%opts) or next;
        $sshd->_log("connection uri", $sshd->uri(hidden_password => 1));
        return $sshd;
    }
    return;
}

1;
__END__