File Coverage

blib/lib/Net/OpenSSH.pm
Criterion Covered Total %
statement 508 1403 36.2
branch 234 1078 21.7
condition 80 433 18.4
subroutine 47 125 37.6
pod 46 50 92.0
total 915 3089 29.6


line stmt bran cond sub pod time code
1             package Net::OpenSSH;
2              
3             our $VERSION = '0.83';
4              
5 5     5   270117 use strict;
  5         13  
  5         133  
6 5     5   24 use warnings;
  5         5  
  5         257  
7              
8             our $debug ||= 0;
9             our $debug_fh ||= \*STDERR;
10              
11             our $FACTORY;
12              
13 5     5   26 use Carp qw(carp croak);
  5         5  
  5         379  
14 5     5   2274 use POSIX qw(:sys_wait_h);
  5         30552  
  5         24  
15 5     5   6630 use Socket;
  5         3103  
  5         2015  
16 5     5   32 use File::Spec;
  5         9  
  5         128  
17 5     5   24 use Cwd ();
  5         10  
  5         58  
18 5     5   19 use Scalar::Util ();
  5         10  
  5         97  
19 5     5   2200 use Errno ();
  5         6477  
  5         128  
20 5     5   1948 use Net::OpenSSH::Constants qw(:error :_state);
  5         14  
  5         657  
21 5     5   1771 use Net::OpenSSH::ModuleLoader;
  5         10  
  5         198  
22 5     5   1687 use Net::OpenSSH::ShellQuoter;
  5         10  
  5         129  
23 5     5   29 use Digest::MD5;
  5         5  
  5         877  
24              
25             my $thread_generation = 0;
26              
27 0     0   0 sub CLONE { $thread_generation++ };
28              
29             sub _debug {
30 0     0   0 local ($!, $@);
31 0 0       0 print {$debug_fh} '# ', (map { defined($_) ? $_ : '' } @_), "\n"
  0         0  
  0         0  
32             }
33              
34             sub _debug_dump {
35 0     0   0 local ($!, $@);
36 0         0 require Data::Dumper;
37 0         0 local $Data::Dumper::Terse = 1;
38 0         0 local $Data::Dumper::Indent = 0;
39 0         0 my $head = shift;
40 0         0 _debug("$head: ", Data::Dumper::Dumper(@_));
41             }
42              
43             sub _hexdump {
44 5     5   30 no warnings qw(uninitialized);
  5         9  
  5         28013  
45 0     0   0 my $data = shift;
46 0         0 while ($data =~ /(.{1,32})/smg) {
47 0         0 my $line=$1;
48 0         0 my @c= (( map { sprintf "%02x",$_ } unpack('C*', $line)),
  0         0  
49             ((" ") x 32))[0..31];
50 0 0       0 $line=~s/(.)/ my $c=$1; unpack("c",$c)>=32 ? $c : '.' /egms;
  0         0  
  0         0  
51 0         0 print {$debug_fh} "#> ", join(" ", @c, '|', $line), "\n";
  0         0  
52             }
53             }
54              
55             {
56             my %good;
57              
58             sub _sub_options {
59 90     90   110 my $sub = shift;
60 90         118 $good{__PACKAGE__ . "::$sub"} = { map { $_ => 1 } @_ };
  1350         1831  
61             }
62              
63             sub _croak_bad_options (\%) {
64 9     9   18 my $opts = shift;
65 9 100       24 if (%$opts) {
66 3         21 my $sub = (caller 1)[3];
67 3         18 my $good = $good{$sub};
68 3 50       27 my @keys = grep defined($opts->{$_}), ( $good ? grep !$good->{$_}, keys %$opts : keys %$opts);
69 3 50       12 if (@keys) {
70 0         0 croak "Invalid or bad combination of options ('" . CORE::join("', '", @keys) . "')";
71             }
72             }
73             }
74             }
75              
76             sub _croak_scalar_context {
77 0     0   0 my ($sub, $wantarray) = (caller 1)[3, 5];
78 0 0       0 unless ($wantarray) {
79 0         0 $sub =~ s/^.*:://;
80 0         0 croak "method '$sub' called in scalar context";
81             }
82             }
83              
84             sub _tcroak {
85 0 0   0   0 if (${^TAINT} > 0) {
86 0         0 push @_, " while running with -T switch";
87 0         0 goto &croak;
88             }
89 0 0       0 if (${^TAINT} < 0) {
90 0         0 push @_, " while running with -t switch";
91 0         0 goto &carp;
92             }
93             }
94              
95             sub _catch_tainted_args {
96 0     0   0 my $i;
97 0         0 for (@_) {
98 0 0       0 next unless $i++;
99 0 0       0 if (Scalar::Util::tainted($_)) {
    0          
100 0         0 my (undef, undef, undef, $subn) = caller 1;
101 0 0       0 my $msg = ( $subn =~ /::([a-z]\w*)$/
102             ? "Insecure argument '$_' on '$1' method call"
103             : "Insecure argument '$_' on method call" );
104 0         0 _tcroak($msg);
105             }
106             elsif (ref($_) eq 'HASH') {
107 0         0 for (grep Scalar::Util::tainted($_), values %$_) {
108 0         0 my (undef, undef, undef, $subn) = caller 1;
109 0 0       0 my $msg = ( $subn =~ /::([a-z]\w*)$/
110             ? "Insecure argument on '$1' method call"
111             : "Insecure argument on method call" );
112 0         0 _tcroak($msg);
113             }
114             }
115             }
116             }
117              
118             sub _set_error {
119 3     3   7 my $self = shift;
120 3   100     19 my $code = shift || 0;
121 3         134 my @extra = grep defined, @_;
122             my $err = $self->{_error} = ( $code
123 3 50       14 ? Scalar::Util::dualvar($code, join(': ', @{$self->{_error_prefix}},
  1 100       24  
124             (@extra ? @extra : "Unknown error $code")))
125             : 0 );
126 3 50 33     32 $debug and $debug & 1 and _debug "set_error($code - $err)";
127 3         7 return $err
128             }
129              
130             my $check_eval_re = do {
131             my $path = quotemeta $INC{"Net/OpenSSH.pm"};
132             qr/at $path line \d+.$/
133             };
134              
135             sub _check_eval_ok {
136 0     0   0 my ($self, $code) = @_;
137 0 0       0 if ($@) {
138 0         0 my $err = $@;
139 0         0 $err =~ s/$check_eval_re//;
140 0         0 $self->_set_error($code, $err);
141 0         0 return;
142             }
143             1
144 0         0 }
145              
146             sub _or_set_error {
147 0     0   0 my $self = shift;
148 0 0       0 $self->{_error} or $self->_set_error(@_);
149             }
150              
151 33   100 33   111 sub _first_defined { defined && return $_ for @_; return }
  9         15  
152              
153             my $obfuscate = sub {
154             # just for the casual observer...
155             my $txt = shift;
156             $txt =~ s/(.)/chr(ord($1) ^ 47)/ges
157             if defined $txt;
158             $txt;
159             };
160              
161             my $deobfuscate = $obfuscate;
162              
163             # regexp from Regexp::IPv6
164             my $IPv6_re = qr((?-xism::(?::[0-9a-fA-F]{1,4}){0,5}(?:(?::[0-9a-fA-F]{1,4}){1,2}|:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})))|[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}:(?:[0-9a-fA-F]{1,4}|:)|(?::(?:[0-9a-fA-F]{1,4})?|(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))))|:(?:(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|[0-9a-fA-F]{1,4}(?::[0-9a-fA-F]{1,4})?|))|(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|:[0-9a-fA-F]{1,4}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){0,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,2}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,3}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))|(?:(?::[0-9a-fA-F]{1,4}){0,4}(?::(?:(?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2})[.](?:25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}))|(?::[0-9a-fA-F]{1,4}){1,2})|:))));
165              
166             sub parse_connection_opts {
167 22     22 0 5111 my ($class, $opts) = @_;
168 22         47 my ($user, $passwd, $ipv6, $host, $port, $host_squared);
169              
170 22         270 my $target = delete $opts->{host};
171 22 50       62 defined $target or croak "mandatory host argument missing";
172              
173 22 50       4166 ($user, $passwd, $ipv6, $host, $port) =
174             $target =~ m{^
175             \s* # space
176             (?:
177             ([^:]+) # username
178             (?::(.*))? # : password
179             \@ # @
180             )?
181             (?: # host
182             ( # IPv6...
183             \[$IPv6_re(?:\%[^\[\]]*)\] # [IPv6]
184             | # or
185             $IPv6_re # IPv6
186             )
187             | # or
188             ([^\[\]\@:]+) # hostname / ipv4
189             )
190             (?::([^\@:]+))? # port
191             \s* # space
192             $}ix
193             or croak "bad host/target '$target' specification";
194              
195 22 100       146 if (defined $ipv6) {
196 1         7 ($host) = $ipv6 =~ /^\[?(.*?)\]?$/;
197 1         4 $host_squared = "[$host]";
198             }
199             else {
200 21         37 $host_squared = $host;
201             }
202              
203 22 100       42 $user = delete $opts->{user} unless defined $user;
204 22 50       54 $port = delete $opts->{port} unless defined $port;
205 22 100       42 $passwd = delete $opts->{passwd} unless defined $passwd;
206 22 100       38 $passwd = delete $opts->{password} unless defined $passwd;
207              
208 22 100       78 wantarray and return ($host, $port, $user, $passwd, $host_squared);
209              
210 19         57 my %r = ( user => $user,
211             password => $passwd,
212             host => $host,
213             host_squared => $host_squared,
214             port => $port );
215 19 100       40 $r{ipv6} = 1 if defined $ipv6;
216 19         51 return \%r;
217             }
218              
219             my $sizeof_sun_path = ($^O eq 'linux' ? 108 :
220             $^O =~ /bsd/i ? 104 :
221             $^O eq 'hpux' ? 92 : undef);
222              
223             sub new {
224 3 50   3 1 3761013 ${^TAINT} and &_catch_tainted_args;
225              
226 3         27 my $class = shift;
227 3 50       42 @_ & 1 and unshift @_, 'host';
228              
229 3 50       21 return $FACTORY->($class, @_) if defined $FACTORY;
230              
231 3         45 my %opts = @_;
232              
233 3         18 my $external_master = delete $opts{external_master};
234             # reuse_master is an obsolete alias:
235 3 50       39 $external_master = delete $opts{reuse_master} unless defined $external_master;
236              
237 3 50 33     36 if (not defined $opts{host} and defined $external_master) {
238 0         0 $opts{host} = '0.0.0.0';
239             }
240              
241 3         45 my ($host, $port, $user, $passwd, $host_squared) = $class->parse_connection_opts(\%opts);
242              
243 3         9 my ($passphrase, $key_path, $login_handler);
244 3 50       12 unless (defined $passwd) {
245 3         6 $key_path = delete $opts{key_path};
246 3         6 $passwd = delete $opts{passphrase};
247 3 50       9 if (defined $passwd) {
248 0         0 $passphrase = 1;
249             }
250             else {
251 3         3 $login_handler = delete $opts{login_handler};
252             }
253             }
254              
255 3         6 my $ssh_version = delete $opts{ssh_version};
256 3         6 my $batch_mode = delete $opts{batch_mode};
257 3         6 my $ctl_path = delete $opts{ctl_path};
258 3         6 my $ctl_dir = delete $opts{ctl_dir};
259 3         6 my $proxy_command = delete $opts{proxy_command};
260 3 50       12 my $gateway = delete $opts{gateway} unless defined $proxy_command;
261 3         24 my $ssh_cmd = _first_defined delete $opts{ssh_cmd}, 'ssh';
262 3         9 my $rsync_cmd = _first_defined delete $opts{rsync_cmd}, 'rsync';
263 3         3 my $scp_cmd = delete $opts{scp_cmd};
264 3         9 my $sshfs_cmd = _first_defined delete $opts{sshfs_cmd}, 'sshfs';
265             my $sftp_server_cmd = _first_defined delete $opts{sftp_server_cmd},
266 3         6 '/usr/lib/openssh/sftp-server';
267 3         6 my $timeout = delete $opts{timeout};
268 3         6 my $kill_ssh_on_timeout = delete $opts{kill_ssh_on_timeout};
269 3         6 my $strict_mode = _first_defined delete $opts{strict_mode}, 1;
270 3         9 my $connect = _first_defined delete $opts{connect}, 1;
271 3         3 my $async = delete $opts{async};
272 3         9 my $remote_shell = _first_defined delete $opts{remote_shell}, 'POSIX';
273 3         6 my $expand_vars = delete $opts{expand_vars};
274 3         18 my $vars = _first_defined delete $opts{vars}, {};
275 3         6 my $default_encoding = delete $opts{default_encoding};
276             my $default_stream_encoding =
277 3         9 _first_defined delete $opts{default_stream_encoding}, $default_encoding;
278             my $default_argument_encoding =
279 3         9 _first_defined delete $opts{default_argument_encoding}, $default_encoding;
280 3         6 my $forward_agent = delete $opts{forward_agent};
281 3 50 33     9 $forward_agent and $passphrase and
282             croak "agent forwarding can not be used when a passphrase has also been given";
283 3         6 my $forward_X11 = delete $opts{forward_X11};
284 3         6 my $passwd_prompt = delete $opts{password_prompt};
285 3         6 my $master_pty_force = delete $opts{master_pty_force};
286 3 50       15 $passwd_prompt = delete $opts{passwd_prompt} unless defined $passwd_prompt;
287              
288 3         12 my ($master_opts, @master_opts,
289             $master_stdout_fh, $master_stderr_fh,
290             $master_stdout_discard, $master_stderr_discard,
291             $master_setpgrp);
292 3 50       9 unless ($external_master) {
293             ($master_stdout_fh = delete $opts{master_stdout_fh} or
294 3 50       9 $master_stdout_discard = delete $opts{master_stdout_discard});
295              
296             ($master_stderr_fh = delete $opts{master_stderr_fh} or
297 3 50       15 $master_stderr_discard = delete $opts{master_stderr_discard});
298              
299 3         6 $master_opts = delete $opts{master_opts};
300 3 50       15 if (defined $master_opts) {
301 3 50       9 if (ref $master_opts) {
302 3         9 @master_opts = @$master_opts;
303             }
304             else {
305 0 0       0 carp "'master_opts' argument looks like if it should be splited first"
306             if $master_opts =~ /^-\w\s+\S/;
307 0         0 @master_opts = $master_opts;
308             }
309             }
310 3         6 $master_setpgrp = delete $opts{master_setpgrp};
311              
312             # when a password/passphrase is given, calling setpgrp is
313             # useless because the process runs attached to a different tty
314 3 50 33     36 undef $master_setpgrp if $login_handler or defined $passwd;
315             }
316              
317 3         6 my $default_ssh_opts = delete $opts{default_ssh_opts};
318 3 0 33     12 carp "'default_ssh_opts' argument looks like if it should be splited first"
      33        
319             if defined $default_ssh_opts and not ref $default_ssh_opts and $default_ssh_opts =~ /^-\w\s+\S/;
320              
321 3         6 my ($default_stdout_fh, $default_stderr_fh, $default_stdin_fh,
322             $default_stdout_file, $default_stderr_file, $default_stdin_file,
323             $default_stdout_discard, $default_stderr_discard, $default_stdin_discard);
324              
325             $default_stdout_file = (delete $opts{default_stdout_discard}
326             ? '/dev/null'
327 3 50       27 : delete $opts{default_stdout_file});
328             $default_stdout_fh = delete $opts{default_stdout_fh}
329 3 50       12 unless defined $default_stdout_file;
330              
331             $default_stderr_file = (delete $opts{default_stderr_discard}
332             ? '/dev/null'
333 3 50       6 : delete $opts{default_stderr_file});
334             $default_stderr_fh = delete $opts{default_stderr_fh}
335 3 50       9 unless defined $default_stderr_file;
336              
337             $default_stdin_file = (delete $opts{default_stdin_discard}
338             ? '/dev/null'
339 3 50       9 : delete $opts{default_stdin_file});
340             $default_stdin_fh = delete $opts{default_stdin_fh}
341 3 50       6 unless defined $default_stdin_file;
342              
343 3         24 _croak_bad_options %opts;
344              
345 3         6 my @ssh_opts;
346             # TODO: are those options really requiered or just do they eat on
347             # the command line limited length?
348 3 50       9 push @ssh_opts, -l => $user if defined $user;
349 3 50       9 push @ssh_opts, -p => $port if defined $port;
350              
351 3         3 my $home = do {
352 3         36 local ($@, $SIG{__DIE__});
353 3         6 eval { Cwd::realpath((getpwuid $>)[7]) }
  3         396  
354             };
355              
356 3 50       15 if (${^TAINT}) {
357 0         0 ($home) = $home =~ /^(.*)$/;
358 0 0       0 Scalar::Util::tainted($ENV{PATH}) and
359             _tcroak('Insecure $ENV{PATH}');
360             }
361              
362 3         33 my $self = { _error => 0,
363             _error_prefix => [],
364             _perl_pid => $$,
365             _thread_generation => $thread_generation,
366             _ssh_version => $ssh_version,
367             _ssh_cmd => $ssh_cmd,
368             _scp_cmd => $scp_cmd,
369             _rsync_cmd => $rsync_cmd,
370             _sshfs_cmd => $sshfs_cmd,
371             _sftp_server_cmd => $sftp_server_cmd,
372             _pid => undef,
373             _host => $host,
374             _host_squared => $host_squared,
375             _user => $user,
376             _port => $port,
377             _passwd => $obfuscate->($passwd),
378             _passwd_prompt => $passwd_prompt,
379             _passphrase => $passphrase,
380             _key_path => $key_path,
381             _login_handler => $login_handler,
382             _timeout => $timeout,
383             _proxy_command => $proxy_command,
384             _gateway_args => $gateway,
385             _kill_ssh_on_timeout => $kill_ssh_on_timeout,
386             _batch_mode => $batch_mode,
387             _home => $home,
388             _forward_agent => $forward_agent,
389             _forward_X11 => $forward_X11,
390             _external_master => $external_master,
391             _default_ssh_opts => $default_ssh_opts,
392             _default_stdin_fh => $default_stdin_fh,
393             _default_stdout_fh => $default_stdout_fh,
394             _default_stderr_fh => $default_stderr_fh,
395             _master_stdout_fh => $master_stdout_fh,
396             _master_stderr_fh => $master_stderr_fh,
397             _master_stdout_discard => $master_stdout_discard,
398             _master_stderr_discard => $master_stderr_discard,
399             _master_setpgrp => $master_setpgrp,
400             _master_pty_force => $master_pty_force,
401             _remote_shell => $remote_shell,
402             _default_stream_encoding => $default_stream_encoding,
403             _default_argument_encoding => $default_argument_encoding,
404             _expand_vars => $expand_vars,
405             _vars => $vars,
406             _master_state => _STATE_START,
407             };
408 3         15 bless $self, $class;
409              
410 3         27 $self->_detect_ssh_version;
411              
412             # default file handles are opened so late in order to have the
413             # $self object to report errors
414 2 50       8 $self->{_default_stdout_fh} = $self->_open_file('>', $default_stdout_file)
415             if defined $default_stdout_file;
416 2 50       6 $self->{_default_stderr_fh} = $self->_open_file('>', $default_stderr_file)
417             if defined $default_stderr_file;
418 2 50       18 $self->{_default_stdin_fh} = $self->_open_file('<', $default_stdin_file)
419             if defined $default_stdin_file;
420              
421 2 50       10 if ($self->{_error} == OSSH_SLAVE_PIPE_FAILED) {
422 0         0 $self->_master_fail($async, "Unable to create default slave stream", $self->{_error});
423 0         0 return $self;
424             }
425              
426 2         24 $self->{_ssh_opts} = [$self->_expand_vars(@ssh_opts)];
427 2         20 $self->{_master_opts} = [$self->_expand_vars(@master_opts)];
428              
429 2         14 $ctl_path = $self->_expand_vars($ctl_path);
430 2         6 $ctl_dir = $self->_expand_vars($ctl_dir);
431              
432 2 50       6 if (defined $ctl_path) {
433 0 0       0 if ($external_master) {
434 0 0       0 unless (-S $ctl_path) {
435 0         0 $self->_master_fail($async, "ctl_path $ctl_path does not point to a socket");
436 0         0 return $self;
437             }
438             }
439             else {
440 0 0       0 if (-e $ctl_path) {
441 0         0 $self->_master_fail($async, "unable to use ctl_path $ctl_path, a file object already exists there");
442 0         0 return $self;
443             }
444             }
445             }
446             else {
447 2 50       6 $external_master and croak "external_master is set but ctl_path is not defined";
448              
449 2 50       6 unless (defined $ctl_dir) {
450 2 50       6 unless (defined $self->{_home}) {
451 0         0 $self->_master_fail($async, "unable to determine home directory for uid $>");
452 0         0 return $self;
453             }
454              
455 2         78 $ctl_dir = File::Spec->catdir($self->{_home}, ".libnet-openssh-perl");
456             }
457              
458 2         310 mkdir $ctl_dir, 0700;
459 2 50       42 unless (-d $ctl_dir) {
460 0         0 $self->_master_fail($async, "unable to create ctl_dir $ctl_dir");
461 0         0 return $self;
462             }
463              
464 2         22 my $target = join('-', grep defined, $user, $host, $port);
465              
466 2         14 for (1..10) {
467 2         82 my $ctl_file = Digest::MD5::md5_hex(sprintf "%s-%d-%d-%d", $target, $$, time, rand 1e6);
468 2         112 $ctl_path = File::Spec->join($ctl_dir, $ctl_file);
469 2 50       38 last unless -e $ctl_path
470             }
471 2 50       36 if (-e $ctl_path) {
472 0         0 $self->_master_fail($async, "unable to find unused name for ctl_path inside ctl_dir $ctl_dir");
473 0         0 return $self;
474             }
475             }
476              
477 2 50 33     22 if (defined $sizeof_sun_path and length $ctl_path > $sizeof_sun_path) {
478 0         0 $self->_master_fail($async, "ctl_path $ctl_path is too long (max permissible size for $^O is $sizeof_sun_path)");
479 0         0 return $self;
480             }
481              
482 2         160 $ctl_dir = File::Spec->catpath((File::Spec->splitpath($ctl_path))[0,1], "");
483 2 50 33     10 $debug and $debug & 2 and _debug "ctl_path: $ctl_path, ctl_dir: $ctl_dir";
484              
485 2 50 33     8 if ($strict_mode and !$self->_is_secure_path($ctl_dir)) {
486 0         0 $self->_master_fail($async, "ctl_dir $ctl_dir is not secure");
487 0         0 return $self;
488             }
489              
490 2         6 $self->{_ctl_path} = $ctl_path;
491              
492 2 50       26 $self->_master_wait($async) if $connect;
493              
494 1         50 $self;
495             }
496              
497 0     0 1 0 sub get_user { shift->{_user} }
498 0     0 1 0 sub get_host { shift->{_host} }
499 0     0 1 0 sub get_port { shift->{_port} }
500 0     0 1 0 sub get_master_pid { shift->{_pid} }
501 0     0 1 0 sub get_ctl_path { shift->{_ctl_path} }
502 0     0 1 0 sub get_expand_vars { shift->{_expand_vars} }
503              
504 0     0 1 0 sub get_master_pty_log { shift->{_master_pty_log} }
505              
506             sub set_expand_vars {
507 0     0 1 0 my $self = shift;
508 0 0       0 $self->{_expand_vars} = (shift(@_) ? 1 : 0);
509             }
510              
511             sub set_var {
512 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
513 0         0 my $self = shift;
514 0         0 my $k = shift;
515 0 0       0 $k =~ /^(?:USER|HOST|PORT)$/
516             and croak "internal variable %$k% can not be set";
517 0         0 $self->{_vars}{$k} = shift;
518             }
519              
520             sub get_var {
521 0     0 1 0 my ($self, $k) = @_;
522             my $v = ( $k =~ /^(?:USER|HOST|PORT)$/
523             ? $self->{lc "_$k"}
524 0 0       0 : $self->{_vars}{$k} );
525 0 0       0 (defined $v ? $v : '');
526             }
527              
528             sub _expand_vars {
529 17     17   65 my ($self, @str) = @_;
530 17 50 33     101 if (ref $self and $self->{_expand_vars}) {
531 0         0 for (@str) {
532 0 0       0 s{%(\w*)%}{length ($1) ? $self->get_var($1) : '%'}ge
  0 0       0  
533             if defined $_;
534             }
535             }
536 17 100       157 wantarray ? @str : $str[0]
537             }
538              
539 1     1 1 27 sub error { shift->{_error} }
540              
541             sub die_on_error {
542 0     0 0 0 my $ssh = shift;
543 0 0       0 $ssh->{_error} and croak(@_ ? "@_: $ssh->{_error}" : $ssh->{_error});
    0          
544             }
545              
546              
547             sub _is_secure_path {
548 0     0   0 my ($self, $path) = @_;
549 0         0 my @parts = File::Spec->splitdir(Cwd::realpath($path));
550 0         0 my $home = $self->{_home};
551 0         0 for my $last (reverse 0..$#parts) {
552 0         0 my $dir = File::Spec->catdir(@parts[0..$last]);
553 0 0       0 unless (-d $dir) {
554 0 0 0     0 $debug and $debug & 2 and _debug "$dir is not a directory";
555 0         0 return undef;
556             }
557 0         0 my ($mode, $uid) = (stat $dir)[2, 4];
558 0 0 0     0 $debug and $debug & 2 and _debug "_is_secure_path(dir: $dir, file mode: $mode, file uid: $uid, euid: $>";
559 0 0 0     0 return undef unless(($uid == $> or $uid == 0 ) and (($mode & 022) == 0 or ($mode & 01000)));
      0        
      0        
560 0 0 0     0 return 1 if (defined $home and $home eq $dir);
561             }
562 0         0 return 1;
563             }
564              
565             _sub_options _capture_local_ssh => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file);
566              
567             sub _capture_local_ssh {
568 3     3   6 my $self = shift;
569 3 50       15 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  3         12  
570 3         9 _croak_bad_options %opts;
571             my (undef, $out, undef, $pid) = $self->open_ex({ %opts,
572             _cmd => 'raw',
573             _no_master_required => 1,
574             stdout_pipe => 1,
575             stdin_discard => 1 },
576 3         63 $self->{_ssh_cmd}, @_);
577 2         98 my ($txt) = $self->_io3($out, undef, undef, undef, 10, 'bytes');
578 2         10 local $self->{_kill_ssh_on_timeout} = 1;
579 2         28 $self->_waitpid($pid, 10);
580 2         30 return $txt
581             }
582              
583             sub _detect_ssh_version {
584 3     3   9 my $self = shift;
585 3 50       39 if (defined $self->{_ssh_version}) {
586 0 0 0     0 $debug and $debug & 4 and _debug "ssh version given as $self->{_ssh_version}";
587             }
588             else {
589 3         27 my $txt = $self->_capture_local_ssh({stderr_to_stdout => 1}, '-V');
590 2 50       44 if (my ($full, $num) = $txt =~ /^OpenSSH_((\d+\.\d+)\S*)/mi) {
591 2 50 33     10 $debug and $debug & 4 and _debug "OpenSSH version is $full";
592 2         8 $self->{_ssh_version} = $num;
593             }
594             else {
595 0         0 $self->{_ssh_version} = 0;
596 0 0 0     0 $debug and $debug & 4 and _debug "unable to determine version, '$self->{_ssh_cmd} -V', output:\n$txt"
597             }
598             }
599             }
600              
601             sub default_ssh_configuration {
602 0     0 1 0 my $self = shift;
603             $self->_capture_local_ssh('-qG', $self->{_host})
604 0         0 }
605              
606             sub _make_ssh_call {
607 2     2   4 my $self = shift;
608 2 50       2 my @before = @{shift || []};
  2         8  
609             my @args = ($self->{_ssh_cmd}, @before,
610             -S => $self->{_ctl_path},
611 2         18 @{$self->{_ssh_opts}}, $self->{_host},
612 2 50       6 '--',
613             (@_ ? "@_" : ()));
614 2 50 33     8 $debug and $debug & 8 and _debug_dump 'call args' => \@args;
615 2         36 @args;
616             }
617              
618             sub _scp_cmd {
619 0     0   0 my $self = shift;
620 0   0     0 $self->{_scp_cmd} ||= do {
621 0         0 my $scp = $self->{_ssh_cmd};
622 0 0       0 $scp =~ s/ssh$/scp/i or croak "scp command name not set";
623 0         0 $scp;
624             }
625             }
626              
627             sub _make_scp_call {
628 0     0   0 my $self = shift;
629 0 0       0 my @before = @{shift || []};
  0         0  
630             my @args = ($self->_scp_cmd, @before,
631             -o => "ControlPath=$self->{_ctl_path}",
632             -S => $self->{_ssh_cmd},
633 0 0       0 (defined $self->{_port} ? (-P => $self->{_port}) : ()),
634             '--', @_);
635              
636 0 0 0     0 $debug and $debug & 8 and _debug_dump 'scp call args' => \@args;
637 0         0 @args;
638             }
639              
640             sub _rsync_quote {
641 0     0   0 my ($self, @args) = @_;
642 0         0 for (@args) {
643 0 0       0 if (/['"\s]/) {
644 0         0 s/"/""/g;
645 0         0 $_ = qq|"$_"|;
646             }
647 0         0 s/%/%%/;
648             }
649 0 0       0 wantarray ? @args : join(' ', @args);
650             }
651              
652             sub _make_rsync_call {
653 0     0   0 my $self = shift;
654 0         0 my $before = shift;
655             my @transport = ($self->{_ssh_cmd}, @$before,
656 0         0 -S => $self->{_ctl_path});
657 0         0 my $transport = $self->_rsync_quote(@transport);
658             my @args = ( $self->{_rsync_cmd},
659 0         0 -e => $transport,
660             @_);
661              
662 0 0 0     0 $debug and $debug & 8 and _debug_dump 'rsync call args' => \@args;
663 0         0 @args;
664             }
665              
666             sub _make_W_option {
667 0     0   0 my $self = shift;
668 0 0       0 if (@_ == 1) {
669 0         0 my $path = shift;
670 0 0       0 $path = "./$path" unless $path =~ m|/|;
671 0         0 $path =~ s/([\\:])/\\$1/g;
672 0         0 return "-W$path";
673             }
674 0 0       0 if (@_ == 2) {
675 0         0 return "-W" . join(':', @_);
676             }
677 0         0 croak "bad number of arguments for creating a tunnel"
678             }
679              
680             sub _make_tunnel_call {
681 0     0   0 my $self = shift;
682 0 0       0 my @before = @{shift||[]};
  0         0  
683 0         0 push @before, $self->_make_W_option(@_);
684 0         0 my @args = $self->_make_ssh_call(\@before);
685 0 0 0     0 $debug and $debug & 8 and _debug_dump 'tunnel call args' => \@args;
686 0         0 @args;
687             }
688              
689             sub master_exited {
690 0     0 1 0 my $self = shift;
691 0         0 $self->_master_gone(1)
692             }
693              
694             sub _master_gone {
695 0     0   0 my $self = shift;
696 0         0 my $async = shift;
697 0         0 delete $self->{_pid};
698 0 0       0 $self->_master_fail($async, (@_ ? @_ : "master process exited unexpectedly"));
699             }
700              
701             my @kill_signal = qw(0 0 TERM TERM TERM KILL);
702              
703             sub __has_sigchld_handle {
704 2     2   18 my $h = $SIG{CHLD};
705 2 50 33     52 defined $h and $h ne 'IGNORE' and $h ne 'DEFAULT'
706             }
707              
708             sub _master_kill {
709 0     0   0 my ($self, $async) = @_;
710              
711 0 0       0 if (my $pid = $self->_my_master_pid) {
712 0 0 0     0 $debug and $debug & 32 and _debug '_master_kill: ', $pid;
713              
714 0         0 my $now = time;
715 0   0     0 my $start = $self->{_master_kill_start} ||= $now;
716 0   0     0 $self->{_master_kill_last} ||= $now;
717 0   0     0 $self->{_master_kill_count} ||= 0;
718              
719 0 0 0 0   0 local $SIG{CHLD} = sub {} unless $async or __has_sigchld_handle;
720 0         0 while (1) {
721 0 0       0 if ($self->{_master_kill_last} < $now) {
722 0         0 $self->{_master_kill_last} = $now;
723 0         0 my $sig = $kill_signal[$self->{_master_kill_count}++];
724 0 0       0 $sig = 'KILL' unless defined $sig;
725 0 0 0     0 $debug and $debug & 32 and _debug "killing master $$ with signal $sig";
726 0         0 kill $sig, $pid;
727             }
728 0         0 my $deceased = waitpid($pid, WNOHANG);
729 0 0 0     0 $debug and $debug & 32 and _debug "waitpid(master: $pid) => pid: $deceased, rc: $!";
730 0 0 0     0 last if $deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD());
      0        
731 0 0       0 if ($self->{_master_kill_count} > 20) {
732             # FIXME: remove the hard-coded 20 retries?
733 0 0 0     0 $debug and $debug & 32 and _debug "unable to kill SSH master process, giving up";
734 0         0 last;
735             }
736 0 0       0 return if $async;
737 0         0 select(undef, undef, undef, 0.2);
738 0         0 $now = time;
739             }
740             }
741             else {
742             $debug and $debug & 32 and _debug("not killing master SSH (", $self->{_pid}, ") started from " .
743             "process ", $self->{_perl_pid}, "/", $self->{_thread_generation},
744 0 0 0     0 ", current ", $$, "/", $thread_generation, ")");
745             }
746 0         0 $self->_master_gone($async);
747             }
748              
749             sub disconnect {
750 0     0 1 0 my ($self, $async) = @_;
751 0 0       0 @_ <= 2 or croak 'Usage: $self->disconnect([$async])';
752 0         0 $self->_disconnect($async, 1);
753             }
754              
755             sub disown_master {
756 0     0 1 0 my $self = shift;
757 0 0       0 if (my $pid = $self->_my_master_pid) {
758 0 0       0 if ($self->wait_for_master) {
759 0         0 $self->{_external_master} = 1;
760 0         0 return $pid;
761             }
762             }
763 0         0 undef;
764             }
765              
766             sub restart {
767 0     0 1 0 my ($self, $async) = @_;
768 0 0       0 $self->{_external_master} and croak "Can restart SSH connection when using external master";
769              
770             # user is responsible for calling us in STATE_GONE in async mode
771 0 0       0 $self->_disconnect($async, 1) unless $async;
772              
773 0 0       0 if ($self->{_master_state} != _STATE_GONE) {
774 0 0       0 croak "restart method called in wrong state (terminate the connection first!)" if $async;
775 0         0 return $self->_master_fail($async, "Unable to restart SSH session from state $self->{_master_state}")
776             }
777              
778             # These slots should be deleted when exiting the KILLING state but
779             # I like keeping them around for throubleshoting purposes.
780 0         0 delete $self->{_master_kill_start};
781 0         0 delete $self->{_master_kill_last};
782 0         0 delete $self->{_master_kill_count};
783 0         0 $self->_master_jump_state(_STATE_START, $async);
784             }
785              
786             sub _my_master_pid {
787 4     4   9 my $self = shift;
788 4 50       24 unless ($self->{_external_master}) {
789 4         11 my $pid = $self->{_pid};
790             return $pid if
791 4 50 66     54 $pid and $self->{_perl_pid} == $$ and $self->{_thread_generation} == $thread_generation;
      66        
792             }
793             ()
794 3         8 }
795              
796             sub _disconnect {
797 1     1   4 my ($self, $async, $send_ctl) = @_;
798 1 50       433 return if $self->{_master_state} == _STATE_GONE;
799              
800 0 0 0     0 if (!$async and
      0        
      0        
801             $self->{_master_state} == _STATE_RUNNING and
802             ($send_ctl or $self->_my_master_pid)) {
803             # we have successfully created the master connection so we
804             # can send control commands:
805 0 0 0     0 $debug and $debug & 32 and _debug("sending exit control to master");
806 0         0 $self->_master_ctl('exit');
807             }
808 0         0 $self->_master_fail($async, 'aborted')
809             }
810              
811             sub _check_is_system_fh {
812 6     6   27 my ($name, $fh) = @_;
813 6 100       24 my $fn = fileno(defined $fh ? $fh : $name);
814 6 50 33     36 defined $fn and $fn >= 0 and return;
815 0         0 croak "child process $name is not a real system file handle";
816             }
817              
818             sub _master_redirect {
819 2     2   14 my $self = shift;
820 2         11 my $uname = uc shift;
821 2         8 my $name = lc $uname;
822              
823 5     5   39 no strict 'refs';
  5         10  
  5         54978  
824 2 50       16 if ($self->{"_master_${name}_discard"}) {
825 0         0 open *$uname, '>>', '/dev/null';
826             }
827             else {
828 2         8 my $fh = $self->{"_master_${name}_fh"};
829 2 50       18 $fh = $self->{"_default_${name}_fh"} unless defined $fh;
830 2 50       16 if (defined $fh) {
831 0         0 _check_is_system_fh $uname => $fh;
832 0 0       0 if (fileno $fh != fileno *$uname) {
833 0 0       0 open *$uname, '>>&', $fh or POSIX::_exit(255);
834             }
835             }
836             }
837             }
838              
839             sub _waitpid {
840 2     2   8 my ($self, $pid, $timeout) = @_;
841 2         16 $? = 0;
842 2 50       8 if ($pid) {
843 2 50       8 $timeout = $self->{_timeout} unless defined $timeout;
844              
845 2         28 my $time_limit;
846 2 50 33     22 if (defined $timeout and $self->{_kill_ssh_on_timeout}) {
847 2 50       10 $timeout = 0 if $self->{_error} == OSSH_SLAVE_TIMEOUT;
848 2         4 $time_limit = time + $timeout;
849             }
850 2 50   0   20 local $SIG{CHLD} = sub {} unless __has_sigchld_handle;
851 2         6 while (1) {
852 2         4 my $deceased;
853 2 50       18 if (defined $time_limit) {
854 2         8 while (1) {
855             # TODO: we assume that all OSs return 0 when the
856             # process is still running, that may be wrong!
857 2 50       90 $deceased = waitpid($pid, WNOHANG) and last;
858 0         0 my $remaining = $time_limit - time;
859 0 0       0 if ($remaining <= 0) {
860 0 0 0     0 $debug and $debug & 16 and _debug "killing SSH slave, pid: $pid";
861 0         0 kill TERM => $pid;
862 0         0 $self->_or_set_error(OSSH_SLAVE_TIMEOUT, "ssh slave failed", "timed out");
863             }
864             # There is a race condition here. We try to
865             # minimize it keeping the waitpid and the select
866             # together and limiting the sleep time to 1s:
867 0 0       0 my $sleep = ($remaining < 0.1 ? 0.1 : 1);
868 0 0 0     0 $debug and $debug & 16 and
869             _debug "waiting for slave, timeout: $timeout, remaining: $remaining, sleep: $sleep";
870 0 0       0 $deceased = waitpid($pid, WNOHANG) and last;
871 0         0 select(undef, undef, undef, $sleep);
872             }
873             }
874             else {
875 0         0 $deceased = waitpid($pid, 0);
876             }
877 2 50 33     10 $debug and $debug & 16 and _debug "_waitpid($pid) => pid: $deceased, rc: $?, err: $!";
878 2 50       8 if ($deceased == $pid) {
    0          
    0          
879 2 50       8 if ($?) {
880 0         0 my $signal = ($? & 255);
881 0         0 my $errstr = "child exited with code " . ($? >> 8);
882 0 0       0 $errstr .= ", signal $signal" if $signal;
883 0         0 $self->_or_set_error(OSSH_SLAVE_CMD_FAILED, $errstr);
884 0         0 return undef;
885             }
886 2         28 return 1;
887             }
888             elsif ($deceased < 0) {
889             # at this point $deceased < 0 and so, $! has a valid error value.
890 0 0       0 next if $! == Errno::EINTR();
891 0 0       0 if ($! == Errno::ECHILD()) {
892 0         0 $self->_or_set_error(OSSH_SLAVE_FAILED, "child process $pid does not exist", $!);
893             return undef
894 0         0 }
895 0         0 warn "Internal error: unexpected error (".($!+0).": $!) from waitpid($pid) = $deceased. Report it, please!";
896             }
897             elsif ($deceased > 0) {
898 0         0 warn "Internal error: spurious process $deceased exited"
899             }
900              
901             # wait a bit before trying again
902 0         0 select(undef, undef, undef, 0.1);
903             }
904             }
905             else {
906 0         0 $self->_or_set_error(OSSH_SLAVE_FAILED, "spawning of new process failed");
907 0         0 return undef;
908             }
909             }
910              
911             sub check_master {
912 0     0 1 0 my $self = shift;
913 0 0       0 @_ and croak 'Usage: $ssh->check_master()';
914 0         0 $self->_master_check(0);
915             }
916              
917             sub wait_for_master {
918 0     0 1 0 my ($self, $async) = @_;
919 0 0       0 @_ <= 2 or croak 'Usage: $ssh->wait_for_master([$async])';
920             $self->{_error} = 0
921 0 0       0 unless $self->{_error} == OSSH_MASTER_FAILED;
922 0         0 $self->_master_wait($async);
923             }
924              
925             sub _master_start {
926 2     2   6 my ($self, $async) = @_;
927 2         18 $self->_set_error;
928              
929 2   50     14 my $timeout = int((($self->{_timeout} || 90) + 2)/3);
930 2         10 my $ssh_flags= '-2MN';
931 2 0       8 $ssh_flags .= ($self->{_forward_agent} ? 'A' : 'a') if defined $self->{_forward_agent};
    50          
932 2 50       10 $ssh_flags .= ($self->{_forward_X11} ? 'X' : 'x');
933 2         38 my @master_opts = (@{$self->{_master_opts}},
934             -o => "ServerAliveInterval=$timeout",
935 2 50       4 ($self->{_ssh_version} >= 5.6 ? (-o => "ControlPersist=no") : ()),
936             $ssh_flags);
937              
938 2         8 my ($mpty, $use_pty, $pref_auths);
939             $use_pty = 1 if ( $self->{_master_pty_force} or
940 2 50 33     18 defined $self->{_login_handler} );
941 2 50       64 if (defined $self->{_passwd}) {
    50          
942 0         0 $use_pty = 1;
943             $pref_auths = ($self->{_passphrase}
944 0 0       0 ? 'publickey'
945             : 'keyboard-interactive,password');
946 0         0 push @master_opts, -o => 'NumberOfPasswordPrompts=1';
947             }
948             elsif ($self->{_batch_mode}) {
949 0         0 push @master_opts, -o => 'BatchMode=yes';
950             }
951              
952 2 50       8 if (defined $self->{_key_path}) {
953 0         0 $pref_auths = 'publickey';
954 0         0 push @master_opts, -i => $self->{_key_path};
955             }
956              
957 2         4 my $proxy_command = $self->{_proxy_command};
958              
959 2         4 my $gateway;
960 2 50       8 if (my $gateway_args = $self->{_gateway_args}) {
961 0 0       0 if (ref $gateway_args eq 'HASH') {
962 0         0 _load_module('Net::OpenSSH::Gateway');
963 0         0 my $errors;
964 0 0       0 unless ($gateway = Net::OpenSSH::Gateway->find_gateway(errors => $errors,
965             host => $self->{_host}, port => $self->{_port},
966             %$gateway_args)) {
967 0         0 return $self->_master_fail($async, 'Unable to build gateway object', join(', ', @$errors));
968             }
969             }
970             else {
971 0         0 $gateway = $gateway_args
972             }
973 0         0 $self->{_gateway} = $gateway;
974 0 0       0 $gateway->before_ssh_connect or
975             return $self->_master_fail($async, 'Gateway setup failed', join(', ', $gateway->errors));
976 0         0 $proxy_command = $gateway->proxy_command;
977             }
978              
979 2 50       14 if (defined $proxy_command) {
980 0         0 push @master_opts, -o => "ProxyCommand=$proxy_command";
981             }
982              
983 2 50       8 if ($use_pty) {
984 0         0 _load_module('IO::Pty');
985 0         0 $self->{_mpty} = $mpty = IO::Pty->new;
986             }
987              
988 2 50       4 push @master_opts, -o => "PreferredAuthentications=$pref_auths"
989             if defined $pref_auths;
990              
991 2         12 my @call = $self->_make_ssh_call(\@master_opts);
992              
993 2         2249 my $pid = fork;
994 2 100       117 unless ($pid) {
995 1 50       19 defined $pid
996             or return $self->_master_fail($async, "unable to fork ssh master: $!");
997              
998 1 50 33     23 if ($debug and $debug & 512) {
999 0         0 require Net::OpenSSH::OSTracer;
1000 0         0 Net::OpenSSH::OSTracer->trace;
1001             }
1002              
1003 1 50       8 $mpty->make_slave_controlling_terminal if $mpty;
1004              
1005 1         68 $self->_master_redirect('STDOUT');
1006 1         12 $self->_master_redirect('STDERR');
1007              
1008 1 50       10 delete $ENV{SSH_ASKPASS} if defined $self->{_passwd};
1009 1 50       15 delete $ENV{SSH_AUTH_SOCK} if defined $self->{_passphrase};
1010              
1011 1 50       6 setpgrp if $self->{_master_setpgrp};
1012              
1013 1         25 local $SIG{__DIE__};
1014 1         13 eval { exec @call };
  1         0  
1015 0         0 POSIX::_exit(255);
1016             }
1017 1         13 $self->{_pid} = $pid;
1018 1         97 1;
1019             }
1020              
1021             sub _master_check {
1022 0     0   0 my ($self, $async) = @_;
1023 0         0 my $error;
1024 0 0       0 if ($async) {
1025 0 0       0 if (-S $self->{_ctl_path}) {
1026 0         0 delete $self->{_master_pty_log};
1027 0         0 return 1
1028             }
1029 0         0 $error = "master SSH connection broken";
1030             }
1031             else {
1032 0         0 my $out = $self->_master_ctl('check');
1033 0         0 $error = $self->{_error};
1034 0 0       0 unless ($error) {
1035 0         0 my $pid = $self->{_pid};
1036 0 0       0 if ($out =~ /pid=(\d+)/) {
1037 0 0 0     0 if (!$pid or $1 == $pid) {
1038 0         0 delete $self->{_master_pty_log};
1039 0         0 return 1;
1040             }
1041 0         0 $error = "bad ssh master at $self->{_ctl_path} socket owned by pid $1 (pid $pid expected)";
1042             }
1043             else {
1044 0 0       0 $error = ($out =~ /illegal option/i
1045             ? 'OpenSSH 4.1 or later required'
1046             : 'unknown error');
1047             }
1048             }
1049             }
1050 0         0 $self->_master_fail($async, $error);
1051             }
1052              
1053             sub _master_fail {
1054 1     1   3 my $self = shift;
1055 1         3 my $async = shift;
1056 1 50       13 if ($self->{_error} != OSSH_MASTER_FAILED) {
1057 1         14 $self->_set_error(OSSH_MASTER_FAILED, @_);
1058             }
1059 1 50       113 $self->_master_jump_state($self->{_pid} ? _STATE_KILLING : _STATE_GONE, $async);
1060             }
1061              
1062             sub _master_jump_state {
1063 2     2   21 my ($self, $state, $async) = @_;
1064 2 50 33     17 $debug and $debug & 4 and _debug "master state jumping from $self->{_master_state} to $state";
1065 2 0 33     14 if ($state == $self->{_master_state} and
      33        
1066             $state != _STATE_KILLING and
1067             $state != _STATE_GONE) {
1068 0         0 croak "internal error: state jump to itself ($state)!";
1069             }
1070 2         11 $self->{_master_state} = $state;
1071 2         57 return $self->_master_wait($async);
1072             }
1073              
1074             sub _master_wait {
1075 4     4   14 my ($self, $async) = @_;
1076              
1077 4         51 my $pid = $self->_my_master_pid;
1078 4 100       12 if ($pid) {
1079 1         6 my $deceased = waitpid($pid, WNOHANG);
1080 1 50 33     28 if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD())) {
      33        
1081 0 0 0     0 $debug and $debug & 4 and _debug "master $pid exited, rc:", $?,", err: ",$!;
1082 0         0 return $self->_master_gone($async);
1083             }
1084             }
1085              
1086 4 50       12 if ($self->{_master_state} == _STATE_RUNNING) {
1087 0 0       0 return 1 if -S $self->{_ctl_path};
1088 0         0 return $self->_master_fail($async, "master SSH connection broken");
1089             }
1090              
1091 4 50       11 if ($self->{_master_state} == _STATE_KILLING) {
1092 0 0 0     0 $debug and $debug & 4 and _debug "killing master";
1093 0         0 return $self->_master_kill($async);
1094             }
1095              
1096 4 100       14 if ($self->{_master_state} == _STATE_START) {
1097 2 50       6 if ($self->{_external_master}) {
1098 0   0     0 return ($self->_master_jump_state(_STATE_RUNNING, $async) and
1099             $self->_master_check($async))
1100             }
1101              
1102 2 50       20 $self->_master_start($async) or return;
1103 1 50       28 if ($self->{_mpty}) {
1104 0         0 $self->{_wfm_bout} = '';
1105 0         0 $self->{_master_pty_log} = '';
1106 0 0 0     0 if (defined $self->{_passwd} or $self->{_login_handler}) {
1107 0         0 return $self->_master_jump_state(_STATE_LOGIN, $async);
1108             }
1109             }
1110 1         29 return $self->_master_jump_state(_STATE_AWAITING_MUX, $async);
1111             }
1112              
1113 2 100       14 if ($self->{_master_state} == _STATE_GONE) {
1114 1 50       4 if (my $mpty = delete $self->{_mpty}) {
1115 0         0 close($mpty)
1116             }
1117 1         6 return 0;
1118             }
1119 1 50       13 if ($self->{_master_state} == _STATE_STOPPED) {
1120 0         0 return 0;
1121             }
1122              
1123             # At this point we are either in state AWAITIN_MUX or LOGIN
1124              
1125 1         3 local $self->{_error_prefix} = [@{$self->{_error_prefix}},
  1         20  
1126             "unable to establish master SSH connection"];
1127              
1128 1 50       12 $pid or return $self->_master_gone($async,
1129             "perl process was forked or threaded before SSH connection had been established");
1130              
1131 1         7 my $old_tcpgrp;
1132 1 0 33     4 if ($self->{_master_setpgrp} and not $async and
      33        
      0        
1133             not $self->{_batch_mode} and not $self->{_external_master}) {
1134 0         0 $old_tcpgrp = POSIX::tcgetpgrp(0);
1135 0 0       0 if ($old_tcpgrp > 0) {
1136             # let the master process ask for passwords at the TTY
1137 0         0 POSIX::tcsetpgrp(0, $pid);
1138             }
1139             else {
1140 0         0 undef $old_tcpgrp;
1141             }
1142             }
1143              
1144 1         2 my $mpty = $self->{_mpty};
1145 1         2 my $fnopty;
1146 1         8 my $rv = '';
1147 1 0 0     4 if ($mpty and
      33        
1148             ( $self->{_master_state} == _STATE_LOGIN or
1149             $self->{_master_state} == _STATE_AWAITING_MUX )) {
1150 0         0 $fnopty = fileno $mpty;
1151 0         0 vec($rv, $fnopty, 1) = 1
1152             }
1153              
1154 1         8 my $timeout = $self->{_timeout};
1155 1 50       3 my $dt = ($async ? 0 : 0.02);
1156 1         7 my $start_time = time;
1157 1         8 my $error;
1158              
1159             # Loop until the mux socket appears or something goes wrong:
1160 1         3 while (1) {
1161 15 50       159 $dt *= 1.10 if $dt < 0.2; # adaptative delay
1162 15 50       336 if (-e $self->{_ctl_path}) {
1163 0 0 0     0 $debug and $debug & 4 and _debug "file object found at $self->{_ctl_path}";
1164 0         0 last;
1165             }
1166 15 50 33     647 $debug and $debug & 4 and _debug "file object not yet found at $self->{_ctl_path}, state:", $self->{_master_state};
1167              
1168 15 50 33     156 if (defined $timeout and (time - $start_time) > $timeout) {
1169 0         0 $error = "login timeout";
1170 0         0 last;
1171             }
1172              
1173 15         165 my $deceased = waitpid($pid, WNOHANG);
1174 15 100 33     122 if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD())) {
      66        
1175 1         10 $error = "master process exited unexpectedly";
1176             $error = "bad pass" . ($self->{_passphrase} ? 'phrase' : 'word') . " or $error"
1177 1 0       8 if defined $self->{_passwd};
    50          
1178 1         12 delete $self->{_pid};
1179 1         3 last;
1180             }
1181              
1182 14 50 33     68 if ($self->{_login_handler} and $self->{_master_state} == _STATE_LOGIN) {
1183 0         0 local ($@, $SIG{__DIE__});
1184 0 0       0 if (eval { $self->{_login_handler}->($self, $mpty, \$self->{_wfm_bout}) }) {
  0         0  
1185 0         0 $self->{_master_state} = _STATE_AWAITING_MUX;
1186 0         0 next;
1187             }
1188 0 0       0 if ($@) {
1189 0         0 $error = "custom login handler failed: $@";
1190 0         0 last;
1191             }
1192             # fallback
1193             }
1194             else {
1195             # we keep reading from mpty even after leaving state
1196             # STATE_LOGIN in order to search for additional password
1197             # prompts.
1198 14         30 my $rv1 = $rv;
1199 14         625087 my $n = select($rv1, undef, undef, $dt);
1200 14 50       143 if ($n > 0) {
1201 0 0       0 vec($rv1, $fnopty, 1) or die "internal error";
1202 0         0 my $read = sysread($mpty, $self->{_wfm_bout}, 4096, length $self->{_wfm_bout});
1203 0 0       0 if ($read) {
1204 0         0 $self->{_master_pty_log} .= substr($self->{_wfm_bout}, -$read);
1205 0 0       0 if ((my $remove = length($self->{_master_pty_log}) - 4096) > 0) {
1206 0         0 substr($self->{_master_pty_log}, 0, $remove) = ''
1207             }
1208              
1209 0 0       0 if ($self->{_wfm_bout} =~ /The authenticity of host.*can't be established/si) {
1210 0         0 $error = "the authenticity of the target host can't be established; the remote host " .
1211             "public key is probably not present in the '~/.ssh/known_hosts' file";
1212 0         0 last;
1213             }
1214              
1215 0 0       0 if ($self->{_wfm_bout} =~ /WARNING: REMOTE HOST IDENTIFICATION HAS CHANGED/si) {
1216 0         0 $error = "the authenticity of the target host can't be established; the remote host " .
1217             "public key doesn't match the one stored locally";
1218 0         0 last;
1219             }
1220              
1221 0         0 my $passwd_prompt = _first_defined $self->{_passwd_prompt}, qr/[:?]/;
1222 0 0       0 $passwd_prompt = quotemeta $passwd_prompt unless ref $passwd_prompt;
1223              
1224 0 0 0     0 if ($self->{_master_state} == _STATE_LOGIN) {
    0          
1225 0 0       0 if ($self->{_wfm_bout} =~ /^(.*$passwd_prompt)/s) {
1226 0 0 0     0 $debug and $debug & 4 and _debug "passwd/passphrase requested ($1)";
1227 0         0 print $mpty $deobfuscate->($self->{_passwd}) . "\n";
1228 0         0 $self->{_wfm_bout} = ''; # reset
1229 0         0 $self->{_master_state} = _STATE_AWAITING_MUX;
1230             }
1231             }
1232             elsif (length($passwd_prompt) and $self->{_wfm_bout} =~ /^(.*$passwd_prompt)\s*$/s) {
1233 0 0 0     0 $debug and $debug & 4 and _debug "passwd/passphrase requested again ($1)";
1234 0         0 $error = "password authentication failed";
1235 0         0 last;
1236             }
1237 0         0 next; # skip delay
1238             }
1239             }
1240             }
1241 14 50       50 return if $async;
1242 14         617094 select(undef, undef, undef, $dt);
1243             }
1244              
1245 1 50       5 if (defined $old_tcpgrp) {
1246 0 0 0     0 $debug and $debug & 4 and
1247             _debug("ssh pid: $pid, pgrp: ", getpgrp($pid),
1248             ", \$\$: ", $$,
1249             ", tcpgrp: ", POSIX::tcgetpgrp(0),
1250             ", old_tcppgrp: ", $old_tcpgrp);
1251 0         0 local $SIG{TTOU} = 'IGNORE';
1252 0         0 POSIX::tcsetpgrp(0, $old_tcpgrp);
1253             }
1254              
1255 1 50       13 if ($error) {
1256 1         12 return $self->_master_fail($async, $error);
1257             }
1258              
1259 0 0       0 $self->_master_jump_state(_STATE_RUNNING, $async)
1260             and $self->_master_check($async);
1261             }
1262              
1263             sub _master_ctl {
1264 0     0   0 my $self = shift;
1265 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1266 0         0 my $cmd = shift;
1267              
1268 0         0 local $?;
1269 0         0 local $self->{_error_prefix} = [@{$self->{_error_prefix}},
  0         0  
1270             "control command failed"];
1271 0         0 $self->capture({ %opts,
1272             encoding => 'bytes', # don't let the encoding
1273             # stuff get in the way
1274             stdin_discard => 1, tty => 0,
1275             stderr_to_stdout => 1, ssh_opts => [-O => $cmd]});
1276             }
1277              
1278             sub stop {
1279 0     0 0 0 my ($self, $timeout) = @_;
1280 0         0 my $pid = $self->{_pid};
1281 0         0 local $self->{_kill_ssh_on_timeout} = 1;
1282 0         0 $self->_master_ctl({timeout => $timeout}, 'stop');
1283 0 0       0 unless ($self->{_error}) {
1284 0         0 $self->_set_error(OSSH_MASTER_FAILED, "master stopped");
1285 0         0 $self->_master_jump_state(_STATE_STOPPED, 1);
1286             }
1287             }
1288              
1289             sub _make_pipe {
1290 3     3   6 my $self = shift;
1291 3         6 my ($r, $w);
1292 3 50       126 if (pipe $r, $w) {
1293 3         18 my $old = select;
1294 3         9 select $r; $ |= 1;
  3         18  
1295 3         9 select $w; $ |= 1;
  3         6  
1296 3         9 select $old;
1297 3         18 return ($r, $w);
1298             }
1299 0         0 $self->_set_error(OSSH_SLAVE_PIPE_FAILED, "unable to create pipe: $!");
1300 0         0 return;
1301             }
1302              
1303             sub _remote_quoter {
1304 3     3   9 my ($self, $remote_shell) = @_;
1305 3 50 33     48 if (ref $self and (!defined $remote_shell or $remote_shell eq $self->{_remote_shell})) {
      33        
1306 3   33     90 return $self->{remote_quoter} ||= Net::OpenSSH::ShellQuoter->quoter($self->{_remote_shell});
1307             }
1308 0         0 Net::OpenSSH::ShellQuoter->quoter($remote_shell);
1309             }
1310              
1311             sub _quote_args {
1312 3     3   9 my $self = shift;
1313 3         3 my $opts = shift;
1314 3 50       15 ref $opts eq 'HASH' or die "internal error";
1315 3         6 my $quote = delete $opts->{quote_args};
1316 3         6 my $quote_extended = delete $opts->{quote_args_extended};
1317 3         6 my $glob_quoting = delete $opts->{glob_quoting};
1318 3 50       12 $quote = (@_ > 1) unless defined $quote;
1319              
1320 3 50       9 if ($quote) {
1321 3         3 my $remote_shell = delete $opts->{remote_shell};
1322 3         12 my $quoter = $self->_remote_quoter($remote_shell);
1323 3 50       12 my $quote_method = ($glob_quoting ? 'quote_glob' : 'quote');
1324             # foo => $quoter
1325             # \foo => $quoter_glob
1326             # \\foo => no quoting at all and disable extended quoting as it is not safe
1327 3         3 my @quoted;
1328 3         9 for (@_) {
1329 6 50       18 if (ref $_) {
1330 0 0 0     0 if (ref $_ eq 'SCALAR') {
    0          
1331 0         0 push @quoted, $quoter->quote_glob($self->_expand_vars($$_));
1332             }
1333             elsif (ref $_ eq 'REF' and ref $$_ eq 'SCALAR') {
1334 0         0 push @quoted, $self->_expand_vars($$$_);
1335 0         0 undef $quote_extended;
1336             }
1337             else {
1338 0         0 croak "invalid reference in remote command argument list"
1339             }
1340             }
1341             else {
1342 6         21 push @quoted, $quoter->$quote_method($self->_expand_vars($_));
1343             }
1344             }
1345              
1346 3 50       9 if ($quote_extended) {
1347 0         0 my @fragments;
1348 0 0 0     0 if ( $opts->{stdout_discard} and
      0        
1349             ( $opts->{stderr_discard} or $opts->{stderr_to_stdout} ) ) {
1350 0         0 @fragments = ('stdout_and_stderr_discard');
1351 0 0       0 push @fragments, 'stdin_discard' if $opts->{stdin_discard};
1352             }
1353             else {
1354 0         0 @fragments = grep $opts->{$_}, qw(stdin_discard stdout_discard
1355             stderr_discard stderr_to_stdout);
1356             }
1357 0         0 push @quoted, $quoter->shell_fragments(@fragments);
1358             }
1359 3 50       15 wantarray ? @quoted : join(" ", @quoted);
1360             }
1361             else {
1362 0 0       0 croak "reference found in argument list when argument quoting is disabled"
1363             if (grep ref, @_);
1364              
1365 0         0 my @args = $self->_expand_vars(@_);
1366 0 0       0 wantarray ? @args : join(" ", @args);
1367             }
1368             }
1369              
1370             sub shell_quote {
1371 0     0 1 0 shift->_quote_args({quote_args => 1}, @_);
1372             }
1373              
1374             sub shell_quote_glob {
1375 0     0 1 0 shift->_quote_args({quote_args => 1, glob_quoting => 1}, @_);
1376             }
1377              
1378 5 0   5   46 sub _array_or_scalar_to_list { map { defined($_) ? (ref $_ eq 'ARRAY' ? @$_ : $_ ) : () } @_ }
  5 50       38  
1379              
1380             sub make_remote_command {
1381 0     0 1 0 my $self = shift;
1382 0 0       0 $self->wait_for_master or return;
1383 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1384 0         0 my @ssh_opts = _array_or_scalar_to_list delete $opts{ssh_opts};
1385 0         0 my $tty = delete $opts{tty};
1386 0         0 my $ssh_flags = '';
1387 0 0       0 $ssh_flags .= ($tty ? 'qtt' : 'T') if defined $tty;
    0          
1388 0 0       0 if ($self->{_forward_agent}) {
1389 0 0       0 my $forward_always = (($self->{_forward_agent} eq 'always') ? 1 : undef);
1390 0         0 my $forward_agent = _first_defined(delete($opts{forward_agent}), $forward_always);
1391 0 0       0 $ssh_flags .= ($forward_agent ? 'A' : 'a') if defined $forward_agent;
    0          
1392             }
1393 0 0       0 if ($self->{_forward_X11}) {
1394 0         0 my $forward_X11 = delete $opts{forward_X11};
1395 0 0       0 $ssh_flags .= ($forward_X11 ? 'X' : 'x');
1396             }
1397 0         0 my $tunnel = delete $opts{tunnel};
1398 0         0 my (@args);
1399 0 0       0 if ($tunnel) {
1400 0         0 push @ssh_opts, $self->_make_W_option(@_);
1401             }
1402             else {
1403 0         0 my $subsystem = delete $opts{subsystem};
1404 0 0       0 if ($subsystem) {
1405 0         0 push @ssh_opts, '-s';
1406 0 0       0 @_ == 1 or croak "wrong number of arguments for subsystem command";
1407             }
1408 0         0 @args = $self->_quote_args(\%opts, @_);
1409             }
1410 0         0 _croak_bad_options %opts;
1411              
1412 0 0       0 push @ssh_opts, "-$ssh_flags" if length $ssh_flags;
1413 0         0 my @call = $self->_make_ssh_call(\@ssh_opts, @args);
1414 0 0       0 if (wantarray) {
1415 0 0 0     0 $debug and $debug & 16 and _debug_dump make_remote_command => \@call;
1416 0         0 return @call;
1417             }
1418             else {
1419 0         0 my $call = join ' ', $self->shell_quote(@call);
1420 0 0 0     0 $debug and $debug & 16 and _debug_dump 'make_remote_command (quoted)' => $call;
1421 0         0 return $call
1422             }
1423             }
1424              
1425             sub _open_file {
1426 0     0   0 my ($self, $default_mode, $name_or_args) = @_;
1427 0 0       0 my ($mode, @args) = (ref $name_or_args
1428             ? @$name_or_args
1429             : ($default_mode, $name_or_args));
1430 0         0 @args = $self->_expand_vars(@args);
1431 0 0       0 if (open my $fh, $mode, @args) {
1432 0         0 return $fh;
1433             }
1434             else {
1435 0         0 $self->_set_error(OSSH_SLAVE_PIPE_FAILED,
1436             "Unable to open file '$args[0]': $!");
1437 0         0 return undef;
1438             }
1439             }
1440              
1441             sub _fileno_dup_over {
1442 3     3   11 my ($good_fn, $fh) = @_;
1443 3 100       7 if (defined $fh) {
1444 2         5 my $fn = fileno $fh;
1445 2         19 for (1..5) {
1446 2 50       18 $fn >= $good_fn and return $fn;
1447 0         0 $fn = POSIX::dup($fn);
1448             }
1449 0         0 POSIX::_exit(255);
1450             }
1451 1         12 undef;
1452             }
1453              
1454             sub _exec_dpipe {
1455 0     0   0 my ($self, $cmd, $io, $err) = @_;
1456 0         0 my $io_fd = _fileno_dup_over(3 => $io);
1457 0         0 my $err_fd = _fileno_dup_over(3 => $err);
1458 0         0 POSIX::dup2($io_fd, 0);
1459 0         0 POSIX::dup2($io_fd, 1);
1460 0 0       0 POSIX::dup2($err_fd, 2) if defined $err_fd;
1461 0 0       0 if (ref $cmd) {
1462 0         0 exec @$cmd;
1463             }
1464             else {
1465 0         0 exec $cmd;
1466             }
1467             }
1468              
1469             sub _delete_stream_encoding {
1470 0     0   0 my ($self, $opts) = @_;
1471             _first_defined(delete $opts->{stream_encoding},
1472             $opts->{encoding},
1473 0         0 $self->{_default_stream_encoding});
1474             }
1475              
1476             sub _delete_argument_encoding {
1477 3     3   6 my ($self, $opts) = @_;
1478             _first_defined(delete $opts->{argument_encoding},
1479             delete $opts->{encoding},
1480 3         12 $self->{_default_argument_encoding});
1481             }
1482              
1483             sub open_ex {
1484 3 50   3 1 15 ${^TAINT} and &_catch_tainted_args;
1485 3         9 my $self = shift;
1486 3 50       18 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  3         18  
1487 3 50       12 unless (delete $opts{_no_master_required}) {
1488 0 0       0 $self->wait_for_master or return;
1489             }
1490              
1491 3         12 my $ssh_flags = '';
1492 3         9 my $tunnel = delete $opts{tunnel};
1493 3         6 my ($cmd, $close_slave_pty, @args);
1494 3 50       9 if ($tunnel) {
1495 0         0 @args = @_;
1496             }
1497             else {
1498 3         15 my $argument_encoding = $self->_delete_argument_encoding(\%opts);
1499 3         30 my $tty = delete $opts{tty};
1500 3 0       12 $ssh_flags .= ($tty ? 'qtt' : 'T') if defined $tty;
    50          
1501              
1502 3   50     12 $cmd = delete $opts{_cmd} || 'ssh';
1503             $opts{quote_args_extended} = 1
1504 3 50 33     27 if (not defined $opts{quote_args_extended} and $cmd eq 'ssh');
1505 3         36 @args = $self->_quote_args(\%opts, @_);
1506 3 50       33 $self->_encode_args($argument_encoding, @args) or return;
1507             }
1508              
1509 3         6 my ($stdinout_socket, $stdinout_dpipe_make_parent);
1510 3         6 my $stdinout_dpipe = delete $opts{stdinout_dpipe};
1511 3 50       6 if ($stdinout_dpipe) {
1512 0         0 $stdinout_dpipe_make_parent = delete $opts{stdinout_dpipe_make_parent};
1513 0         0 $stdinout_socket = 1;
1514             }
1515             else {
1516 3         6 $stdinout_socket = delete $opts{stdinout_socket};
1517             }
1518              
1519 3         6 my ($stdin_discard, $stdin_pipe, $stdin_fh, $stdin_file, $stdin_pty,
1520             $stdout_discard, $stdout_pipe, $stdout_fh, $stdout_file, $stdout_pty,
1521             $stderr_discard, $stderr_pipe, $stderr_fh, $stderr_file, $stderr_to_stdout);
1522 3 50       9 unless ($stdinout_socket) {
1523 3 0 33     12 unless ($stdin_discard = delete $opts{stdin_discard} or
      33        
      0        
1524             $stdin_pipe = delete $opts{stdin_pipe} or
1525             $stdin_fh = delete $opts{stdin_fh} or
1526             $stdin_file = delete $opts{stdin_file}) {
1527 0 0       0 unless ($tunnel) {
1528 0 0       0 if ($stdin_pty = delete $opts{stdin_pty}) {
1529 0         0 $close_slave_pty = _first_defined delete $opts{close_slave_pty}, 1;
1530             }
1531             }
1532             }
1533              
1534             ( $stdout_discard = delete $opts{stdout_discard} or
1535             $stdout_pipe = delete $opts{stdout_pipe} or
1536             $stdout_fh = delete $opts{stdout_fh} or
1537             $stdout_file = delete $opts{stdout_file} or
1538 3 0 0     33 (not $tunnel and $stdout_pty = delete $opts{stdout_pty}) );
      33        
      33        
      33        
1539              
1540 3 50 33     12 $stdout_pty and !$stdin_pty
1541             and croak "option stdout_pty requires stdin_pty set";
1542             }
1543              
1544             ( $stderr_discard = delete $opts{stderr_discard} or
1545             $stderr_pipe = delete $opts{stderr_pipe} or
1546             $stderr_fh = delete $opts{stderr_fh} or
1547             $stderr_to_stdout = delete $opts{stderr_to_stdout} or
1548 3 50 33     48 $stderr_file = delete $opts{stderr_file} );
      33        
      33        
1549              
1550 3         9 my $ssh_opts = delete $opts{ssh_opts};
1551 3 50       9 $ssh_opts = $self->{_default_ssh_opts} unless defined $ssh_opts;
1552 3         12 my @ssh_opts = $self->_expand_vars(_array_or_scalar_to_list $ssh_opts);
1553 3 50       9 if ($self->{_forward_agent}) {
1554 0 0       0 my $forward_always = (($self->{_forward_agent} eq 'always') ? 1 : undef);
1555 0         0 my $forward_agent = _first_defined(delete($opts{forward_agent}), $forward_always);
1556 0 0       0 $ssh_flags .= ($forward_agent ? 'A' : 'a') if defined $forward_agent;
    0          
1557             }
1558 3 50       9 if ($self->{_forward_X11}) {
1559 0         0 my $forward_X11 = delete $opts{forward_X11};
1560 0 0       0 $ssh_flags .= ($forward_X11 ? 'X' : 'x');
1561             }
1562 3 50       6 if (delete $opts{subsystem}) {
1563 0         0 $ssh_flags .= 's';
1564             }
1565              
1566 3         6 my $setpgrp = delete $opts{setpgrp};
1567 3 50       9 undef $setpgrp if defined $stdin_pty;
1568              
1569 3         30 _croak_bad_options %opts;
1570              
1571 3 50       6 if (defined $stdin_file) {
1572 0 0       0 $stdin_fh = $self->_open_file('<', $stdin_file) or return
1573             }
1574 3 50       9 if (defined $stdout_file) {
1575 0 0       0 $stdout_fh = $self->_open_file('>', $stdout_file) or return
1576             }
1577 3 50       9 if (defined $stderr_file) {
1578 0 0       0 $stderr_fh = $self->_open_file('>', $stderr_file) or return
1579             }
1580              
1581 3         6 my ($rin, $win, $rout, $wout, $rerr, $werr);
1582              
1583 3 50       9 if ($stdinout_socket) {
1584 0 0       0 unless(socketpair $rin, $win, AF_UNIX, SOCK_STREAM, PF_UNSPEC) {
1585 0         0 $self->_set_error(OSSH_SLAVE_PIPE_FAILED, "socketpair failed: $!");
1586 0         0 return;
1587             }
1588 0         0 $wout = $rin;
1589             }
1590             else {
1591 3 50       12 if ($stdin_pipe) {
    50          
    50          
1592 0 0       0 ($rin, $win) = $self->_make_pipe or return;
1593             }
1594             elsif ($stdin_pty) {
1595 0         0 _load_module('IO::Pty');
1596 0         0 $win = IO::Pty->new;
1597 0 0       0 unless ($win) {
1598 0         0 $self->_set_error(OSSH_SLAVE_PIPE_FAILED, "unable to allocate pseudo-tty: $!");
1599 0         0 return;
1600             }
1601 0         0 $rin = $win->slave;
1602             }
1603             elsif (defined $stdin_fh) {
1604 0         0 $rin = $stdin_fh;
1605             }
1606             else {
1607             $rin = $self->{_default_stdin_fh}
1608 3         6 }
1609 3         87 _check_is_system_fh STDIN => $rin;
1610              
1611 3 50       9 if ($stdout_pipe) {
    0          
    0          
1612 3 50       12 ($rout, $wout) = $self->_make_pipe or return;
1613             }
1614             elsif ($stdout_pty) {
1615 0         0 $wout = $rin;
1616             }
1617             elsif (defined $stdout_fh) {
1618 0         0 $wout = $stdout_fh;
1619             }
1620             else {
1621 0         0 $wout = $self->{_default_stdout_fh};
1622             }
1623 3         6 _check_is_system_fh STDOUT => $wout;
1624             }
1625              
1626 3 50       9 unless ($stderr_to_stdout) {
1627 0 0       0 if ($stderr_pipe) {
    0          
1628 0 0       0 ($rerr, $werr) = $self->_make_pipe or return;
1629             }
1630             elsif (defined $stderr_fh) {
1631 0         0 $werr = $stderr_fh;
1632             }
1633             else {
1634 0         0 $werr = $self->{_default_stderr_fh};
1635             }
1636 0         0 _check_is_system_fh STDERR => $werr;
1637             }
1638              
1639 3 50       12 push @ssh_opts, "-$ssh_flags" if length $ssh_flags;
1640              
1641 3 50       63 my @call = ( $tunnel ? $self->_make_tunnel_call(\@ssh_opts, @args) :
    50          
    50          
    50          
    50          
1642             $cmd eq 'ssh' ? $self->_make_ssh_call(\@ssh_opts, @args) :
1643             $cmd eq 'scp' ? $self->_make_scp_call(\@ssh_opts, @args) :
1644             $cmd eq 'rsync' ? $self->_make_rsync_call(\@ssh_opts, @args) :
1645             $cmd eq 'raw' ? @args :
1646             die "Internal error: bad _cmd protocol" );
1647              
1648 3 50 33     12 $debug and $debug & 16 and _debug_dump open_ex => \@call;
1649              
1650 3         2896 my $pid = fork;
1651 3 100       177 unless ($pid) {
1652 1 50       22 unless (defined $pid) {
1653 0         0 $self->_set_error(OSSH_SLAVE_FAILED,
1654             "unable to fork new ssh slave: $!");
1655 0         0 return;
1656             }
1657              
1658 1 50       14 setpgrp if $setpgrp;
1659              
1660 1 50 33     212 $stdin_discard and (open $rin, '<', '/dev/null' or POSIX::_exit(255));
1661 1 50 0     8 $stdout_discard and (open $wout, '>', '/dev/null' or POSIX::_exit(255));
1662 1 50 0     18 $stderr_discard and (open $werr, '>', '/dev/null' or POSIX::_exit(255));
1663              
1664 1 50       8 if ($stdinout_dpipe) {
1665 0         0 my $pid1 = fork;
1666 0 0       0 defined $pid1 or POSIX::_exit(255);
1667              
1668 0 0 0     0 unless ($pid1 xor $stdinout_dpipe_make_parent) {
1669 0         0 eval { $self->_exec_dpipe($stdinout_dpipe, $win, $werr) };
  0         0  
1670 0         0 POSIX::_exit(255);
1671             }
1672             }
1673              
1674 1         18 my $rin_fd = _fileno_dup_over(0 => $rin);
1675 1         8 my $wout_fd = _fileno_dup_over(1 => $wout);
1676 1         14 my $werr_fd = _fileno_dup_over(2 => $werr);
1677              
1678 1 50       9 if (defined $rin_fd) {
1679 1 50       4 $win->make_slave_controlling_terminal if $stdin_pty;
1680 1 50 33     50 $rin_fd == 0 or POSIX::dup2($rin_fd, 0) or POSIX::_exit(255);
1681             }
1682 1 50       11 if (defined $wout_fd) {
1683 1 50 33     13 $wout_fd == 1 or POSIX::dup2($wout_fd, 1) or POSIX::_exit(255);
1684             }
1685 1 50       16 if (defined $werr_fd) {
    50          
1686 0 0 0     0 $werr_fd == 2 or POSIX::dup2($werr_fd, 2) or POSIX::_exit(255);
1687             }
1688             elsif ($stderr_to_stdout) {
1689 1 50       7 POSIX::dup2(1, 2) or POSIX::_exit(255);
1690             }
1691 1         247 do { exec @call };
  1         0  
1692 0         0 POSIX::_exit(255);
1693             }
1694 2 50       50 $win->close_slave() if $close_slave_pty;
1695 2 50       32 undef $win if defined $stdinout_dpipe;
1696 2 50       284 wantarray ? ($win, $rout, $rerr, $pid) : $pid;
1697             }
1698              
1699             sub pipe_in {
1700 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
1701 0         0 my $self = shift;
1702 0 0       0 $self->wait_for_master or return;
1703 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1704 0         0 my $argument_encoding = $self->_delete_argument_encoding(\%opts);
1705 0         0 my @args = $self->_quote_args(\%opts, @_);
1706 0         0 _croak_bad_options %opts;
1707              
1708 0 0       0 $self->_encode_args($argument_encoding, @args) or return;
1709 0         0 my @call = $self->_make_ssh_call([], @args);
1710 0 0 0     0 $debug and $debug & 16 and _debug_dump pipe_in => @call;
1711 0         0 my $pid = open my $rin, '|-', @call;
1712 0 0       0 unless ($pid) {
1713 0         0 $self->_set_error(OSSH_SLAVE_FAILED,
1714             "unable to fork new ssh slave: $!");
1715 0         0 return;
1716             }
1717 0 0       0 wantarray ? ($rin, $pid) : $rin;
1718             }
1719              
1720             sub pipe_out {
1721 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
1722 0         0 my $self = shift;
1723 0 0       0 $self->wait_for_master or return;
1724 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1725 0         0 my $argument_encoding = $self->_delete_argument_encoding(\%opts);
1726 0         0 my @args = $self->_quote_args(\%opts, @_);
1727 0         0 _croak_bad_options %opts;
1728              
1729 0 0       0 $self->_encode_args($argument_encoding, @args) or return;
1730 0         0 my @call = $self->_make_ssh_call([], @args);
1731 0 0 0     0 $debug and $debug & 16 and _debug_dump pipe_out => @call;
1732 0         0 my $pid = open my $rout, '-|', @call;
1733 0 0       0 unless ($pid) {
1734 0         0 $self->_set_error(OSSH_SLAVE_FAILED,
1735             "unable to fork new ssh slave: $!");
1736 0         0 return;
1737             }
1738 0 0       0 wantarray ? ($rout, $pid) : $rout;
1739             }
1740              
1741             sub _find_encoding {
1742 5     5   20 my ($self, $encoding, $data) = @_;
1743 5 50 66     44 if (defined $encoding and $encoding ne 'bytes') {
1744 0         0 _load_module('Encode');
1745 0         0 my $enc = Encode::find_encoding($encoding);
1746 0 0       0 unless (defined $enc) {
1747 0         0 $self->_set_error(OSSH_ENCODING_ERROR, "bad encoding '$encoding'");
1748             return
1749 0         0 }
1750 0         0 return $enc
1751             }
1752             return undef
1753 5         12 }
1754              
1755             sub _encode {
1756 0     0   0 my $self = shift;
1757 0         0 my $enc = shift;
1758 0 0 0     0 if (defined $enc and @_) {
1759 0         0 local ($@, $SIG{__DIE__});
1760 0         0 eval {
1761 0         0 for (@_) {
1762 0 0       0 defined or next;
1763 0         0 $_ = $enc->encode($_, Encode::FB_CROAK());
1764             }
1765             };
1766 0 0       0 $self->_check_eval_ok(OSSH_ENCODING_ERROR) or return undef;
1767             }
1768 0         0 1;
1769             }
1770              
1771             sub _encode_args {
1772 3 50   3   15 if (@_ > 2) {
1773 3         6 my $self = shift;
1774 3         3 my $encoding = shift;
1775              
1776 3         21 my $enc = $self->_find_encoding($encoding);
1777 3 50       9 if ($enc) {
1778 0         0 local $self->{_error_prefix} = [@{$self->{_error_prefix}}, "argument encoding failed"];
  0         0  
1779 0         0 $self->_encode($enc, @_);
1780             }
1781 3         15 return !$self->{_error};
1782             }
1783 0         0 1;
1784             }
1785              
1786             sub _decode {
1787 0     0   0 my $self = shift;
1788 0         0 my $enc = shift;
1789 0         0 local ($@, $SIG{__DIE__});
1790 0         0 eval {
1791 0         0 for (@_) {
1792 0 0       0 defined or next;
1793 0         0 $_ = $enc->decode($_, Encode::FB_CROAK());
1794             }
1795             };
1796 0         0 $self->_check_eval_ok(OSSH_ENCODING_ERROR);
1797             }
1798              
1799             my @retriable = (Errno::EINTR(), Errno::EAGAIN());
1800             push @retriable, Errno::EWOULDBLOCK() if Errno::EWOULDBLOCK() != Errno::EAGAIN();
1801              
1802             sub _io3 {
1803 2     2   12 my ($self, $out, $err, $in, $stdin_data, $timeout, $encoding, $keep_in_open) = @_;
1804             # $self->wait_for_master or return;
1805 2         56 my @data = _array_or_scalar_to_list $stdin_data;
1806 2         30 my ($cout, $cerr, $cin) = (defined($out), defined($err), defined($in));
1807 2 50       66 $timeout = $self->{_timeout} unless defined $timeout;
1808              
1809 2 0       8 my $has_input = grep { defined and length } @data;
  0         0  
1810 2 50 33     60 if ($cin and !$has_input) {
    50 33        
1811 0 0       0 close $in unless $keep_in_open;
1812 0         0 undef $cin;
1813             }
1814             elsif (!$cin and $has_input) {
1815 0         0 croak "remote input channel is not defined but data is available for sending"
1816             }
1817              
1818 2         140 my $enc = $self->_find_encoding($encoding);
1819 2 50 33     18 if ($enc and @data) {
1820 0         0 local $self->{_error_prefix} = [@{$self->{_error_prefix}}, "stdin data encoding failed"];
  0         0  
1821 0 0       0 $self->_encode($enc, @data) if $has_input;
1822 0 0       0 return if $self->{_error};
1823             }
1824              
1825 2         18 my $bout = '';
1826 2         6 my $berr = '';
1827 2         4 my ($fnoout, $fnoerr, $fnoin);
1828 2         106 local $SIG{PIPE} = 'IGNORE';
1829              
1830 2   66     10 MLOOP: while ($cout or $cerr or $cin) {
      66        
1831 2 50 0     18 $debug and $debug & 64 and _debug "io3 mloop, cin: " . ($cin || 0) .
      0        
      0        
      33        
1832             ", cout: " . ($cout || 0) . ", cerr: " . ($cerr || 0);
1833 2         6 my ($rv, $wv);
1834              
1835 2 50 33     20 if ($cout or $cerr) {
1836 2         6 $rv = '';
1837 2 50       10 if ($cout) {
1838 2         320 $fnoout = fileno $out;
1839 2         28 vec($rv, $fnoout, 1) = 1;
1840             }
1841 2 50       10 if ($cerr) {
1842 0         0 $fnoerr = fileno $err;
1843 0         0 vec($rv, $fnoerr, 1) = 1
1844             }
1845             }
1846              
1847 2 50       6 if ($cin) {
1848 0         0 $fnoin = fileno $in;
1849 0         0 $wv = '';
1850 0         0 vec($wv, $fnoin, 1) = 1;
1851             }
1852              
1853 2         2 my $recalc_vecs;
1854 2         6 FAST: until ($recalc_vecs) {
1855 4 50 0     12 $debug and $debug & 64 and
      0        
      0        
      33        
1856             _debug "io3 fast, cin: " . ($cin || 0) .
1857             ", cout: " . ($cout || 0) . ", cerr: " . ($cerr || 0);
1858 4         18 my ($rv1, $wv1) = ($rv, $wv);
1859 4         2330580 my $n = select ($rv1, $wv1, undef, $timeout);
1860 4 50       34 if ($n > 0) {
1861 4 50 33     46 if ($cout and vec($rv1, $fnoout, 1)) {
1862 4         8 my $offset = length $bout;
1863 4         136 my $read = sysread($out, $bout, 20480, $offset);
1864 4 50 33     20 if ($debug and $debug & 64) {
1865 0         0 _debug "stdout, bytes read: ", $read, " at offset $offset";
1866 0 0 0     0 $read and $debug & 128 and _hexdump substr $bout, $offset;
1867             }
1868 4 100 66     58 unless ($read or grep $! == $_, @retriable) {
1869 2         38 close $out;
1870 2         8 undef $cout;
1871 2         4 $recalc_vecs = 1;
1872             }
1873             }
1874 4 50 33     56 if ($cerr and vec($rv1, $fnoerr, 1)) {
1875 0         0 my $read = sysread($err, $berr, 20480, length($berr));
1876 0 0 0     0 $debug and $debug & 64 and _debug "stderr, bytes read: ", $read;
1877 0 0 0     0 unless ($read or grep $! == $_, @retriable) {
1878 0         0 close $err;
1879 0         0 undef $cerr;
1880 0         0 $recalc_vecs = 1;
1881             }
1882             }
1883 4 50 33     48 if ($cin and vec($wv1, $fnoin, 1)) {
1884 0         0 my $written = syswrite($in, $data[0], 20480);
1885 0 0 0     0 if ($debug and $debug & 64) {
1886 0         0 _debug "stdin, bytes written: ", $written;
1887 0 0 0     0 $written and $debug & 128 and _hexdump substr $data[0], 0, $written;
1888             }
1889 0 0       0 if ($written) {
    0          
1890 0         0 substr($data[0], 0, $written, '');
1891 0         0 while (@data) {
1892             next FAST
1893 0 0 0     0 if (defined $data[0] and length $data[0]);
1894 0         0 shift @data;
1895             }
1896             # fallback when stdin queue is exhausted
1897             }
1898             elsif (grep $! == $_, @retriable) {
1899 0         0 next FAST;
1900             }
1901 0 0       0 close $in unless $keep_in_open;
1902 0         0 undef $cin;
1903 0         0 $recalc_vecs = 1;
1904             }
1905             }
1906             else {
1907 0 0 0     0 next if $n < 0 and grep $! == $_, @retriable;
1908 0         0 $self->_set_error(OSSH_SLAVE_TIMEOUT, 'ssh slave failed', 'timed out');
1909 0         0 last MLOOP;
1910             }
1911             }
1912             }
1913 2 50       6 close $out if $cout;
1914 2 50       6 close $err if $cerr;
1915 2 50 33     6 close $in if $cin and not $keep_in_open;
1916              
1917 2 50       20 if ($enc) {
1918 0         0 local $self->{_error_prefix} = [@{$self->{_error_prefix}}, 'output decoding failed'];
  0         0  
1919 0 0       0 unless ($self->_decode($enc, $bout, $berr)) {
1920 0         0 undef $bout;
1921 0         0 undef $berr;
1922             }
1923             }
1924 2 50 33     18 $debug and $debug & 64 and _debug "leaving _io3()";
1925 2         40 return ($bout, $berr);
1926             }
1927              
1928              
1929              
1930             _sub_options spawn => qw(stderr_to_stdout stdin_discard stdin_fh stdin_file stdout_discard stdout_fh
1931             stdout_file stderr_discard stderr_fh stderr_file stdinout_dpipe
1932             stdinout_dpipe_make_parent quote_args quote_args_extended remote_shell
1933             glob_quoting tty ssh_opts tunnel encoding argument_encoding forward_agent
1934             forward_X11 setpgrp subsystem);
1935             sub spawn {
1936 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
1937 0         0 my $self = shift;
1938 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1939 0         0 _croak_bad_options %opts;
1940              
1941 0         0 return scalar $self->open_ex(\%opts, @_);
1942             }
1943              
1944             _sub_options open2 => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file quote_args quote_args_extended
1945             remote_shell glob_quoting tty ssh_opts tunnel encoding argument_encoding forward_agent
1946             forward_X11 setpgrp subsystem);
1947             sub open2 {
1948 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
1949 0         0 my $self = shift;
1950 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1951 0         0 _croak_bad_options %opts;
1952 0         0 _croak_scalar_context;
1953              
1954 0 0       0 my ($in, $out, undef, $pid) =
1955             $self->open_ex({ stdout_pipe => 1,
1956             stdin_pipe => 1,
1957             %opts }, @_) or return ();
1958 0         0 return ($in, $out, $pid);
1959             }
1960              
1961             _sub_options open2pty => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file
1962             quote_args quote_args_extended remote_shell glob_quoting tty
1963             close_slave_pty ssh_opts encoding argument_encoding forward_agent
1964             forward_X11 setpgrp subsystem);
1965             sub open2pty {
1966 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
1967 0         0 my $self = shift;
1968 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1969 0         0 _croak_bad_options %opts;
1970              
1971 0 0       0 my ($pty, undef, undef, $pid) =
1972             $self->open_ex({ stdout_pty => 1,
1973             stdin_pty => 1,
1974             tty => 1,
1975             %opts }, @_) or return ();
1976 0 0       0 wantarray ? ($pty, $pid) : $pty;
1977             }
1978              
1979             _sub_options open2socket => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file
1980             quote_args quote_args_extended remote_shell glob_quoting tty
1981             ssh_opts tunnel encoding argument_encoding forward_agent
1982             forward_X11 setpgrp subsystem);
1983             sub open2socket {
1984 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
1985 0         0 my $self = shift;
1986 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
1987 0         0 _croak_bad_options %opts;
1988              
1989 0 0       0 my ($socket, undef, undef, $pid) =
1990             $self->open_ex({ stdinout_socket => 1,
1991             %opts }, @_) or return ();
1992 0 0       0 wantarray ? ($socket, $pid) : $socket;
1993             }
1994              
1995             _sub_options open3 => qw(quote_args quote_args_extended remote_shell glob_quoting tty ssh_opts
1996             encoding argument_encoding forward_agent forward_X11 setpgrp subsystem);
1997             sub open3 {
1998 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
1999 0         0 my $self = shift;
2000 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2001 0         0 _croak_bad_options %opts;
2002 0         0 _croak_scalar_context;
2003              
2004 0 0       0 my ($in, $out, $err, $pid) =
2005             $self->open_ex({ stdout_pipe => 1,
2006             stdin_pipe => 1,
2007             stderr_pipe => 1,
2008             %opts },
2009             @_) or return ();
2010 0         0 return ($in, $out, $err, $pid);
2011             }
2012              
2013             _sub_options open3pty => qw(quote_args quote_args_extended remote_shell glob_quoting tty close_slave_pty ssh_opts
2014             encoding argument_encoding forward_agent forward_X11 setpgrp subsystem);
2015             sub open3pty {
2016 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2017 0         0 my $self = shift;
2018 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2019 0         0 _croak_bad_options %opts;
2020 0         0 _croak_scalar_context;
2021              
2022 0 0       0 my ($pty, undef, $err, $pid) =
2023             $self->open_ex({ stdout_pty => 1,
2024             stdin_pty => 1,
2025             tty => 1,
2026             stderr_pipe => 1,
2027             %opts },
2028             @_) or return ();
2029 0         0 return ($pty, $err, $pid);
2030             }
2031              
2032             _sub_options open3socket => qw(quote_args quote_args_extended remote_shell glob_quoting tty ssh_opts encoding
2033             argument_encoding forward_agent forward_X11 setpgrp subsystem);
2034             sub open3socket {
2035 0 0   0 0 0 ${^TAINT} and &_catch_tainted_args;
2036 0         0 my $self = shift;
2037 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2038 0         0 _croak_bad_options %opts;
2039 0         0 _croak_scalar_context;
2040              
2041 0 0       0 my ($socket, undef, $err, $pid) =
2042             $self->open_ex({ stdinout_socket => 1,
2043             stderr_pipe => 1,
2044             %opts }, @_) or return ();
2045 0         0 return ($socket, $err, $pid);
2046             }
2047              
2048             _sub_options system => qw(stdout_discard stdout_fh stdin_discard stdout_file stdin_fh stdin_file
2049             quote_args quote_args_extended remote_shell glob_quoting
2050             stderr_to_stdout stderr_discard stderr_fh stderr_file
2051             stdinout_dpipe stdinout_dpipe_make_parent tty ssh_opts tunnel encoding
2052             argument_encoding forward_agent forward_X11 setpgrp subsystem);
2053             sub system {
2054 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2055 0         0 my $self = shift;
2056 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2057 0         0 my $stdin_data = delete $opts{stdin_data};
2058 0         0 my $timeout = delete $opts{timeout};
2059 0         0 my $async = delete $opts{async};
2060 0 0       0 my $stdin_keep_open = ($async ? undef : delete $opts{stdin_keep_open});
2061              
2062 0         0 _croak_bad_options %opts;
2063              
2064 0 0 0     0 $stdin_data = '' if $stdin_keep_open and not defined $stdin_data;
2065              
2066 0         0 my $stream_encoding;
2067 0 0       0 if (defined $stdin_data) {
2068 0         0 $opts{stdin_pipe} = 1;
2069 0         0 $stream_encoding = $self->_delete_stream_encoding(\%opts);
2070             }
2071              
2072 0         0 local $SIG{INT} = 'IGNORE';
2073 0         0 local $SIG{QUIT} = 'IGNORE';
2074 0         0 local $SIG{CHLD};
2075              
2076 0 0       0 my ($in, undef, undef, $pid) = $self->open_ex(\%opts, @_) or return undef;
2077              
2078 0 0       0 $self->_io3(undef, undef, $in, $stdin_data,
2079             $timeout, $stream_encoding, $stdin_keep_open) if defined $stdin_data;
2080 0 0       0 return $pid if $async;
2081 0         0 $self->_waitpid($pid, $timeout);
2082             }
2083              
2084             _sub_options test => qw(stdout_discard stdout_fh stdin_discard stdout_file stdin_fh stdin_file
2085             quote_args quote_args_extended remote_shell glob_quoting stderr_to_stdout
2086             stderr_discard stderr_fh stderr_file stdinout_dpipe
2087             stdinout_dpipe_make_parent tty ssh_opts timeout stdin_data stdin_keep_open
2088             encoding stream_encoding argument_encoding forward_agent forward_X11
2089             setpgrp subsystem);
2090              
2091             sub test {
2092 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2093 0         0 my $self = shift;
2094 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2095 0 0       0 $opts{stdout_discard} = 1 unless grep defined($opts{$_}), qw(stdout_discard stdout_fh
2096             stdout_file stdinout_dpipe);
2097 0 0       0 $opts{stderr_discard} = 1 unless grep defined($opts{$_}), qw(stderr_discard stderr_fh
2098             stderr_file stderr_to_stdout);
2099 0         0 _croak_bad_options %opts;
2100              
2101 0         0 $self->system(\%opts, @_);
2102 0         0 my $error = $self->{_error};
2103 0 0       0 unless ($error) {
2104 0         0 return 1;
2105             }
2106 0 0       0 if ($error == OSSH_SLAVE_CMD_FAILED) {
2107 0         0 $self->_set_error(0);
2108 0         0 return 0;
2109             }
2110 0         0 return undef;
2111             }
2112              
2113             _sub_options capture => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file stdin_discard
2114             stdin_fh stdin_file quote_args quote_args_extended remote_shell
2115             glob_quoting tty ssh_opts tunnel encoding argument_encoding forward_agent
2116             forward_X11 setpgrp subsystem);
2117             sub capture {
2118 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2119 0         0 my $self = shift;
2120 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2121 0         0 my $stdin_data = delete $opts{stdin_data};
2122 0         0 my $stdin_keep_open = delete $opts{stdin_keep_open};
2123 0         0 my $timeout = delete $opts{timeout};
2124 0         0 _croak_bad_options %opts;
2125              
2126 0 0 0     0 $stdin_data = '' if $stdin_keep_open and not defined $stdin_data;
2127              
2128 0         0 my $stream_encoding = $self->_delete_stream_encoding(\%opts);
2129 0         0 $opts{stdout_pipe} = 1;
2130 0 0       0 $opts{stdin_pipe} = 1 if defined $stdin_data;
2131              
2132 0         0 local $SIG{INT} = 'IGNORE';
2133 0         0 local $SIG{QUIT} = 'IGNORE';
2134 0         0 local $SIG{CHLD};
2135              
2136 0 0       0 my ($in, $out, undef, $pid) = $self->open_ex(\%opts, @_) or return ();
2137 0         0 my ($output) = $self->_io3($out, undef, $in, $stdin_data,
2138             $timeout, $stream_encoding, $stdin_keep_open);
2139 0         0 $self->_waitpid($pid, $timeout);
2140 0 0       0 if (wantarray) {
2141 0         0 my $pattern = quotemeta $/;
2142 0         0 return split /(?<=$pattern)/, $output;
2143             }
2144             $output
2145 0         0 }
2146              
2147             _sub_options capture2 => qw(stdin_discard stdin_fh stdin_file quote_args quote_args_extended
2148             remote_shell glob_quoting tty ssh_opts encoding stream_encoding
2149             argument_encoding forward_agent forward_X11 setpgrp subsystem);
2150             sub capture2 {
2151 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2152 0         0 my $self = shift;
2153 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2154 0         0 my $stdin_data = delete $opts{stdin_data};
2155 0         0 my $stdin_keep_open = delete $opts{stdin_keep_open};
2156 0         0 my $timeout = delete $opts{timeout};
2157 0         0 _croak_bad_options %opts;
2158              
2159 0 0 0     0 $stdin_data = '' if $stdin_keep_open and not defined $stdin_data;
2160              
2161 0         0 my $stream_encoding = $self->_delete_stream_encoding(\%opts);
2162 0         0 $opts{stdout_pipe} = 1;
2163 0         0 $opts{stderr_pipe} = 1;
2164 0 0       0 $opts{stdin_pipe} = 1 if defined $stdin_data;
2165              
2166 0         0 local $SIG{INT} = 'IGNORE';
2167 0         0 local $SIG{QUIT} = 'IGNORE';
2168 0         0 local $SIG{CHLD};
2169              
2170 0 0       0 my ($in, $out, $err, $pid) = $self->open_ex( \%opts, @_) or return ();
2171 0         0 my @capture = $self->_io3($out, $err, $in, $stdin_data,
2172             $timeout, $stream_encoding, $stdin_keep_open);
2173 0         0 $self->_waitpid($pid, $timeout);
2174 0 0       0 wantarray ? @capture : $capture[0];
2175             }
2176              
2177             _sub_options open_tunnel => qw(ssh_opts stderr_discard stderr_fh stderr_file
2178             encoding argument_encoding forward_agent setpgrp);
2179             sub open_tunnel {
2180 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2181 0         0 my $self = shift;
2182 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2183 0 0       0 $opts{stderr_discard} = 1 unless grep defined $opts{$_}, qw(stderr_discard stderr_fh stderr_file);
2184 0         0 _croak_bad_options %opts;
2185 0 0       0 @_ == 2 or croak 'Usage: $ssh->open_tunnel(\%opts, $host, $port)';
2186 0         0 $opts{tunnel} = 1;
2187 0         0 $self->open2socket(\%opts, @_);
2188             }
2189              
2190             _sub_options capture_tunnel => qw(ssh_opts stderr_discard stderr_fh stderr_file stdin_discard
2191             stdin_fh stdin_file stdin_data timeout encoding stream_encoding
2192             argument_encoding forward_agent setpgrp);
2193             sub capture_tunnel {
2194 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2195 0         0 my $self = shift;
2196 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2197 0 0       0 $opts{stderr_discard} = 1 unless grep defined $opts{$_}, qw(stderr_discard stderr_fh stderr_file);
2198 0         0 _croak_bad_options %opts;
2199 0 0       0 @_ == 2 or croak 'Usage: $ssh->capture_tunnel(\%opts, $host, $port)';
2200 0         0 $opts{tunnel} = 1;
2201 0         0 $self->capture(\%opts, @_);
2202             }
2203              
2204             sub _calling_method {
2205 0     0   0 my $method = (caller 2)[3];
2206 0         0 $method =~ s/.*:://;
2207 0         0 $method;
2208             }
2209              
2210             sub _scp_get_args {
2211 0     0   0 my $self = shift;
2212 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2213              
2214 0 0       0 @_ > 0 or croak
2215             'Usage: $ssh->' . _calling_method . '(\%opts, $remote_fn1, $remote_fn2, ..., $local_fn_or_dir)';
2216              
2217 0         0 my $glob = delete $opts{glob};
2218              
2219 0 0       0 my $target = (@_ > 1 ? pop @_ : '.');
2220 0 0       0 $target =~ m|^[^/]*:| and $target = "./$target";
2221              
2222 0         0 my $prefix = $self->{_host_squared};
2223 0 0       0 $prefix = "$self->{_user}\@$prefix" if defined $self->{_user};
2224              
2225 0         0 my $src = "$prefix:". join(" ", $self->_quote_args({quote_args => 1,
2226             glob_quoting => $glob},
2227             @_));
2228 0         0 ($self, \%opts, $target, $src);
2229             }
2230              
2231             sub scp_get {
2232 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2233 0         0 my ($self, $opts, $target, @src) = _scp_get_args @_;
2234 0         0 $self->_scp($opts, @src, $target);
2235             }
2236              
2237             sub rsync_get {
2238 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2239 0         0 my ($self, $opts, $target, @src) = _scp_get_args @_;
2240 0         0 $self->_rsync($opts, @src, $target);
2241             }
2242              
2243             sub _scp_put_args {
2244 0     0   0 my $self = shift;
2245 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2246              
2247 0 0       0 @_ > 0 or croak
2248             'Usage: $ssh->' . _calling_method . '(\%opts, $local_fn1, $local_fn2, ..., $remote_dir_or_fn)';
2249              
2250 0         0 my $glob = delete $opts{glob};
2251 0 0 0     0 my $glob_flags = ($glob ? delete $opts{glob_flags} || 0 : undef);
2252              
2253 0         0 my $prefix = $self->{_host_squared};
2254 0 0       0 $prefix = "$self->{_user}\@$prefix" if defined $self->{_user};
2255              
2256 0         0 my $remote_shell = delete $opts{remote_shell};
2257 0 0       0 my $target = $prefix . ':' . ( @_ > 1
2258             ? $self->_quote_args({quote_args => 1, remote_shell => $remote_shell}, pop(@_))
2259             : '');
2260              
2261 0         0 my @src = @_;
2262 0 0       0 if ($glob) {
2263 0         0 require File::Glob;
2264 0         0 @src = map File::Glob::bsd_glob($_, $glob_flags), @src;
2265 0 0       0 unless (@src) {
2266 0         0 $self->_set_error(OSSH_SLAVE_FAILED,
2267             "given file name patterns did not match any file");
2268 0         0 return undef;
2269             }
2270             }
2271 0         0 $_ = "./$_" for grep m|^[^/]*:|, @src;
2272              
2273 0         0 ($self, \%opts, $target, @src);
2274             }
2275              
2276             sub scp_put {
2277 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2278 0         0 my ($self, $opts, $target, @src) = _scp_put_args @_;
2279 0 0       0 return unless $self;
2280 0         0 $self->_scp($opts, @src, $target);
2281             }
2282              
2283             sub rsync_put {
2284 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2285 0         0 my ($self, $opts, $target, @src) = _scp_put_args @_;
2286 0 0       0 return unless $self;
2287 0         0 $self->_rsync($opts, @src, $target);
2288             }
2289              
2290             _sub_options _scp => qw(stderr_to_stdout stderr_discard stderr_fh
2291             stderr_file stdout_discard stdout_fh
2292             stdout_file encoding argument_encoding
2293             forward_agent setpgrp);
2294             sub _scp {
2295 0     0   0 my $self = shift;
2296 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2297 0         0 my $quiet = delete $opts{quiet};
2298 0 0       0 $quiet = 1 unless defined $quiet;
2299 0         0 my $recursive = delete $opts{recursive};
2300 0         0 my $copy_attrs = delete $opts{copy_attrs};
2301 0         0 my $bwlimit = delete $opts{bwlimit};
2302 0         0 my $async = delete $opts{async};
2303 0         0 my $ssh_opts = delete $opts{ssh_opts};
2304 0         0 my $timeout = delete $opts{timeout};
2305 0         0 my $verbose = delete $opts{verbose};
2306 0         0 _croak_bad_options %opts;
2307              
2308 0         0 my @opts;
2309 0 0       0 @opts = @$ssh_opts if $ssh_opts;
2310 0 0       0 push @opts, '-q' if $quiet;
2311 0 0       0 push @opts, '-v' if $verbose;
2312 0 0       0 push @opts, '-r' if $recursive;
2313 0 0       0 push @opts, '-p' if $copy_attrs;
2314 0 0       0 push @opts, '-l', $bwlimit if $bwlimit;
2315              
2316 0         0 local $self->{_error_prefix} = [@{$self->{_error_prefix}}, 'scp failed'];
  0         0  
2317              
2318 0         0 my $pid = $self->open_ex({ %opts,
2319             _cmd => 'scp',
2320             ssh_opts => \@opts,
2321             quote_args => 0 },
2322             @_);
2323              
2324 0 0       0 return $pid if $async;
2325 0         0 $self->_waitpid($pid, $timeout);
2326             }
2327              
2328             my %rsync_opt_with_arg = map { $_ => 1 } qw(chmod suffix backup-dir rsync-path max-delete max-size min-size partial-dir
2329             timeout modify-window temp-dir compare-dest copy-dest link-dest compress-level
2330             skip-compress filter exclude exclude-from include include-from
2331             out-format log-file log-file-format bwlimit protocol iconv checksum-seed files-from);
2332              
2333             my %rsync_opt_forbidden = map { $_ => 1 } qw(rsh address port sockopts password-file write-batch
2334             only-write-batch read-batch ipv4 ipv6 version help daemon config detach
2335             protect-args list-only);
2336              
2337             $rsync_opt_forbidden{"no-$_"} = 1 for (keys %rsync_opt_with_arg, keys %rsync_opt_forbidden);
2338              
2339             my %rsync_error = (1, 'syntax or usage error',
2340             2, 'protocol incompatibility',
2341             3, 'errors selecting input/output files, dirs',
2342             4, 'requested action not supported: an attempt was made to manipulate 64-bit files on a platform '.
2343             'that cannot support them; or an option was specified that is supported by the client and not '.
2344             'by the server.',
2345             5, 'error starting client-server protocol',
2346             6, 'daemon unable to append to log-file',
2347             10, 'error in socket I/O',
2348             11, 'error in file I/O',
2349             12, 'error in rsync protocol data stream',
2350             13, 'errors with program diagnostics',
2351             14, 'error in IPC code',
2352             20, 'received SIGUSR1 or SIGINT',
2353             21, 'some error returned by waitpid()',
2354             22, 'error allocating core memory buffers',
2355             23, 'partial transfer due to error',
2356             24, 'partial transfer due to vanished source files',
2357             25, 'the --max-delete limit stopped deletions',
2358             30, 'timeout in data send/receive',
2359             35, 'timeout waiting for daemon connection');
2360              
2361             my %rsync_opt_open_ex = map { $_ => 1 } qw(stderr_to_stdout
2362             stderr_discard stderr_fh
2363             stderr_file stdout_discard
2364             stdout_fh stdout_file encoding
2365             argument_encoding);
2366             sub _rsync {
2367 0     0   0 my $self = shift;
2368 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2369 0         0 my $async = delete $opts{async};
2370 0         0 my $verbose = delete $opts{verbose};
2371 0         0 my $quiet = delete $opts{quiet};
2372 0         0 my $copy_attrs = delete $opts{copy_attrs};
2373 0         0 my $timeout = delete $opts{timeout};
2374 0 0 0     0 $quiet = 1 unless (defined $quiet or $verbose);
2375              
2376 0         0 my @opts;
2377 0 0       0 push @opts, '-q' if $quiet;
2378 0 0       0 push @opts, '-pt' if $copy_attrs;
2379 0 0       0 push @opts, '-' . ($verbose =~ /^\d+$/ ? 'v' x $verbose : 'v') if $verbose;
    0          
2380              
2381 0         0 my %opts_open_ex = ( _cmd => 'rsync',
2382             quote_args => 0 );
2383              
2384 0         0 for my $opt (keys %opts) {
2385 0         0 my $value = $opts{$opt};
2386 0 0       0 if (defined $value) {
2387 0 0       0 if ($rsync_opt_open_ex{$opt}) {
2388 0         0 $opts_open_ex{$opt} = $value;
2389             }
2390             else {
2391 0         0 my $opt1 = $opt;
2392 0         0 $opt1 =~ tr/_/-/;
2393 0 0       0 $rsync_opt_forbidden{$opt1} and croak "forbidden rsync option '$opt' used";
2394 0 0       0 if ($rsync_opt_with_arg{$opt1}) {
2395 0         0 push @opts, "--$opt1=$_" for _array_or_scalar_to_list($value)
2396             }
2397             else {
2398 0 0       0 $value = !$value if $opt1 =~ s/^no-//;
2399 0 0       0 push @opts, ($value ? "--$opt1" : "--no-$opt1");
2400             }
2401             }
2402             }
2403             }
2404              
2405 0         0 local $self->{_error_prefix} = [@{$self->{_error_prefix}}, 'rsync failed'];
  0         0  
2406              
2407 0         0 my $pid = $self->open_ex(\%opts_open_ex, @opts, '--', @_);
2408 0 0       0 return $pid if $async;
2409 0 0       0 $self->_waitpid($pid, $timeout) and return 1;
2410              
2411 0 0 0     0 if ($self->{_error} == OSSH_SLAVE_CMD_FAILED and $?) {
2412 0         0 my $err = ($? >> 8);
2413 0         0 my $errstr = $rsync_error{$err};
2414 0 0       0 $errstr = 'Unknown rsync error' unless defined $errstr;
2415 0         0 my $signal = $? & 255;
2416 0 0       0 my $signalstr = ($signal ? " (signal $signal)" : '');
2417 0         0 $self->_set_error(OSSH_SLAVE_CMD_FAILED,
2418             "command exited with code $err$signalstr: $errstr");
2419             }
2420             return undef
2421 0         0 }
2422              
2423             _sub_options sftp => qw(autoflush timeout argument_encoding encoding block_size queue_size autodie
2424             late_set_perm forward_agent setpgrp min_block_size read_ahead write_delay
2425             dirty_cleanup remote_has_volumes autodisconnect more);
2426              
2427             sub sftp {
2428 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2429 0 0       0 @_ & 1 or croak 'Usage: $ssh->sftp(%sftp_opts)';
2430 0         0 _load_module('Net::SFTP::Foreign', '1.47');
2431 0         0 my ($self, %opts) = @_;
2432 0         0 my $stderr_fh = delete $opts{stderr_fh};
2433 0         0 my $stderr_discard = delete $opts{stderr_discard};
2434             my $fs_encoding = _first_defined(delete $opts{fs_encoding},
2435             $opts{argument_encoding},
2436             $opts{encoding},
2437 0         0 $self->{_default_argument_encoding});
2438 0 0 0     0 undef $fs_encoding if (defined $fs_encoding and $fs_encoding eq 'bytes');
2439 0         0 _croak_bad_options %opts;
2440 0 0       0 $opts{timeout} = $self->{_timeout} unless defined $opts{timeout};
2441 0 0       0 $self->wait_for_master or return undef;
2442 0 0       0 my ($in, $out, $pid) = $self->open2( { subsystem => 1,
2443             stderr_fh => $stderr_fh,
2444             stderr_discard => $stderr_discard },
2445             'sftp' )
2446             or return undef;
2447              
2448 0         0 my $sftp = Net::SFTP::Foreign->new(transport => [$out, $in, $pid],
2449             dirty_cleanup => 0,
2450             fs_encoding => $fs_encoding,
2451             %opts);
2452 0 0       0 if ($sftp->error) {
2453 0         0 $self->_or_set_error(OSSH_SLAVE_SFTP_FAILED, "unable to create SFTP client", $sftp->error);
2454 0         0 return undef;
2455             }
2456             $sftp
2457 0         0 }
2458              
2459             _sub_options sshfs_import => qw(stderr_discard stderr_fh stderr_file
2460             ssh_opts argument_encoding sshfs_opts setpgrp);
2461             sub sshfs_import {
2462 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2463 0         0 my $self = shift;
2464 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2465 0 0       0 @_ == 2 or croak 'Usage: $ssh->sshfs_import(\%opts, $remote, $local)';
2466 0         0 my ($from, $to) = @_;
2467             my @sshfs_opts = ( -o => 'slave',
2468 0         0 _array_or_scalar_to_list delete $opts{sshfs_opts} );
2469 0         0 _croak_bad_options %opts;
2470              
2471 0         0 $opts{ssh_opts} = ['-s', _array_or_scalar_to_list delete $opts{ssh_opts}];
2472 0         0 $opts{stdinout_dpipe} = [$self->{_sshfs_cmd}, "$self->{_host_squared}:$from", $to, @sshfs_opts];
2473 0         0 $opts{stdinout_dpipe_make_parent} = 1;
2474 0         0 $self->spawn(\%opts, 'sftp');
2475             }
2476              
2477             _sub_options sshfs_export => qw(stderr_discard stderr_fh stderr_file
2478             ssh_opts argument_encoding sshfs_opts setpgrp);
2479             sub sshfs_export {
2480 0 0   0 1 0 ${^TAINT} and &_catch_tainted_args;
2481 0         0 my $self = shift;
2482 0 0       0 my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ());
  0         0  
2483 0 0       0 @_ == 2 or croak 'Usage: $ssh->sshfs_export(\%opts, $local, $remote)';
2484 0         0 my ($from, $to) = @_;
2485             my @sshfs_opts = ( -o => 'slave',
2486 0         0 _array_or_scalar_to_list delete $opts{sshfs_opts} );
2487 0         0 _croak_bad_options %opts;
2488 0         0 $opts{stdinout_dpipe} = $self->{_sftp_server_cmd};
2489              
2490 0         0 my $hostname = do {
2491 0         0 local ($@, $SIG{__DIE__});
2492 0         0 eval {
2493 0         0 require Sys::Hostname;
2494 0         0 Sys::Hostname::hostname();
2495             };
2496             };
2497 0 0 0     0 $hostname = 'remote' if (not defined $hostname or
      0        
2498             not length $hostname or
2499             $hostname=~/^localhost\b/);
2500 0         0 $self->spawn(\%opts, $self->{_sshfs_cmd}, "$hostname:$from", $to, @sshfs_opts);
2501             }
2502              
2503             sub object_remote {
2504 0     0 1 0 my $self = shift;
2505 0 0       0 _load_module('Object::Remote') or return;
2506 0 0       0 _load_module('Net::OpenSSH::ObjectRemote') or return;
2507 0         0 my $connector = Net::OpenSSH::ObjectRemote->new(net_openssh => $self);
2508 0         0 $connector->connect(@_);
2509             }
2510              
2511             sub any {
2512 0     0 1 0 my $self = shift;
2513 0         0 _load_module('Net::SSH::Any');
2514             Net::SSH::Any->new($self->{_host}, user => $self->{_user}, port => $self->{_port},
2515 0         0 backend => 'Net_OpenSSH',
2516             backend_opts => { Net_OpenSSH => { instance => $self } });
2517             }
2518              
2519             sub DESTROY {
2520 1     1   2577 my $self = shift;
2521 1 50 33     6 $debug and $debug & 2 and _debug("DESTROY($self, pid: ", $self->{_pid}, ")");
2522 1         24 local ($SIG{__DIE__}, $@, $?, $!);
2523 1         4 $self->_disconnect;
2524             }
2525              
2526             1;
2527             __END__