File Coverage

blib/lib/Net/OpenSSH/Compat/Perl.pm

Criterion	Covered	Total	%
statement	24	127	18.9
branch	1	52	1.9
condition	2	12	16.6
subroutine	8	24	33.3
pod	1	8	12.5
total	36	223	16.1

package Net::OpenSSH::Compat::Perl;

our $VERSION = '0.08';

use strict;
use warnings;
use Carp ();

use Net::OpenSSH;
use Net::OpenSSH::Constants qw(OSSH_MASTER_FAILED OSSH_SLAVE_CMD_FAILED);

require Exporter;
our @ISA = qw(Exporter);
our @CARP_NOT = qw(Net::OpenSSH);

my $supplant;
my $session_id = 1;

our %DEFAULTS = ( session    => [protocol => 2,
                                 strict_host_key_checking => 'no'],
                  connection => [] );

sub import {
    my $class = shift;
    if (!$supplant and
        $class eq __PACKAGE__ and
        grep($_ eq ':supplant', @_)) {
        $supplant = 1;
        for my $end ('') { #, qw(Channel SFTP Dir File)) {
            my $this = __PACKAGE__;
            my $pkg = "Net::SSH::Perl";
            my $file = "Net/SSH/Perl";
            if ($end) {
                $this .= "::$end";
                $pkg .= "::$end";
                $file .= "/$end";
            }
            $INC{$file . '.pm'} = __FILE__;
            no strict 'refs';
            @{"${pkg}::ISA"} = ($this);
            ${"${pkg}::VERSION"} = __PACKAGE__->version;
        }
    }
    __PACKAGE__->export_to_level(1, $class,
                                 grep $_ ne ':supplant', @_);
}

sub version { "1.34 (".__PACKAGE__."-$VERSION)" }

sub new {
    my $class = shift;
    my $host = shift;
    my $cfg = Net::OpenSSH::Compat::Perl::Config->new(@_);
    my $cpt = { host => $host,
                state => 'new',
                cfg => $cfg,
                session_id => $session_id++ };

    bless $cpt, $class;
}

sub _entry_method {
    my $n = 1;
    my $last = 'unknown';
    while (1) {
        my $sub = (caller $n++)[3];
        $sub =~ /^Net::OpenSSH::Compat::(?:\w+::)?(\w+)$/ or last;
        $last = $1;
    }
    $last;
}

sub _check_state {
    my ($cpt, $expected) = @_;
    my $state = $cpt->{state};
    return 1 if $expected eq $state;
    my $method = $cpt->_entry_method;
    my $class = ref $cpt;
    Carp::croak qq($class object can't do "$method" on state $state);
    return
}

sub _check_error {
    my $cpt = shift;
    my $ssh = $cpt->{ssh};
    return if (!$ssh->error or $ssh->error == OSSH_SLAVE_CMD_FAILED);
    my $method = $cpt->_entry_method;
    $cpt->{state} = 'failed' if $ssh->error == OSSH_MASTER_FAILED;
    Carp::croak "$method failed: " . $ssh->error;
}

sub login {
    my ($cpt, $user, $password, $suppress_shell) = @_;
    $cpt->_check_state('new');

    $cpt->{user} = $user;
    $cpt->{password} = '*****' if defined $password;
    $cpt->{suppress_shell} = $suppress_shell;

    my @args = (host => $cpt->{host}, @{$DEFAULTS{connection}});
    push @args, user => $user if defined $user;
    push @args, password => $password if defined $password;

    my $cfg = $cpt->{cfg};
    push @args, port => $cfg->{port} if defined $cfg->{port};
    push @args, batch_mode => 1 unless $cfg->{interactive};

    my @more;
    push @more, 'UsePrivilegedPort=yes' if $cfg->{privileged};
    push @more, "Ciphers=$cfg->{ciphers}" if defined $cfg->{ciphers};
    push @more, "Compression=$cfg->{compression}" if defined $cfg->{compression};
    push @more, "CompressionLevel=$cfg->{compression_level}" if defined $cfg->{compression_level};
    push @more, "StrictHostKeyChecking=$cfg->{strict_host_key_checking}" if defined $cfg->{strict_host_key_checking};
    if ($cfg->{identity_files}) {
        push @more, "IdentityFile=$_" for @{$cfg->{identity_files}};
    }
    if ($cfg->{options}) {
        push @more, @{$cfg->{options}};
    }
    push @args, master_opts => [map { -o => $_ } @more];
    # warn "args: @args";

    my $ssh = $cpt->{ssh} = Net::OpenSSH->new(@args);
    if ($ssh->error) {
        $ssh->{state} = 'failed';
        $ssh->die_on_error;
    }
    $cpt->{state} = 'connected';
}

sub cmd {
    my ($cpt, $cmd, $stdin) = @_;
    $cpt->_check_state('connected');
    my $ssh = $cpt->{ssh};
    $stdin = '' unless defined $stdin;
    local $?;
    my ($out, $err) = $ssh->capture2({stdin_data => $stdin}, $cmd);
    $cpt->_check_error;
    return ($out, $err, ($? >> 8));
}

sub shell {
    my $cpt = shift;
    $cpt->_check_state('connected');
    my $ssh = $cpt->{ssh};
    my $tty = $cpt->{cfg}{use_pty};
    $tty = 1 unless defined $tty;
    $ssh->system({tty => $tty});
}

sub config { shift->{cfg} }

sub debug { Carp::carp("@_") if shift->{cfg}{debug} }

sub session_id { shift->{session_id} }

my $make_missing_methods = sub {
    my $pkg = caller;
    my $faked = $pkg;
    $faked =~ s/^Net::OpenSSH::Compat::/Net::SSH::/;
    for (@_) {
        my $name = $_;
        no strict 'refs';
        *{$pkg.'::'.$name} = sub {
            Carp::croak("method ${faked}::$name is not implemented by $pkg, report a bug if you want it supported!");
        }
    }
};

$make_missing_methods->(qw(register_handler
                           sock
                           incomming_data
                           packet_start));

package Net::OpenSSH::Compat::Perl::Config;

my %option_perl2openssh = qw(protocol proto);

sub new {
    my $class = shift;
    my %opts = (@{$DEFAULTS{session}}, @_);
    my %cfg = map { my $v = delete $opts{$_};
                    my $name = $option_perl2openssh{$_} || $_;
                    defined $v ? ($name, $v) : () } qw(port protocol debug interactive
                                                       privileged identity_files cipher
                                                       ciphers compression
                                                       compression_level use_pty
                                                       options strict_host_key_checking);

    %opts and Carp::croak "unsupported configuration option(s) given: ".join(", ", keys %opts);
    $cfg{proto} =~ /\b2\b/ or Carp::croak "Unsupported protocol version requested $cfg{proto}";

    bless \%cfg, $class;
}

sub get { $_[0]->{$_[1]} }

sub set {
    my ($cfg, $k, $v) = @_;
    $cfg->{$k} = $v if @_ == 3;
    $cfg->{$k};
}

sub DESTROY {};

$make_missing_methods->(qw(read_config merge_directive AUTOLOAD));

1;

__END__