view release on metacpan or  search on metacpan

lib/AnyEvent/SSH2.pm  view on Meta::CPAN

    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);
    }

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

    #my $suppress_shell = $_[2];
}

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

sub set_protocol {
    my $ssh = shift;
    my $proto = shift;
    $ssh->{use_protocol} = $proto;
    $ssh->debug($ssh->version_string);
    $ssh->_proto_init;
}


sub _dup {
    my($fh, $mode) = @_;
    my $dup = Symbol::gensym;
    my $str = "${mode}&$fh";
    open ($dup, $str) or die "Could not dupe: $!\n"; ## no critic
    $dup;
}

sub version_string {
    my $class = shift;
    sprintf "Net::SSH::Perl Version %s, protocol version %s.%s.",
        $class->VERSION, PROTOCOL_MAJOR_2, PROTOCOL_MINOR_2;
}

sub _exchange_identification {
    my $ssh = shift;
    my $remote_id = $ssh->_read_version(@_); 
    ($ssh->{server_version_string} = $remote_id) =~ s/\cM?$//;
    my($remote_major, $remote_minor, $remote_version) = $remote_id =~
        /^SSH-(\d+)\.(\d+)-([^\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;
    my $handle = $ssh->{session}{sock};
    $handle->push_write($buf);
    $ssh->set_protocol($set_proto);
    $ssh->_compat_init($remote_version);
}

sub _proto_init {
    my $ssh = shift;
    my $home = $ENV{HOME} || (getpwuid($>))[7];
    unless ($ssh->{config}->get('user_known_hosts')) {
        defined $home or croak "Cannot determine home directory, please set the environment variable HOME";
        $ssh->{config}->set('user_known_hosts', "$home/.ssh/known_hosts2");
    }
    unless ($ssh->{config}->get('global_known_hosts')) {
        $ssh->{config}->set('global_known_hosts', "/etc/ssh_known_hosts2");
    }
    unless (my $if = $ssh->{config}->get('identity_files')) {
        defined $home or croak "Cannot determine home directory, please set the environment variable HOME";
        $ssh->{config}->set('identity_files', [ "$home/.ssh/id_dsa" ]);
    }

    for my $a (qw( password dsa kbd_interactive )) {
        $ssh->{config}->set("auth_$a", 1)
            unless defined $ssh->{config}->get("auth_$a");
    }
}

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

sub register_handler {
    my($ssh, $type, $sub, @extra) = @_;
    $ssh->{client_handlers}{$type} = { code => $sub, extra => \@extra };
}

sub connect {
    my $ssh = shift;
    my($type, @args) = @_;
    $ssh->{session}{sock} = new AnyEvent::Handle
        connect  => [
          $ssh->{host} => $ssh->{config}->get('port') || 'ssh'
        ],
        on_error => sub {
            my ($hdl, $fatal, $msg) = @_;
            $ssh->debug("Can't connect to $ssh->{host}, port $ssh->{config}->get('port'): $msg");
            $hdl->destroy;
        },
        on_connect_error => sub {
            $ssh->debug("Can't connect to $ssh->{host}, port $ssh->{config}->get('port'): $!");
        }, 
        on_eof   => sub {
            shift->destroy; # explicitly destroy handle
        };
    $ssh->{session}{sock}->push_read( line => sub {
        my ($handle, $line) = @_;
        $ssh->_exchange_identification($line);
        $ssh->debug("Connection established.");
        $ssh->_login();


    });
}

sub _login {
    my $ssh = shift;

    my $kex = Net::SSH::Perl::Kex->new($ssh);
    $kex->exchange(undef, sub{
        my $ssh = shift;
        my $amgr = Net::SSH::Perl::AuthMgr->new($ssh);