File Coverage

blib/lib/Net/SSH/Any.pm
Criterion Covered Total %
statement 27 181 14.9
branch 0 106 0.0
condition 0 67 0.0
subroutine 9 29 31.0
pod 11 13 84.6
total 47 396 11.8


line stmt bran cond sub pod time code
1             package Net::SSH::Any;
2              
3             our $VERSION = '0.09';
4              
5 1     1   446 use strict;
  1         1  
  1         24  
6 1     1   3 use warnings;
  1         2  
  1         18  
7 1     1   4 use warnings::register;
  1         1  
  1         100  
8 1     1   3 use Carp;
  1         1  
  1         39  
9              
10 1     1   13 use Net::SSH::Any::Util;
  1         5  
  1         120  
11 1     1   4 use Net::SSH::Any::URI;
  1         1  
  1         21  
12 1     1   319 use Net::SSH::Any::Constants qw(:error);
  1         2  
  1         130  
13 1     1   4 use Scalar::Util qw(dualvar);
  1         1  
  1         37  
14              
15 1     1   344 use Net::SSH::Any::_Base;
  1         1  
  1         1360  
16             our @ISA = qw(Net::SSH::Any::_Base);
17              
18             my $REQUIRED_BACKEND_VERSION = '2';
19             our @default_backends = qw(Net_OpenSSH Net_SSH2 Net_SSH_Perl Ssh_Cmd Plink_Cmd);
20              
21             sub _new {
22 0     0     my ($class, $opts) = @_;
23 0           my $any = $class->SUPER::_new($opts);
24 0   0       $opts->{uri} // $opts->{host} // croak "either host or uri argument must be given";
      0        
25 0   0       $opts->{password} //= delete $opts->{passwd};
26              
27 0           my @uri_opts = (port => 22);
28 0 0         if (defined (my $uri = delete $opts->{uri})) {
29 0 0 0       $uri = $uri->as_string if ref $uri and $uri->can('as_string');
30 0           push @uri_opts, uri => $uri;
31             }
32 0           for (qw(host user port password passphrase)) {
33 0 0         if (defined (my $v = delete $opts->{$_})) {
34 0           push @uri_opts, $_, $v;
35             }
36             }
37 0           my $uri = $any->{uri} = Net::SSH::Any::URI->new(@uri_opts);
38 0 0         unless ($uri) {
39 0           $any->_set_error(SSHA_CONNECTION_ERROR, "Unable to parse URI");
40 0           return $any;
41             }
42              
43 0 0         unless (defined $uri->user) {
44 0 0         if (defined (my $current_user = $any->_os_current_user)) {
45 0           $uri->user($current_user);
46             }
47             else {
48 0           $any->_set_error(SSHA_UNIMPLEMENTED_ERROR, "Unable to infer login name");
49 0           return $any;
50             }
51             }
52              
53 0 0 0       if (defined (my $key_paths = delete $opts->{key_path} // delete $opts->{key_paths})) {
54 0           $uri->or_set(key_path => _array_or_scalar_to_list($key_paths))
55             }
56              
57 0   0       $any->{io_timeout} = delete $opts->{io_timeout} // 120;
58 0           $any->{timeout} = delete $opts->{timeout};
59 0   0       $any->{remote_shell} = delete $opts->{remote_shell} // 'POSIX';
60 0           $any->{known_hosts_path} = delete $opts->{known_hosts_path};
61 0   0       $any->{strict_host_key_checking} = delete $opts->{strict_host_key_checking} // 1;
62 0   0       $any->{compress} = delete $opts->{compress} // 1;
63 0           $any->{backend_opts} = delete $opts->{backend_opts};
64 0           $any->{batch_mode} = delete $opts->{batch_mode};
65              
66 0   0       my @backends = _array_or_scalar_to_list(delete $opts->{backend} // delete $opts->{backends} // \@default_backends);
      0        
67 0           $any->{backends} = \@backends;
68              
69 0           for my $backend (@backends) {
70 0           $any->{error} = 0;
71 0 0         if ($any->_load_backend_module(__PACKAGE__, $backend, $REQUIRED_BACKEND_VERSION)) {
72 0 0         $any->{backend} or croak "internal error: backend not set";
73 0   0       my %backend_opts = map { $_ => $any->{$_} // scalar($uri->get($_)) }
  0            
74             qw(host port user password passphrase key_path timeout io_timeout
75             strict_host_key_checking known_hosts_path compress batch_mode);
76              
77              
78 0 0         if (my $extra = $any->{backend_opts}{$backend}) {
79 0           @backend_opts{keys %$extra} = values %$extra;
80             }
81             defined $backend_opts{$_} or delete $backend_opts{$_}
82 0   0       for keys %backend_opts;
83              
84 0 0         if ($any->_validate_backend_opts(%backend_opts)) {
85 0           $any->_connect;
86 0           return $any;
87             }
88 0 0         unless ($any->{error}) {
89 0           $any->_set_error(SSHA_BACKEND_ERROR, "internal error: _validate_backend_opts failed without setting the error");
90             }
91 0           $any->_log_error_and_reset_backend;
92             }
93             }
94 0           $any->_set_error(SSHA_NO_BACKEND_ERROR, "no backend available");
95 0           $any;
96             }
97              
98             sub new {
99 0     0 1   my $class = shift;
100 0 0         my %opts = (@_ & 1 ? (uri => @_) : @_);
101 0           $class->_new(\%opts);
102             }
103              
104             sub _clear_error {
105 0     0     my $any = shift;
106 0           my $error = $any->{error};
107 0 0 0       return if ( $error and
      0        
108             ( $error == SSHA_NO_BACKEND_ERROR or
109             $error == SSHA_BACKEND_ERROR or
110             $error == SSHA_CONNECTION_ERROR ) );
111 0           $any->{error} = 0;
112 0           1;
113             }
114              
115             sub _quoter {
116 0     0     my ($any, $shell) = @_;
117 0 0 0       if (defined $shell and $shell ne $any->{remote_shell}) {
118 0           return $any->_new_quoter($shell);
119             }
120 0   0       $any->{quoter} //= $any->_new_quoter($any->{remote_shell});
121             }
122              
123             sub _delete_stream_encoding_and_encode_input_data {
124 0     0     my ($any, $opts) = @_;
125 0 0         my $stream_encoding = $any->_delete_stream_encoding($opts) or return;
126 0 0 0       $debug and $debug & 1024 and _debug("stream_encoding: "
    0          
127             . ($stream_encoding ? $stream_encoding : '') );
128 0 0         if (defined(my $data = $opts->{stdin_data})) {
129 0           my @input = grep defined, _array_or_scalar_to_list $data;
130 0 0         $any->_encode_data($stream_encoding => @input) or return;
131 0           $opts->{stdin_data} = \@input;
132             }
133             $stream_encoding
134 0           }
135              
136             sub _check_child_error {
137 0     0     my $any = shift;
138 0 0         $any->error and return;
139 0 0         if ($?) {
140 0           $any->_set_error(SSHA_REMOTE_CMD_ERROR,
141             "remote command failed with code " . ($? >> 8)
142             . " and signal " . ($? & 255));
143 0           return;
144             }
145 0           return 1;
146             }
147              
148             _sub_options capture => qw(timeout stdin_data stderr_to_stdout stderr_discard
149             stderr_fh stderr_file);
150             sub capture {
151 0     0 1   my $any = shift;
152 0 0         $any->_clear_error or return undef;
153 0 0         my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0            
154 0 0         my $stream_encoding = $any->_delete_stream_encoding_and_encode_input_data(\%opts) or return;
155 0   0       my $cmd = $any->_quote_args(\%opts, @_) // return;
156 0           _croak_bad_options %opts;
157 0 0         my ($out) = $any->_capture(\%opts, $cmd) or return;
158 0           $any->_check_child_error;
159 0 0         if ($stream_encoding) {
160 0 0         $any->_decode_data($stream_encoding => $out) or return;
161             }
162 0 0         if (wantarray) {
163 0           my $pattern = quotemeta $/;
164 0           return split /(?<=$pattern)/, $out;
165             }
166             $out
167 0           }
168              
169             _sub_options capture2 => qw(timeout stdin_data);
170             sub capture2 {
171 0     0 1   my $any = shift;
172 0 0         $any->_clear_error or return undef;
173 0 0         my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0            
174 0 0         my $stream_encoding = $any->_delete_stream_encoding_and_encode_input_data(\%opts) or return;
175 0   0       my $cmd = $any->_quote_args(\%opts, @_) // return;
176 0           _croak_bad_options %opts;
177 0 0         my ($out, $err) = $any->_capture2(\%opts, $cmd) or return;
178 0           $any->_check_child_error;
179 0 0         if ($stream_encoding) {
180 0 0         $any->_decode_data($stream_encoding => $out) or return;
181 0 0         $any->_decode_data($stream_encoding => $err) or return;
182             }
183 0 0         wantarray ? ($out, $err) : $out
184             }
185              
186             _sub_options system => qw(timeout stdin_data stdin_file stdin_fh
187             stdout_fh stdout_file stdout_discard
188             stderr_to_stdout stderr_fh stderr_file stderr_discard
189             _window_size);
190             sub system {
191 0     0 1   my $any = shift;
192 0 0         $any->_clear_error or return undef;
193 0 0         my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0            
194 0 0         my $stream_encoding = $any->_delete_stream_encoding_and_encode_input_data(\%opts) or return;
195 0   0       my $cmd = $any->_quote_args(\%opts, @_) // return;
196 0           _croak_bad_options %opts;
197 0           $any->_system(\%opts, $cmd);
198 0           $any->_check_child_error;
199             }
200              
201             _sub_options dpipe => qw(stderr_to_stdout stderr_discard subsystem);
202             sub dpipe {
203 0     0 0   my $any = shift;
204 0 0         $any->_clear_error or return undef;
205 0 0         my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0            
206 0   0       my $cmd = $any->_quote_args(\%opts, @_) // return;
207 0           _croak_bad_options %opts;
208 0           $any->_dpipe(\%opts, $cmd);
209             }
210              
211             _sub_options sftp => qw(fs_encoding timeout block_size queue_size autoflush write_delay
212             read_ahead late_set_perm autodie remote_sftp_server_cmd ssh1);
213             sub sftp {
214 0     0 1   my ($any, %opts) = @_;
215              
216 0 0 0       $opts{timeout} //= $any->{timeout} if defined $any->{timeout};
217 0   0       $opts{fs_encoding} //= $any->_delete_argument_encoding(\%opts);
218              
219 0           _croak_bad_options %opts;
220 0 0         $any->_load_module('Net::SFTP::Foreign') or return;
221 0 0         if (my $sftp = $any->_sftp(\%opts)) {
222 0 0         if (my $error = $sftp->error) {
223 0           $any->_set_error(SSHA_SFTP_ERROR, 'Unable to start SFTP connection', $sftp->error);
224 0           return;
225             }
226 0           return $sftp;
227             }
228             else {
229 0           $any->_or_set_error(SSHA_SFTP_ERROR, 'Unable to start SFTP connection', 'Unknown error');
230             }
231             ()
232 0           }
233              
234             sub _helper_delegate {
235 0     0     my $any = shift;
236 0           my $class = shift;
237 0 0         $any->_load_module($class) or return;
238 0 0         my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0            
239 0 0         my $obj = $class->_new($any, \%opts, @_) or return;
240 0           $obj->run(\%opts);
241             }
242              
243             sub _wait_ssh_proc {
244 0     0     my ($any, $proc, $timeout, $force_kill) = @_;
245 0   0       $force_kill //= $any->{_kill_ssh_on_timeout};
246 0 0         if ($force_kill) {
247 0 0         $timeout = $any->{_timeout} unless defined $timeout;
248 0 0         $timeout = 0 if $any->error == SSHA_TIMEOUT_ERROR;
249             }
250              
251 0           $any->_os_wait_proc($proc, $timeout, $force_kill);
252             }
253              
254 0     0 1   sub scp_get { shift->_helper_delegate('Net::SSH::Any::SCP::Getter::Standard', @_) }
255 0     0 1   sub scp_get_content { shift->_helper_delegate('Net::SSH::Any::SCP::Getter::Content', @_) }
256 0     0 1   sub scp_mkdir { shift->_helper_delegate('Net::SSH::Any::SCP::Putter::DirMaker', @_) }
257 0     0 1   sub scp_put { shift->_helper_delegate('Net::SSH::Any::SCP::Putter::Standard', @_) }
258 0     0 1   sub scp_put_content { shift->_helper_delegate('Net::SSH::Any::SCP::Putter::Content', @_) }
259              
260             sub scp_find {
261 0     0 0   _warn("this feature is not finished yet");
262 0           shift->_helper_delegate('Net::SSH::Any::SCP::Getter::Finder', @_)
263             }
264              
265             sub autodetect {
266 0     0 1   my $any = shift;
267 0   0       my $auto = $any->_helper_delegate('Net::SSH::Any::Autodetector', @_) // return;
268 0 0         wantarray ? %$auto : $auto;
269             }
270              
271             1;
272              
273             __END__