File Coverage

blib/lib/AnyEvent/SSH2.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             # $Id: SSH2.pm,v 1.47 2009/01/26 01:50:38 turnstep Exp $
2             package AnyEvent::SSH2;
3 1     1   13443 use strict;
  1         2  
  1         26  
4 1     1   365 use AE;
  1         4933  
  1         31  
5 1     1   628 use AnyEvent::Handle;
  1         14472  
  1         28  
6 1     1   197 use Net::SSH::Perl::Kex;
  0            
  0            
7             use Net::SSH::Perl::ChannelMgr;
8             use Net::SSH::Perl::Packet;
9             use Net::SSH::Perl::Buffer;
10             use Net::SSH::Perl::Constants qw( :protocol :msg2 :compat :hosts :channels :proposal :kex
11             CHAN_INPUT_CLOSED CHAN_INPUT_WAIT_DRAIN );
12             use Net::SSH::Perl::Cipher;
13             use Net::SSH::Perl::AuthMgr;
14             use Net::SSH::Perl::Comp;
15             use Net::SSH::Perl::Util qw(:hosts);
16             use Scalar::Util qw(blessed weaken);
17             use Carp qw( croak );
18              
19             use base qw( Net::SSH::Perl );
20             our $VERSION = '0.03';
21              
22             use Errno qw( EAGAIN EWOULDBLOCK );
23             use vars qw( $VERSION $CONFIG $HOSTNAME @PROPOSAL );
24             use vars qw( @PROPOSAL );
25             @PROPOSAL = (
26             KEX_DEFAULT_KEX,
27             KEX_DEFAULT_PK_ALG,
28             KEX_DEFAULT_ENCRYPT,
29             KEX_DEFAULT_ENCRYPT,
30             KEX_DEFAULT_MAC,
31             KEX_DEFAULT_MAC,
32             KEX_DEFAULT_COMP,
33             KEX_DEFAULT_COMP,
34             KEX_DEFAULT_LANG,
35             KEX_DEFAULT_LANG,
36             );
37              
38             $CONFIG = {};
39              
40             BEGIN {
41             use Net::SSH::Perl::Packet;
42             no warnings qw(redefine);
43             *Net::SSH::Perl::Packet::send_ssh2 = sub {
44             my $pack = shift;
45             my $buffer = shift || $pack->{data};
46             my $ssh = $pack->{ssh};
47              
48             my $kex = $ssh->kex;
49             my($ciph, $mac, $comp);
50             if ($kex) {
51             $ciph = $kex->send_cipher;
52             $mac = $kex->send_mac;
53             $comp = $kex->send_comp;
54             }
55             my $block_size = 8;
56              
57             if ($comp && $comp->enabled) {
58             my $compressed = $comp->compress($buffer->bytes);
59             $buffer->empty;
60             $buffer->append($compressed);
61             }
62              
63             my $len = $buffer->length + 4 + 1;
64             my $padlen = $block_size - ($len % $block_size);
65             $padlen += $block_size if $padlen < 4;
66             my $junk = $ciph ? (join '', map chr rand 255, 1..$padlen) : ("\0" x $padlen);
67             $buffer->append($junk);
68              
69             my $packet_len = $buffer->length + 1;
70             $buffer->bytes(0, 0, pack("N", $packet_len) . pack("c", $padlen));
71              
72             my($macbuf);
73             if ($mac && $mac->enabled) {
74             $macbuf = $mac->hmac(pack("N", $ssh->{session}{seqnr_out}) . $buffer->bytes);
75             }
76             my $output = Net::SSH::Perl::Buffer->new( MP => 'SSH2' );
77             $output->append( $ciph && $ciph->enabled ? $ciph->encrypt($buffer->bytes) : $buffer->bytes );
78             $output->append($macbuf) if $mac && $mac->enabled;
79              
80             $ssh->{session}{seqnr_out}++;
81              
82             my $handle = $ssh->sock;
83             my $stat = $handle->push_write($output->bytes);
84             };
85             *Net::SSH::Perl::Packet::read_expect = sub {
86             my $class = shift;
87             my($ssh, $type, $cb) = @_;
88             my $pack = $class->read($ssh, sub{
89             my ($ssh, $pack) = @_;
90             if ($pack->type != $type) {
91             $ssh->fatal_disconnect(sprintf
92             "Protocol error: expected packet type %d, got %d",
93             $type, $pack->type);
94             }
95             $cb->($ssh, $pack);
96             });
97             };
98              
99             *Net::SSH::Perl::Packet::read = sub {
100             my $class = shift;
101             my $ssh = shift;
102             my $cb = shift;
103             my $sock = $ssh->sock;
104             if (my $packet = $class->read_poll($ssh)) {
105             $cb->($ssh, $packet);
106             }
107             else {
108             $sock->push_read(chunk => 4 => sub {
109             my ($hdl, $buf) = @_;
110             if (length($buf) == 0) {
111             croak "Connection closed by remote host." if !$buf;
112             }
113             if (!defined $buf) {
114             next if $! == EAGAIN || $! == EWOULDBLOCK;
115             croak "Read from socket failed: $!";
116             }
117             # Untaint data read from sshd. This is binary data,
118             # so there's nothing to taint-check against/for.
119             ($buf) = $buf =~ /(.*)/s;
120             $ssh->incoming_data->append($buf);
121             $class->read($ssh, $cb);
122             })
123             }
124             };
125             use Net::SSH::Perl::Kex;
126             *Net::SSH::Perl::Kex::exchange_kexinit = sub {
127             my $kex = shift;
128             my $ssh = $kex->{ssh};
129             my $received_packet = shift;
130             my $cb = shift;
131             my $packet;
132            
133             $packet = $ssh->packet_start(SSH2_MSG_KEXINIT);
134             $packet->put_chars($kex->client_kexinit->bytes);
135             $packet->send;
136            
137             if ( defined $received_packet ) {
138             $ssh->debug("Received key-exchange init (KEXINIT), sent response.");
139             $packet = $received_packet;
140             }
141             else {
142             $ssh->debug("Sent key-exchange init (KEXINIT), wait response.");
143             Net::SSH::Perl::Packet->read_expect($ssh, SSH2_MSG_KEXINIT, sub{
144             my ($ssh, $packet) = @_;
145             $kex->{server_kexinit} = $packet->data;
146            
147             $packet->get_char for 1..16;
148             my @s_props = map $packet->get_str, 1..10;
149             $packet->get_int8;
150             $packet->get_int32;
151             $cb->($ssh, \@s_props);
152             });
153             }
154             };
155             *Net::SSH::Perl::Kex::exchange = sub {
156             my $kex = shift;
157             my $ssh = $kex->{ssh};
158             my $packet = shift;
159             my $cb = shift;
160            
161             my @proposal = @PROPOSAL;
162             if (!$ssh->config->get('ciphers')) {
163             if (my $c = $ssh->config->get('cipher')) {
164             $ssh->config->set('ciphers', $c);
165             }
166             }
167             if (my $cs = $ssh->config->get('ciphers')) {
168             # SSH2 cipher names are different; for compatibility, we'll map
169             # valid SSH1 ciphers to the SSH2 equivalent names
170             if($ssh->protocol eq PROTOCOL_SSH2) {
171             my %ssh2_cipher = reverse %Net::SSH::Perl::Cipher::CIPHERS_SSH2;
172             $cs = join ',', map $ssh2_cipher{$_} || $_, split(/,/, $cs);
173             }
174             $proposal[ PROPOSAL_CIPH_ALGS_CTOS ] =
175             $proposal[ PROPOSAL_CIPH_ALGS_STOC ] = $cs;
176             }
177             if ($ssh->config->get('compression')) {
178             $proposal[ PROPOSAL_COMP_ALGS_CTOS ] =
179             $proposal[ PROPOSAL_COMP_ALGS_STOC ] = "zlib";
180             }
181             else {
182             $proposal[ PROPOSAL_COMP_ALGS_CTOS ] =
183             $proposal[ PROPOSAL_COMP_ALGS_STOC ] = "none";
184             }
185             if ($ssh->config->get('host_key_algorithms')) {
186             $proposal[ PROPOSAL_SERVER_HOST_KEY_ALGS ] =
187             $ssh->config->get('host_key_algorithms');
188             }
189            
190             $kex->{client_kexinit} = $kex->kexinit(\@proposal);
191             $kex->exchange_kexinit($packet, sub{
192             my ($ssh, $sprop) = @_;
193             $kex->choose_conf(\@proposal, $sprop);
194             $ssh->debug("Algorithms, c->s: " .
195             "$kex->{ciph_name}[0] $kex->{mac_name}[0] $kex->{comp_name}[0]");
196             $ssh->debug("Algorithms, s->c: " .
197             "$kex->{ciph_name}[1] $kex->{mac_name}[1] $kex->{comp_name}[1]");
198            
199             bless $kex, $kex->{class_name};
200             $kex->exchange(sub{
201             my $ssh = shift;
202             $ssh->debug("Waiting for NEWKEYS message.");
203             Net::SSH::Perl::Packet->read_expect($ssh, SSH2_MSG_NEWKEYS, sub{
204             my ($ssh, $packet) = @_;
205             $ssh->debug("Send NEWKEYS.");
206             $packet = $ssh->packet_start(SSH2_MSG_NEWKEYS);
207             $packet->send;
208            
209             $ssh->debug("Enabling encryption/MAC/compression.");
210             $ssh->{kex} = $kex;
211             for my $att (qw( mac ciph comp )) {
212             $kex->{$att}[0]->enable if $kex->{$att}[0];
213             $kex->{$att}[1]->enable if $kex->{$att}[1];
214             }
215             $cb->($ssh);
216             });
217             });
218            
219             });
220             };
221             use Net::SSH::Perl::Kex::DH1;
222             no strict "subs";
223             *Net::SSH::Perl::Kex::DH1::exchange = sub {
224             package Net::SSH::Perl::Kex::DH1;
225             my $kex = shift;
226             my $ssh = $kex->{ssh};
227             my $packet;
228             my $dh = _dh_new_group1;
229             my $cb = shift;
230              
231             $ssh->debug("Entering Diffie-Hellman Group 1 key exchange.");
232             $packet = $ssh->packet_start(SSH2_MSG_KEXDH_INIT);
233             $packet->put_mp_int($dh->pub_key);
234             $packet->send;
235              
236             $ssh->debug("Sent DH public key, waiting for reply.");
237             Net::SSH::Perl::Packet->read_expect($ssh,
238             SSH2_MSG_KEXDH_REPLY, sub {
239             my ($ssh, $packet) = @_;
240             my $host_key_blob = $packet->get_str;
241             my $s_host_key = Net::SSH::Perl::Key->new_from_blob($host_key_blob,
242             \$ssh->{datafellows});
243             $ssh->debug("Received host key, type '" . $s_host_key->ssh_name . "'.");
244              
245             $ssh->check_host_key($s_host_key);
246              
247             my $dh_server_pub = $packet->get_mp_int;
248             my $signature = $packet->get_str;
249              
250             $ssh->fatal_disconnect("Bad server public DH value")
251             unless _pub_is_valid($dh, $dh_server_pub);
252              
253             $ssh->debug("Computing shared secret key.");
254             my $shared_secret = $dh->compute_key($dh_server_pub);
255              
256             my $hash = $kex->kex_hash(
257             $ssh->client_version_string,
258             $ssh->server_version_string,
259             $kex->client_kexinit,
260             $kex->server_kexinit,
261             $host_key_blob,
262             $dh->pub_key,
263             $dh_server_pub,
264             $shared_secret);
265              
266             $ssh->debug("Verifying server signature.");
267             croak "Key verification failed for server host key"
268             unless $s_host_key->verify($signature, $hash);
269              
270             $ssh->session_id($hash);
271              
272             $kex->derive_keys($hash, $shared_secret, $ssh->session_id);
273             $cb->($ssh);
274             });
275             };
276             use Net::SSH::Perl::AuthMgr;
277             no warnings qw(redefine);
278             #no strict "refs";
279             *Net::SSH::Perl::AuthMgr::new = sub {
280             my $class = shift;
281             my $ssh = shift;
282             my $amgr = bless { ssh => $ssh }, $class;
283             weaken $amgr->{ssh};
284             $amgr;
285             };
286             *Net::SSH::Perl::AuthMgr::run = sub {
287             my $amgr = shift;
288             my $cb = pop @_;
289             my($end, @args) = @_;
290             Net::SSH::Perl::Packet->read($amgr->{ssh}, sub{
291             my ($ssh, $packet) = @_;
292             my $code = $amgr->handler_for($packet->type);
293             unless (defined $code) {
294             $code = $amgr->error_handler ||
295             sub { croak "Protocol error: received type ", $packet->type };
296             }
297             $code->($amgr, $packet, @args);
298             if ($$end) {
299             $cb->($amgr);
300             return;
301             }
302             $amgr->run($end, $cb);
303             });
304             };
305             *Net::SSH::Perl::AuthMgr::authenticate = sub {
306             package Net::SSH::Perl::AuthMgr;
307             my $amgr = shift;
308             my $cb = shift;
309             $amgr->init(sub{
310             my ($ssh, $amgr) = @_;
311             my($packet);
312            
313             my $valid = 0;
314             $amgr->{_done} = 0;
315             $amgr->register_handler(SSH2_MSG_USERAUTH_SUCCESS, sub {
316             $valid++;
317             $amgr->{_done}++
318             });
319             $amgr->register_handler(SSH2_MSG_USERAUTH_BANNER, sub {
320             my $amgr = shift;
321             my($packet) = @_;
322             if ($amgr->{ssh}->config->get('interactive')) {
323             print $packet->get_str, "\n";
324             }
325             });
326             $amgr->register_handler(SSH2_MSG_USERAUTH_FAILURE, \&auth_failure);
327             $amgr->register_error(
328             sub { croak "userauth error: bad message during auth" } );
329             $amgr->run( \$amgr->{_done}, sub{
330             my ($amgr) = shift;
331             $amgr->{agent}->close_socket if $amgr->{agent};
332            
333             $cb->($ssh, $amgr, $valid);
334             } );
335            
336             });
337             };
338              
339             *Net::SSH::Perl::AuthMgr::init = sub {
340             package Net::SSH::Perl::AuthMgr;
341             my $amgr = shift;
342             my $cb = shift;
343             my $ssh = $amgr->{ssh};
344             my($packet);
345            
346             $ssh->debug("Sending request for user-authentication service.");
347             $packet = $ssh->packet_start(SSH2_MSG_SERVICE_REQUEST);
348             $packet->put_str("ssh-userauth");
349             $packet->send;
350            
351             Net::SSH::Perl::Packet->read($ssh, sub {
352             my ($ssh, $packet) = @_;
353             croak "Server denied SSH2_MSG_SERVICE_ACCEPT: ", $packet->type
354             unless $packet->type == SSH2_MSG_SERVICE_ACCEPT;
355             $ssh->debug("Service accepted: " . $packet->get_str . ".");
356            
357             $amgr->{agent} = Net::SSH::Perl::Agent->new(2);
358             $amgr->{service} = "ssh-connection";
359            
360             $amgr->send_auth_none;
361             $cb->($ssh, $amgr);
362             });
363            
364             };
365             };
366             use Carp qw( croak );
367              
368             sub VERSION { $VERSION }
369              
370             sub new {
371             my $class = shift;
372             my $host = shift;
373             croak "usage: ", __PACKAGE__, "->new(\$host)"
374             unless defined $host;
375             my $ssh = bless { host => $host }, $class;
376             my %p = @_;
377             $ssh->{_test} = delete $p{_test};
378             $ssh->_init(%p);
379             $ssh;
380             }
381              
382             sub _init {
383             my $ssh = shift;
384              
385             my %arg = @_;
386             my $user_config = delete $arg{user_config} || "$ENV{HOME}/.ssh/config";
387             my $sys_config = delete $arg{sys_config} || "/etc/ssh_config";
388              
389             my $directives = delete $arg{options} || [];
390              
391             if (my $proto = delete $arg{protocol}) {
392             push @$directives, "Protocol $proto";
393             }
394              
395             my $cfg = Net::SSH::Perl::Config->new($ssh->{host}, %arg);
396             $ssh->{config} = $cfg;
397              
398             # Merge config-format directives given through "options"
399             # (just like -o option to ssh command line). Do this before
400             # reading config files so we override files.
401             for my $d (@$directives) {
402             $cfg->merge_directive($d);
403             }
404              
405             for my $f (($user_config, $sys_config)) {
406             $ssh->debug("Reading configuration data $f");
407             $cfg->read_config($f);
408             }
409              
410             if (my $real_host = $ssh->{config}->get('hostname')) {
411             $ssh->{host} = $real_host;
412             }
413              
414             my $user = _current_user();
415             if ($user && $user eq "root" &&
416             !defined $ssh->{config}->get('privileged')) {
417             $ssh->{config}->set('privileged', 1);
418             }
419              
420             unless ($ssh->{config}->get('protocol')) {
421             $ssh->{config}->set('protocol',
422             PROTOCOL_SSH1 | PROTOCOL_SSH2 | PROTOCOL_SSH1_PREFERRED);
423             }
424              
425             unless (defined $ssh->{config}->get('password_prompt_login')) {
426             $ssh->{config}->set('password_prompt_login', 1);
427             }
428             unless (defined $ssh->{config}->get('password_prompt_host')) {
429             $ssh->{config}->set('password_prompt_host', 1);
430             }
431              
432             unless (defined $ssh->{config}->get('number_of_password_prompts')) {
433             $ssh->{config}->set('number_of_password_prompts', 3);
434             }
435              
436             # login
437             if (!defined $ssh->{config}->get('user')) {
438             $ssh->{config}->set('user',
439             defined $arg{user} ? $arg{user} : _current_user());
440             }
441             if (!defined $arg{pass} && exists $CONFIG->{ssh_password}) {
442             $arg{pass} = $CONFIG->{ssh_password};
443             }
444             $ssh->{config}->set('pass', $arg{pass});
445              
446             #my $suppress_shell = $_[2];
447             }
448              
449             sub _current_user {
450             my $user;
451             eval { $user = scalar getpwuid $> };
452             return $user;
453             }
454              
455             sub set_protocol {
456             my $ssh = shift;
457             my $proto = shift;
458             $ssh->{use_protocol} = $proto;
459             $ssh->debug($ssh->version_string);
460             $ssh->_proto_init;
461             }
462              
463              
464             sub _dup {
465             my($fh, $mode) = @_;
466             my $dup = Symbol::gensym;
467             my $str = "${mode}&$fh";
468             open ($dup, $str) or die "Could not dupe: $!\n"; ## no critic
469             $dup;
470             }
471              
472             sub version_string {
473             my $class = shift;
474             sprintf "Net::SSH::Perl Version %s, protocol version %s.%s.",
475             $class->VERSION, PROTOCOL_MAJOR_2, PROTOCOL_MINOR_2;
476             }
477              
478             sub _exchange_identification {
479             my $ssh = shift;
480             my $remote_id = $ssh->_read_version(@_);
481             ($ssh->{server_version_string} = $remote_id) =~ s/\cM?$//;
482             my($remote_major, $remote_minor, $remote_version) = $remote_id =~
483             /^SSH-(\d+)\.(\d+)-([^\n]+)$/;
484             $ssh->debug("Remote protocol version $remote_major.$remote_minor, remote software version $remote_version");
485              
486             my $proto = $ssh->config->get('protocol');
487             my($mismatch, $set_proto);
488             if ($remote_major == 1) {
489             if ($remote_minor == 99 && $proto & PROTOCOL_SSH2 &&
490             !($proto & PROTOCOL_SSH1_PREFERRED)) {
491             $set_proto = PROTOCOL_SSH2;
492             }
493             elsif (!($proto & PROTOCOL_SSH1)) {
494             $mismatch = 1;
495             }
496             else {
497             $set_proto = PROTOCOL_SSH1;
498             }
499             }
500             elsif ($remote_major == 2) {
501             if ($proto & PROTOCOL_SSH2) {
502             $set_proto = PROTOCOL_SSH2;
503             }
504             }
505             if ($mismatch) {
506             croak sprintf "Protocol major versions differ: %d vs. %d",
507             ($proto & PROTOCOL_SSH2) ? PROTOCOL_MAJOR_2 :
508             PROTOCOL_MAJOR_1, $remote_major;
509             }
510             my $compat20 = $set_proto == PROTOCOL_SSH2;
511             my $buf = sprintf "SSH-%d.%d-%s\n",
512             $compat20 ? PROTOCOL_MAJOR_2 : PROTOCOL_MAJOR_1,
513             $compat20 ? PROTOCOL_MINOR_2 : PROTOCOL_MINOR_1,
514             $VERSION;
515             $ssh->{client_version_string} = substr $buf, 0, -1;
516             my $handle = $ssh->{session}{sock};
517             $handle->push_write($buf);
518             $ssh->set_protocol($set_proto);
519             $ssh->_compat_init($remote_version);
520             }
521              
522             sub _proto_init {
523             my $ssh = shift;
524             my $home = $ENV{HOME} || (getpwuid($>))[7];
525             unless ($ssh->{config}->get('user_known_hosts')) {
526             defined $home or croak "Cannot determine home directory, please set the environment variable HOME";
527             $ssh->{config}->set('user_known_hosts', "$home/.ssh/known_hosts2");
528             }
529             unless ($ssh->{config}->get('global_known_hosts')) {
530             $ssh->{config}->set('global_known_hosts', "/etc/ssh_known_hosts2");
531             }
532             unless (my $if = $ssh->{config}->get('identity_files')) {
533             defined $home or croak "Cannot determine home directory, please set the environment variable HOME";
534             $ssh->{config}->set('identity_files', [ "$home/.ssh/id_dsa" ]);
535             }
536              
537             for my $a (qw( password dsa kbd_interactive )) {
538             $ssh->{config}->set("auth_$a", 1)
539             unless defined $ssh->{config}->get("auth_$a");
540             }
541             }
542              
543             sub kex { $_[0]->{kex} }
544              
545             sub register_handler {
546             my($ssh, $type, $sub, @extra) = @_;
547             $ssh->{client_handlers}{$type} = { code => $sub, extra => \@extra };
548             }
549              
550             sub connect {
551             my $ssh = shift;
552             my($type, @args) = @_;
553             $ssh->{session}{sock} = new AnyEvent::Handle
554             connect => [
555             $ssh->{host} => $ssh->{config}->get('port') || 'ssh'
556             ],
557             on_error => sub {
558             my ($hdl, $fatal, $msg) = @_;
559             $ssh->debug("Can't connect to $ssh->{host}, port $ssh->{config}->get('port'): $msg");
560             $hdl->destroy;
561             },
562             on_connect_error => sub {
563             $ssh->debug("Can't connect to $ssh->{host}, port $ssh->{config}->get('port'): $!");
564             },
565             on_eof => sub {
566             shift->destroy; # explicitly destroy handle
567             };
568             $ssh->{session}{sock}->push_read( line => sub {
569             my ($handle, $line) = @_;
570             $ssh->_exchange_identification($line);
571             $ssh->debug("Connection established.");
572             $ssh->_login();
573              
574              
575             });
576             }
577              
578             sub _login {
579             my $ssh = shift;
580              
581             my $kex = Net::SSH::Perl::Kex->new($ssh);
582             $kex->exchange(undef, sub{
583             my $ssh = shift;
584             my $amgr = Net::SSH::Perl::AuthMgr->new($ssh);
585             $amgr->authenticate(sub{
586             my ($ssh, $amgr, $valid) = @_;
587             $ssh->debug("Login completed, opening dummy shell channel.");
588             my $cmgr = $ssh->channel_mgr;
589             my $channel = $cmgr->new_channel(
590             ctype => 'session', local_window => 0,
591             local_maxpacket => 0, remote_name => 'client-session');
592             $channel->open;
593              
594             Net::SSH::Perl::Packet->read_expect($ssh,
595             SSH2_MSG_CHANNEL_OPEN_CONFIRMATION, sub{
596             my ($ssh, $packet) = @_;
597             $cmgr->input_open_confirmation($packet);
598              
599             #my $suppress_shell = $_[2];
600             #unless ($suppress_shell) {
601             # $ssh->debug("Got channel open confirmation, requesting shell.");
602             # $channel->request("shell", 0);
603             #}
604              
605             $ssh->emit('_cmd');
606             $ssh->emit('_shell');
607             $ssh->client_loop;
608             });
609             });
610             })
611             }
612              
613             sub emit {
614             my ($self, $name) = (shift, shift);
615              
616             if (my $s = $self->{events}{$name}) {
617             $self->debug("-- Emit $name in @{[blessed $self]} (@{[scalar @$s]})\n");
618             for my $arg (@$s) {
619             $self->$name(@$arg)
620             }
621             }
622             else {
623             $self->debug("-- Emit $name in @{[blessed $self]} (0)\n");
624             die "@{[blessed $self]}: $_[0]" if $name eq 'error';
625             }
626              
627             return $self;
628             }
629              
630             sub _session_channel {
631             my $ssh = shift;
632             my $cmgr = $ssh->channel_mgr;
633              
634             my $channel = $cmgr->new_channel(
635             ctype => 'session', local_window => 32*1024,
636             local_maxpacket => 16*1024, remote_name => 'client-session',
637             rfd => _dup('STDIN', '<'), wfd => _dup('STDOUT', '>'),
638             efd => _dup('STDERR', '>'));
639              
640             $channel;
641             }
642              
643             sub _make_input_channel_req {
644             my($r_exit) = @_;
645             return sub {
646             my($channel, $packet) = @_;
647             my $rtype = $packet->get_str;
648             my $reply = $packet->get_int8;
649             $channel->{ssh}->debug("input_channel_request: rtype $rtype reply $reply");
650             if ($rtype eq "exit-status") {
651             $$r_exit = $packet->get_int32;
652             }
653             if ($reply) {
654             my $r_packet = $channel->{ssh}->packet_start(SSH2_MSG_CHANNEL_SUCCESS);
655             $r_packet->put_int($channel->{remote_id});
656             $r_packet->send;
657             }
658             };
659             }
660              
661             sub on { push @{$_[0]->{events}{$_[1]}}, [$_[-2], $_[-1]] }
662              
663             sub cmd {
664             my ($ssh, $cmd, $cb) = @_;
665             $ssh->on(_cmd => $cmd => $cb);
666             $ssh;
667             }
668              
669             sub _cmd {
670             my $ssh = shift;
671             my($cmd, $cb) = @_;
672              
673             my $cmgr = $ssh->channel_mgr;
674             my $channel = $ssh->_session_channel;
675             $channel->open;
676              
677              
678             $channel->register_handler(SSH2_MSG_CHANNEL_OPEN_CONFIRMATION, sub {
679             my($channel, $packet) = @_;
680              
681             ## Experimental pty support:
682             if ($ssh->{config}->get('use_pty')) {
683             $ssh->debug("Requesting pty.");
684              
685             my $packet = $channel->request_start('pty-req', 0);
686              
687             my($term) = $ENV{TERM} =~ /(\w+)/;
688             $packet->put_str($term);
689             my $foundsize = 0;
690             if (eval "require Term::ReadKey") {
691             my @sz = Term::ReadKey::GetTerminalSize($ssh->sock);
692             if (defined $sz[0]) {
693             $foundsize = 1;
694             $packet->put_int32($sz[1]); # height
695             $packet->put_int32($sz[0]); # width
696             $packet->put_int32($sz[2]); # xpix
697             $packet->put_int32($sz[3]); # ypix
698             }
699             }
700             if (!$foundsize) {
701             $packet->put_int32(0) for 1..4;
702             }
703              
704             # Array used to build Pseudo-tty terminal modes; fat commas separate opcodes from values for clarity.
705             my $terminal_mode_string;
706             if(!defined($ssh->{config}->get('terminal_mode_string'))) {
707             my @terminal_modes = (
708             5 => 0,0,0,4, # VEOF => 0x04 (^d)
709             0 # string must end with a 0 opcode
710             );
711             for my $char (@terminal_modes) {
712             $terminal_mode_string .= chr($char);
713             }
714             }
715             else {
716             $terminal_mode_string = $ssh->{config}->get('terminal_mode_string');
717             }
718             $packet->put_str($terminal_mode_string);
719             $packet->send;
720             }
721              
722             my $r_packet = $channel->request_start("exec", 0);
723             $r_packet->put_str($cmd);
724             $r_packet->send;
725              
726             });
727              
728             my($exit);
729             $channel->register_handler(SSH2_MSG_CHANNEL_REQUEST,
730             _make_input_channel_req(\$exit));
731              
732             my $h = $ssh->{client_handlers};
733             my($stdout, $stderr);
734             if (my $r = $h->{stdout}) {
735             $channel->register_handler("_output_buffer",
736             $r->{code}, @{ $r->{extra} });
737             }
738             else {
739             $channel->register_handler("_output_buffer", sub {
740             $stdout .= $_[1]->bytes;
741             });
742             }
743             if (my $r = $h->{stderr}) {
744             $channel->register_handler("_extended_buffer",
745             $r->{code}, @{ $r->{extra} });
746             }
747             else {
748             $channel->register_handler("_extended_buffer", sub {
749             $stderr .= $_[1]->bytes;
750             });
751             }
752              
753             $ssh->debug("Entering interactive session.");
754             $channel->{cb} = sub {
755             my $ssh = shift;
756             $cb->($ssh, $stdout, $stderr);
757             }
758            
759             }
760             sub shell {
761             my $ssh = shift;
762             my $cb = shift;
763             $ssh->on(_shell => '');
764             $ssh->on(on_fininsh => $cb);
765             $ssh;
766             }
767             sub _shell {
768             my $ssh = shift;
769             my $cmgr = $ssh->channel_mgr;
770             my $channel = $ssh->_session_channel;
771             $channel->open;
772              
773             $channel->register_handler(SSH2_MSG_CHANNEL_OPEN_CONFIRMATION, sub {
774             my($channel, $packet) = @_;
775             my $r_packet = $channel->request_start('pty-req', 0);
776             my($term) = $ENV{TERM} =~ /(\S+)/;
777             $r_packet->put_str($term);
778             my $foundsize = 0;
779             if (eval "require Term::ReadKey") {
780             my @sz = Term::ReadKey::GetTerminalSize($ssh->sock);
781             if (defined $sz[0]) {
782             $foundsize = 1;
783             $r_packet->put_int32($sz[1]); # height
784             $r_packet->put_int32($sz[0]); # width
785             $r_packet->put_int32($sz[2]); # xpix
786             $r_packet->put_int32($sz[3]); # ypix
787             }
788             }
789             if (!$foundsize) {
790             $r_packet->put_int32(0) for 1..4;
791             }
792             $r_packet->put_str("");
793             $r_packet->send;
794             $channel->{ssh}->debug("Requesting shell.");
795             $channel->request("shell", 0);
796             });
797              
798             my($exit);
799             $channel->register_handler(SSH2_MSG_CHANNEL_REQUEST,
800             _make_input_channel_req(\$exit));
801              
802             $channel->register_handler("_output_buffer", sub {
803             syswrite STDOUT, $_[1]->bytes;
804             });
805             $channel->register_handler("_extended_buffer", sub {
806             syswrite STDERR, $_[1]->bytes;
807             });
808              
809             $ssh->debug("Entering interactive session.");
810             }
811              
812              
813             sub break_client_loop { $_[0]->{ek_client_loopcl_quit_pending} = 1 }
814             sub restore_client_loop { $_[0]->{_cl_quit_pending} = 0 }
815             sub _quit_pending { $_[0]->{_cl_quit_pending} }
816              
817             sub client_loop {
818             my $ssh = shift;
819             $ssh->{_cl_quit_pending} = 0;
820             my $cmgr = $ssh->channel_mgr;
821             my $h = $cmgr->handlers;
822             $ssh->event($cmgr, $h);
823             }
824              
825             sub event {
826             my ($ssh, $cmgr, $h, $cb) = @_;
827             return $ssh->emit('on_finish') if $ssh->_quit_pending;
828             while (my $packet = Net::SSH::Perl::Packet->read_poll($ssh)) {
829             if (my $code = $h->{ $packet->type }) {
830             $code->($cmgr, $packet);
831             }
832             else {
833             $ssh->debug("Warning: ignore packet type " . $packet->type);
834             }
835             }
836              
837             return $ssh->emit('on_finish') if $ssh->_quit_pending;
838              
839             $cmgr->process_output_packets;
840              
841             # 如果处理完了. 关掉所有的连接
842             # 之所以在这进行这个操作是因为主 channel 也需要操作
843             for my $c (@{ $cmgr->{channels} }) {
844             next unless defined $c;
845             if ($c->{wfd} &&
846             $c->{extended}->length == 0 &&
847             $c->{output}->length == 0 &&
848             $c->{ostate} == CHAN_OUTPUT_WAIT_DRAIN ) {
849             $c->obuf_empty;
850             }
851             # 上面 obuf_empty 会给 ostate 变成 CHAN_OUTPUT_CLOSED
852             # 下面这个就会发关闭给远程
853             if ($c->delete_if_full_closed) {
854             defined $c->{cb} ? $c->{cb}->() : '';
855             $cmgr->remove($c->{id});
856             }
857             }
858            
859             my $oc = grep { defined } @{ $cmgr->{channels} };
860             return $ssh->emit('on_finish') unless $oc > 1;
861              
862             my $cv = AE::cv sub {
863             my $result = shift->recv;
864             delete $ssh->{watcher};
865             $ssh->event($cmgr, $h, $cb);
866             };
867              
868             # 这是处理频道上的输出, 客户端的输入
869             for my $c (@{ $cmgr->{channels} }) {
870             next unless defined $c;
871             my $id = $c->{id};
872             if ($c->{rfd} && $c->{istate} == CHAN_INPUT_OPEN &&
873             $c->{remote_window} > 0 &&
874             $c->{input}->length < $c->{remote_window}) {
875             $ssh->{watcher}{$id}{rfd} = AE::io $c->{rfd}, 0, sub {
876             # 顺序记录 - 频道 - rfd
877             my $buf;
878             sysread $c->{rfd}, $buf, 8192;
879             ($buf) = $buf =~ /(.*)/s;
880             $c->send_data($buf);
881             $cv->send('rfd');
882             delete $ssh->{watcher}{$id}{rfd}
883             };
884             }
885              
886             # 给内容输出
887             if (defined $c->{wfd} &&
888             $c->{ostate} == CHAN_OUTPUT_OPEN ||
889             $c->{ostate} == CHAN_OUTPUT_WAIT_DRAIN) {
890             if ($c->{output} and $c->{output}->length > 0) {
891             $ssh->{watcher}{$id}{wfd} = AE::io $c->{wfd}, 1, sub {
892             if (my $r = $c->{handlers}{"_output_buffer"}) {
893             $r->{code}->( $c, $c->{output}, @{ $r->{extra} } );
894             }
895             $c->{local_consumed} += $c->{output}->length;
896             $c->{output}->empty;
897             $cv->send('wfd');
898             delete $ssh->{watcher}{$id}{wfd}
899             }
900             }
901             }
902            
903             if ($c->{efd} && $c->{extended}->length > 0) {
904             my $c->{watcher}{$id}{efd} = AE::io $c->{efd}, 1, sub {
905             if (my $r = $c->{handlers}{"_extended_buffer"}) {
906             $r->{code}->( $c, $c->{extended}, @{ $r->{extra} } );
907             }
908             $c->{local_consumed} += $c->{extended}->length;
909             $c->{extended}->empty;
910             $cv->send('efd');
911             delete $ssh->{watcher}{$id}{efd}
912             };
913             }
914              
915            
916             # 原进程
917             $c->check_window;
918             if ($c->delete_if_full_closed) {
919             defined $c->{cb} ? $c->{cb}->() : '';
920             $cmgr->remove($c->{id});
921             }
922             }
923              
924              
925             # 这是主连接的句柄
926             my $handle = $ssh->{session}{sock};
927             $handle->push_read( chunk => 4 => sub {
928             my ($handle, $buf) = @_;
929             if (!length($buf)) {
930             croak "Connection failed: $!\n";
931             }
932             $ssh->break_client_loop if length($buf) == 0;
933             ($buf) = $buf =~ /(.*)/s; ## Untaint data. Anything allowed.
934             $ssh->incoming_data->append($buf);
935             $cv->send('main');
936             });
937             }
938              
939             sub channel_mgr {
940             my $ssh = shift;
941             unless (defined $ssh->{channel_mgr}) {
942             $ssh->{channel_mgr} = Net::SSH::Perl::ChannelMgr->new($ssh);
943             }
944             $ssh->{channel_mgr};
945             }
946             sub _read_version {
947             my $ssh = shift;
948             my $line = shift;;
949             my $len = length $line;
950             unless(defined($len)) {
951             next if $! == EAGAIN || $! == EWOULDBLOCK;
952             croak "Read from socket failed: $!";
953             }
954             croak "Connection closed by remote host" if $len == 0;
955             croak "Version line too long: $line"
956             if substr($line, 0, 4) eq "SSH-" and length($line) > 255;
957             croak "Pre-version line too long: $line" if length($line) > 4*1024;
958             if (substr($line, 0, 4) ne "SSH-") {
959             $ssh->debug("Remote version string: $line");
960             }
961             return $line;
962             }
963             sub sock { $_[0]->{session}{sock} }
964              
965             1;
966             __END__