File Coverage

blib/lib/Net/SFTP/Foreign/Backend/Net_SSH2.pm
Criterion Covered Total %
statement 19 21 90.4
branch n/a
condition n/a
subroutine 7 7 100.0
pod n/a
total 26 28 92.8


line stmt bran cond sub pod time code
1             package Net::SFTP::Foreign::Backend::Net_SSH2;
2              
3             our $VERSION = '0.09';
4              
5 1     1   26889 use strict;
  1         2  
  1         39  
6 1     1   5 use warnings;
  1         2  
  1         33  
7 1     1   971 use Time::HiRes qw(sleep);
  1         2126  
  1         5  
8              
9 1     1   222 use Carp;
  1         2  
  1         128  
10             our @CARP_NOT = qw(Net::SFTP::Foreign);
11              
12 1     1   1238 use Net::SFTP::Foreign::Helpers;
  1         3858  
  1         199  
13 1         119 use Net::SFTP::Foreign::Constants qw(SSH2_FX_BAD_MESSAGE
14 1     1   1241 SFTP_ERR_REMOTE_BAD_MESSAGE);
  1         2484  
15 1     1   519 use Net::SSH2;
  0            
  0            
16              
17             my $eagain_error = do {
18             local ($@, $SIG{__DIE__}, $SIG{__WARN__});
19             eval { Net::SSH2::LIBSSH2_ERROR_EAGAIN() };
20             };
21             unless (defined $eagain_error) {
22             $eagain_error = -1;
23             $debug and $debug & 131072 and _debug "The installed version of Net::SSH2 does not support LIBSSH2_ERROR_EGAIN";
24             }
25              
26             sub _new {
27             $debug and
28             _debug "Using Net_SSH2 backend, Net::SSH2 version $Net::SSH2::VERSION compiled against libssh2 "
29             . Net::SSH2->version;
30             my $class = shift;
31             my $self = {};
32             bless $self, $class;
33             }
34              
35             sub _defaults {
36             ( queue_size => 32 )
37             }
38              
39             sub _conn_failed {
40             my ($self, $sftp, $msg) = @_;
41             $sftp->_conn_failed(sprintf("%s: %s (%d): %s",
42             $msg,
43             ($self->{_ssh2}->error)[1, 0, 2]));
44             }
45              
46             sub _conn_lost {
47             my ($self, $sftp, $msg) = @_;
48             $sftp->_conn_lost(undef, undef,
49             sprintf("%s: %s (%d): %s",
50             $msg,
51             ($self->{_ssh2}->error)[1, 0, 2]));
52             }
53              
54             my %auth_arg_map = qw(host hostname
55             user username
56             passphrase password
57             local_user local_username
58             key_path privatekey);
59              
60             sub _init_transport {
61             my ($self, $sftp, $opts) = @_;
62             my $ssh2 = delete $opts->{ssh2};
63             if (defined $ssh2) {
64             $debug and $debug & 131072 and $ssh2->debug(1);
65             unless ($ssh2->auth_ok) {
66             $sftp->_conn_failed("Net::SSH2 object is not authenticated");
67             return;
68             }
69             }
70             else {
71             my %auth_args;
72             for (qw(rank username passphrase password publickey privatekey
73             hostname key_path local_user local_username interact
74             cb_keyboard cb_password user host)) {
75             my $map = $auth_arg_map{$_} || $_;
76             next if defined $auth_args{$map};
77             $auth_args{$map} = delete $opts->{$_} if exists $opts->{$_}
78             }
79              
80             if (defined $auth_args{privatekey} and not defined $auth_args{publickey}) {
81             $auth_args{publickey} = "$auth_args{privatekey}.pub";
82             }
83              
84             my $host = $auth_args{hostname};
85             defined $host or croak "sftp target host not defined";
86             my $port = delete $opts->{port} || 22;
87             %$opts and return;
88              
89             unless (defined $auth_args{username}) {
90             local $SIG{__DIE__};
91             $auth_args{username} = eval { scalar getpwuid $< };
92             defined $auth_args{username} or croak "required option 'user' missing";
93             }
94              
95             $ssh2 = $self->{_ssh2} = Net::SSH2->new();
96             $debug and $debug & 131072 and $ssh2->debug(1);
97              
98             unless ($ssh2->connect($host, $port)) {
99             $self->_conn_failed($sftp, "connection to remote host $host failed");
100             return;
101             }
102              
103             unless ($ssh2->auth(%auth_args)) {
104             $self->_conn_failed($sftp, "authentication failed");
105             return;
106             }
107             }
108              
109             my $channel = $self->{_channel} = $ssh2->channel;
110             unless (defined $channel) {
111             $self->_conn_failed($sftp, "unable to create new session channel");
112             return;
113             }
114             $channel->ext_data('ignore');
115             $self->{_ssh2} = $ssh2;
116             $channel->subsystem('sftp');
117             }
118              
119             sub _sysreadn {
120             my ($self, $sftp, $n) = @_;
121             my $channel = $self->{_channel};
122             my $bin = \$sftp->{_bin};
123             while (1) {
124             my $len = length $$bin;
125             return 1 if $len >= $n;
126             my $buf = '';
127             my $read = $channel->read($buf, $n - $len);
128             unless (defined $read) {
129             $debug and $debug & 32 and _debug("read failed: " . $self->{_ssh2}->error . ", n: $n, len: $len");
130             if ($self->{_ssh2}->error == $eagain_error) {
131             $debug and $debug & 32 and _debug "read error: EAGAIN, delaying before retrying";
132             sleep 0.01;
133             redo;
134             }
135             $self->_conn_lost($sftp, "read failed: " . $self->{_ssh2}->error);
136             return undef;
137             }
138             $sftp->{_read_total} += $read;
139             if ($debug and $debug & 32) {
140             _debug "$read bytes read from SSH channel, total $sftp->{_read_total}";
141             $debug & 2048 and $read and _hexdump($buf);
142             }
143             $$bin .= $buf;
144             }
145             return $n;
146             }
147              
148             sub _do_io {
149             my ($self, $sftp, $timeout) = @_;
150             my $channel = $self->{_channel};
151             return undef unless $sftp->{_connected};
152              
153             my $bin = \$sftp->{_bin};
154             my $bout = \$sftp->{_bout};
155              
156             while (length $$bout) {
157             my $buf = substr($$bout, 0, 20480);
158             my $written = $channel->write($buf);
159             unless ($written) {
160             if ($self->{_ssh2}->error == Net::SSH2::LIBSSH2_ERROR_EAGAIN()) {
161             $debug and $debug & 32 and _debug "write error: EAGAIN, delaying before retrying";
162             sleep 0.01;
163             redo;
164             }
165             $self->_conn_lost($sftp, "write failed: " . $self->{_ssh2}->error);
166             return undef;
167             }
168             $sftp->{_written_total} += $written;
169             if ($debug and $debug & 32) {
170             _debug("$written bytes written to SSH channel, total $sftp->{_written_total}");
171             $debug & 2048 and $written and _hexdump($$bout, 0, $written);
172             }
173             substr($$bout, 0, $written, "");
174             }
175              
176             defined $timeout and $timeout <= 0 and return;
177              
178             $self->_sysreadn($sftp, 4) or return undef;
179              
180             my $len = 4 + unpack N => $$bin;
181             if ($len > 256 * 1024) {
182             $sftp->_set_status(SSH2_FX_BAD_MESSAGE);
183             $sftp->_set_error(SFTP_ERR_REMOTE_BAD_MESSAGE,
184             "bad remote message received, len=$len");
185             return undef;
186             }
187             $self->_sysreadn($sftp, $len);
188             }
189              
190             sub _after_init {};
191              
192             sub DESTROY {
193             my $self = shift;
194             local ($@, $!, $?, $SIG{__DIE__});
195             eval {
196             $self->{_channel}->close;
197             undef $self->{_channel};
198             };
199             }
200              
201             1;
202              
203             __END__