File Coverage

blib/lib/Net/SSH/Perl.pm

Criterion	Covered	Total	%
statement	102	281	36.3
branch	15	132	11.3
condition	8	75	10.6
subroutine	24	51	47.0
pod	12	22	54.5
total	161	561	28.7

# $Id: Perl.pm,v 1.126 2009/02/02 01:18:27 turnstep Exp $

package Net::SSH::Perl;
use strict;
use warnings;

use Net::SSH::Perl::Packet;
use Net::SSH::Perl::Buffer;
use Net::SSH::Perl::Config;
use Net::SSH::Perl::Constants qw( :protocol :compat :hosts );
use Net::SSH::Perl::Cipher;
use Net::SSH::Perl::Util qw( :hosts _read_yes_or_no _current_user_win32 );

use Errno;

use vars qw( $VERSION $CONFIG $HOSTNAME );
$CONFIG = {};

use Socket qw(IPPROTO_TCP TCP_NODELAY);
use IO::Socket;
use Fcntl;
use Symbol;
use Carp qw( croak );
use File::Spec::Functions qw( catfile );
use Sys::Hostname;
eval {
    $HOSTNAME = hostname();
};

$VERSION = '2.14';

sub VERSION { $VERSION }

sub new {
    my $class = shift;
    my $host = shift;
    croak "usage: ", __PACKAGE__, "->new(\$host)"
        unless defined $host;
    my $ssh = bless { host => $host }, $class;
    my %p = @_;
    $ssh->{_test} = delete $p{_test};
    $ssh->_init(%p);
    $ssh->_connect unless $ssh->{_test};
    $ssh;
}

sub protocol { $_[0]->{use_protocol} }

sub set_protocol {
    my $ssh = shift;
    my $proto = shift;
    $ssh->{use_protocol} = $proto;
    my $proto_class = join '::', __PACKAGE__,
        ($proto == PROTOCOL_SSH2 ? "SSH2" : "SSH1");
    (my $lib = $proto_class . ".pm") =~ s!::!/!g;
    require $lib;
    bless $ssh, $proto_class;
    $ssh->debug($proto_class->version_string);
    $ssh->_proto_init;
}

use vars qw( @COMPAT );
@COMPAT = (
  [  '^OpenSSH[-_]2\.[012]' => SSH_COMPAT_OLD_SESSIONID,   ],
  [  'MindTerm'             => 0,                          ],
  [  '^2\.1\.0 '            => SSH_COMPAT_BUG_SIGBLOB |
                               SSH_COMPAT_BUG_HMAC |
                               SSH_COMPAT_OLD_SESSIONID,   ],
  [  '^2\.0\.'              => SSH_COMPAT_BUG_SIGBLOB |
                               SSH_COMPAT_BUG_HMAC |
                               SSH_COMPAT_OLD_SESSIONID |
                               SSH_COMPAT_BUG_PUBKEYAUTH |
                               SSH_COMPAT_BUG_X11FWD,      ],
  [  '^2\.[23]\.0 '         => SSH_COMPAT_BUG_HMAC,        ],
  [  '^2\.[2-9]\.'          => 0,                          ],
  [  '^2\.4$'               => SSH_COMPAT_OLD_SESSIONID,   ],
  [  '^3\.0 SecureCRT'      => SSH_COMPAT_OLD_SESSIONID,   ],
  [  '^1\.7 SecureFX'       => SSH_COMPAT_OLD_SESSIONID,   ],
  [  '^2\.'                 => SSH_COMPAT_BUG_HMAC,        ],
);

sub _compat_init {
    my $ssh = shift;
    my($version) = @_;
    $ssh->{datafellows} = 0;
    for my $rec (@COMPAT) {
        my($re, $mask) = @$rec[0, 1];
        if ($version =~ /$re/) {
            $ssh->debug("Compat match: '$version' matches pattern '$re'.");
            $ssh->{datafellows} = $mask;
            return;
        }
    }
    $ssh->debug("No compat match: $version.");
}

sub version_string { }

sub client_version_string { $_[0]->{client_version_string} }
sub server_version_string { $_[0]->{server_version_string} }

sub _current_user {
    if ( $^O eq 'MSWin32' ) {
        return _current_user_win32();
    }

    my $user;
    eval { $user = scalar getpwuid $> };
    return $user;
}

sub _init {
    my $ssh = shift;

    my %arg = @_;
    my $user_config = delete $arg{user_config}
      || catfile($ENV{HOME} || $ENV{USERPROFILE}, '.ssh', 'config');
    my $sys_config  = delete $arg{sys_config}
      || $^O eq 'MSWin32'
        ? catfile($ENV{WINDIR}, 'ssh_config')
        : "/etc/ssh_config";

    my $directives = delete $arg{options} || [];

    if (my $proto = delete $arg{protocol}) {
        push @$directives, "Protocol $proto";
    }

    my $cfg = Net::SSH::Perl::Config->new($ssh->{host}, %arg);
    $ssh->{config} = $cfg;

    # Merge config-format directives given through "options"
    # (just like -o option to ssh command line). Do this before
    # reading config files so we override files.
    for my $d (@$directives) {
        $cfg->merge_directive($d);
    }

    for my $f (($user_config, $sys_config)) {
        $ssh->debug("Reading configuration data $f");
        $cfg->read_config($f);
    }

    if (my $real_host = $ssh->{config}->get('hostname')) {
        $ssh->{host} = $real_host;
    }

    my $user = _current_user();
    if ($user && $user eq "root" &&
      !defined $ssh->{config}->get('privileged')) {
        $ssh->{config}->set('privileged', 1);
    }

    unless ($ssh->{config}->get('protocol')) {
        $ssh->{config}->set('protocol',
            PROTOCOL_SSH1 | PROTOCOL_SSH2 | PROTOCOL_SSH1_PREFERRED);
    }

    unless (defined $ssh->{config}->get('password_prompt_login')) {
        $ssh->{config}->set('password_prompt_login', 1);
    }
    unless (defined $ssh->{config}->get('password_prompt_host')) {
        $ssh->{config}->set('password_prompt_host', 1);
    }
    unless (defined $ssh->{config}->get('number_of_password_prompts')) {
        $ssh->{config}->set('number_of_password_prompts', 3);
    }
}

sub _proto_init { }

sub register_handler { }

sub config { $_[0]->{config} }

sub configure {
    my $class = shift;
    $CONFIG = { @_ };
}

sub ssh {
    my($host, @cmd) = @_;
    my($user);
    ($host, $user) = $host =~ m!(.+)@(.+)! ?
       ($2, $1) : ($host, _current_user());
    my $ssh = __PACKAGE__->new($host, %$CONFIG);
    $ssh->login($user);
    my($out, $err, $exit) = $ssh->cmd(join ' ', @cmd);
    print $out;
    print STDERR $err if $err;
}

sub issh {
    my($host, @cmd) = @_;
    print join(' ', @cmd), "\n";
    print "Proceed: [y/N]:";
    my $x = scalar();
    if ($x =~ /^y/i) {
        $CONFIG->{interactive} = 1;
        ssh($host, @cmd);
    }
}

sub _connect {
    my $ssh = shift;
    my $sock = $ssh->_create_socket;

    my $raddr = inet_aton($ssh->{host});
    croak "Net::SSH: Bad host name: $ssh->{host}"
        unless defined $raddr;
    my $rport = $ssh->{config}->get('port') || 'ssh';
    if ($rport =~ /\D/) {
        my @serv = getservbyname(my $serv = $rport, 'tcp');
        $rport = $serv[2] || 22;
    }
    $ssh->debug("Connecting to $ssh->{host}, port $rport.");
    connect($sock, sockaddr_in($rport, $raddr))
        or die "Can't connect to $ssh->{host}, port $rport: $!";

    select((select($sock), $|=1)[0]);

    $ssh->{session}{sock} = $sock;
    $ssh->_exchange_identification;

    if ($^O eq 'MSWin32') {
      my $nonblocking = 1;
      ioctl $sock, 0x8004667e, \\$nonblocking;
    }
    else {
      defined($sock->blocking(0))
          or die "Can't set socket non-blocking: $!";
    }

    $ssh->debug("Connection established.");
}

sub _create_socket {
    my $ssh = shift;
    my $sock = gensym;

    my ($p,$end,$delta) = (0,1,1); # normally we use whatever port we can get
          ($p,$end,$delta) = (1023,512,-1) if $ssh->{config}->get('privileged');

    # allow an explicit bind address
    my $addr = $ssh->{config}->get('bind_address');
    $addr = inet_aton($addr) if $addr;
    ($p,$end,$delta) = (10000,65535,1) if $addr and not $p;
    $addr ||= INADDR_ANY;

    for(; $p != $end; $p += $delta) {
        socket($sock, AF_INET, SOCK_STREAM, getprotobyname('tcp') || 0) ||
            croak "Net::SSH: Can't create socket: $!";
        setsockopt($sock, IPPROTO_TCP, TCP_NODELAY, 1);
        last if not $p or bind($sock, sockaddr_in($p,$addr));
        if ($! =~ /Address already in use/i) {
            close($sock) or warn qq{Could not close socket: $!\n};
            next;
        }
        croak "Net::SSH: Can't bind socket to port $p: $!";
    }
    if($p) {
        $ssh->debug("Allocated local port $p.");
        $ssh->{config}->set('localport', $p);
    }

    $sock;
}

sub _disconnect { }

sub fatal_disconnect {
    my $ssh = shift;
    $ssh->_disconnect(@_);
    croak @_;
}

sub _read_version_line {
    my $ssh = shift;
    my $sock = $ssh->{session}{sock};
    my $line;
    for(;;) {
        my $s = IO::Select->new($sock);
        my @ready = $s->can_read;
        my $buf;
        my $len = sysread($sock, $buf, 1);
        unless(defined($len)) {
            next if $!{EAGAIN} || $!{EWOULDBLOCK};
            croak "Read from socket failed: $!";
        }
        croak "Connection closed by remote host" if $len == 0;
        $line .= $buf;
        croak "Version line too long: $line"
         if substr($line, 0, 4) eq "SSH-" and length($line) > 255;
        croak "Pre-version line too long: $line" if length($line) > 4*1024;
        return $line if $buf eq "\n";
    }
}

sub _read_version {
    my $ssh = shift;
    my ($line, $line_out);
    do {
        $line = $line_out = $ssh->_read_version_line;
    } while (substr($line, 0, 4) ne "SSH-");
    chomp($line_out);
    $ssh->debug("Remote version string: $line_out");
    return $line;
}

sub sock { $_[0]->{session}{sock} }

sub _exchange_identification {
    my $ssh = shift;
    my $sock = $ssh->{session}{sock};
    my $remote_id = $ssh->_read_version;
    ($ssh->{server_version_string} = $remote_id) =~ s/\cM?\n$//;
    my($remote_major, $remote_minor, $remote_version) = $remote_id =~
        /^SSH-(\d+)\.(\d+)-([^\n\r]+)[\r]*\n$/;
    $ssh->debug("Remote protocol version $remote_major.$remote_minor, remote software version $remote_version");

    my $proto = $ssh->config->get('protocol');
    my($mismatch, $set_proto);
    if ($remote_major == 1) {
        if ($remote_minor == 99 && $proto & PROTOCOL_SSH2 &&
            !($proto & PROTOCOL_SSH1_PREFERRED)) {
            $set_proto = PROTOCOL_SSH2;
        }
        elsif (!($proto & PROTOCOL_SSH1)) {
            $mismatch = 1;
        }
        else {
            $set_proto = PROTOCOL_SSH1;
        }
    }
    elsif ($remote_major == 2) {
        if ($proto & PROTOCOL_SSH2) {
            $set_proto = PROTOCOL_SSH2;
        }
    }
    if ($mismatch) {
        croak sprintf "Protocol major versions differ: %d vs. %d",
            ($proto & PROTOCOL_SSH2) ? PROTOCOL_MAJOR_2 :
            PROTOCOL_MAJOR_1, $remote_major;
    }
    my $compat20 = $set_proto == PROTOCOL_SSH2;
    my $buf = sprintf "SSH-%d.%d-%s\n",
        $compat20 ? PROTOCOL_MAJOR_2 : PROTOCOL_MAJOR_1,
        $compat20 ? PROTOCOL_MINOR_2 : PROTOCOL_MINOR_1,
        $VERSION;
    $ssh->{client_version_string} = substr $buf, 0, -1;
    syswrite $sock, $buf;

    $ssh->set_protocol($set_proto);
    $ssh->_compat_init($remote_version);
}

sub debug {
    my $ssh = shift;
    if ($ssh->{config}->get('debug')) {
        printf STDERR "%s@_\n", $HOSTNAME ? "$HOSTNAME: " : '';
    }
}

sub login {
    my $ssh = shift;
    my($user, $pass) = @_;
    if (!defined $ssh->{config}->get('user')) {
        $ssh->{config}->set('user',
            defined $user ? $user : _current_user());
    }
    if (!defined $pass && exists $CONFIG->{ssh_password}) {
        $pass = $CONFIG->{ssh_password};
    }
    $ssh->{config}->set('pass', $pass);
}

sub _login { }

sub cmd { }
sub shell { }

sub incoming_data {
    my $ssh = shift;
    if (!exists $ssh->{session}{incoming_data}) {
        $ssh->{session}{incoming_data} = Net::SSH::Perl::Buffer->new( MP => $ssh->protocol == PROTOCOL_SSH2 ? 'SSH2' : 'SSH1' );
    }
    $ssh->{session}{incoming_data};
}

sub session_id {
    my $ssh = shift;
    $ssh->{session}{id} = shift if @_ and not defined $ssh->{session}{id};
    $ssh->{session}{id};
}

sub packet_start { Net::SSH::Perl::Packet->new($_[0], type => $_[1]) }

sub check_host_key {
    my $ssh = shift;
    my($key, $host, $u_hostfile, $s_hostfile) = @_;
    my $strict_host_key_checking =
        $ssh->{config}->get('strict_host_key_checking') || 'no';
    $host ||= $ssh->{host};
    $u_hostfile ||= $ssh->{config}->get('user_known_hosts');
    $s_hostfile ||= $ssh->{config}->get('global_known_hosts');
    my $port = $ssh->{config}->get('port');

    if (defined $port && $port =~ /\D/) {
        my @serv = getservbyname(my $serv = $port, 'tcp');
        $port = $serv[2];
    }

    my $hash_known_hosts = $ssh->{config}->get('hash_known_hosts');
    my $check_ip = $ssh->{config}->get('check_host_ip');
    $check_ip = 1 unless defined $check_ip;

    my $status = _check_host_in_hostfile($host, $port, $u_hostfile, $key);
    unless (defined $status && ($status == HOST_OK || $status == HOST_CHANGED)) {
        $status = _check_host_in_hostfile($host, $port, $s_hostfile, $key);
    }

    if ($status == HOST_OK) {
        $ssh->debug("Host '$host' is known and matches the host key.");
    }
    elsif ($status == HOST_NEW) {
        if ($strict_host_key_checking =~ /(ask|yes)/) {
            if (!$ssh->{config}->get('interactive')) {
                croak "Host key verification failed.";
            }
            my $prompt =
qq(The authenticity of host '$host' can't be established.
Key fingerprint is @{[ $key->fingerprint($ssh->config->get('fingerprint_hash')) ]}.
Are you sure you want to continue connecting (yes/no)?);
            unless (_read_yes_or_no($prompt, "yes")) {
                croak "Aborted by user!";
            }
        }
        _add_host_to_hostfile($host, $port, $u_hostfile, $key, $hash_known_hosts);
        $ssh->debug("Permanently added '$host' to the list of known hosts.");
    }
    else {
        croak "Host key for '$host' has changed!";
    }

    return unless $check_ip && $host =~ /[a-z][A-Z]+/;
    my $ip = inet_ntoa(inet_aton($host)) or return;

    $status = _check_host_in_hostfile($ip, $port, $u_hostfile, $key);
    unless (defined $status && ($status == HOST_OK || $status == HOST_CHANGED)) {
        $status = _check_host_in_hostfile($ip, $port, $s_hostfile, $key);
    }
    if ($status == HOST_NEW) {
        _add_host_to_hostfile($ip, $port, $u_hostfile, $key, $hash_known_hosts);
    }
    elsif ($status == HOST_CHANGED) {
        my $prompt =
qq(The host key for IP address '$ip' does not match that for '$host'.
Are you sure you want to continue connecting (yes/no)?);
        unless (_read_yes_or_no($prompt, "yes")) {
            croak "Aborted by user!";
        }
    }
}

1;
__END__