File Coverage

blib/lib/Test/SSH/Backend/Base.pm
Criterion Covered Total %
statement 119 311 38.2
branch 30 168 17.8
condition 4 20 20.0
subroutine 23 36 63.8
pod 0 5 0.0
total 176 540 32.5


line stmt bran cond sub pod time code
1             package Test::SSH::Backend::Base;
2            
3 1     1   3 use strict;
  1         0  
  1         22  
4 1     1   2 use warnings;
  1         2  
  1         18  
5 1     1   3 use File::Spec;
  1         0  
  1         17  
6 1     1   3 use File::Glob qw(:glob);
  1         1  
  1         141  
7 1     1   4 use Carp;
  1         1  
  1         43  
8 1     1   444 use POSIX;
  1         4733  
  1         4  
9 1     1   2367 use FileHandle;
  1         7414  
  1         5  
10            
11 1     1   648 use Test::SSH::Patch::URI::ssh;
  1         3  
  1         55  
12            
13             my @private = qw(timeout logger test_commands path user_keys private_dir requested_uri run_server c_params);
14             my @public = qw(host port auth_method password user key_path);
15             for my $accessor (@public) {
16 1     1   7 no strict 'refs';
  1         1  
  1         2630  
17 0     0   0 *$accessor = sub { shift->{$accessor} }
18             }
19            
20             sub new {
21 4     4 0 11 my ($class, %opts) = @_;
22            
23 4         5 my $sshd = {};
24 4         6 bless $sshd, $class;
25 4         57 $sshd->{$_} = delete($opts{$_}) for (@public, @private);
26            
27 4 50       14 if (defined (my $uri_txt = $sshd->{requested_uri})) {
28 0         0 my $uri = URI->new($uri_txt);
29 0 0       0 $uri->scheme('ssh') unless defined $uri->scheme;
30 0 0       0 if ($uri->scheme ne 'ssh') {
31 0         0 $sshd->_error("not a ssh URI '$uri'");
32 0         0 return;
33             }
34            
35 0         0 for my $k (qw(password host port user c_params)) {
36 0         0 my $v = $uri->$k;
37 0 0       0 $sshd->{$k} = $v if defined $v;
38             }
39            
40 0 0       0 for (@{$opts{c_params} || []}) {
  0         0  
41 0 0       0 if (/^key_path=(.*)$/) {
42 0         0 $sshd->{user_keys} = [$1];
43             }
44             }
45             }
46            
47 4         11 $sshd->_write_fh('log'); # opens log file
48 4         11 $sshd->_log("starting backend of class '$class'");
49            
50 4         483 return $sshd;
51             }
52            
53             sub _log {
54 31     31   225 local ($@, $!, $?, $^E);
55 31         29 my $sshd = shift;
56 31         53 my $line = join(': ', @_);
57 31 100       62 if (defined (my $fhs = $sshd->{log_fhs})) {
58 22         16 print {$fhs->[1]} "# Test::SSH > $line\n"
  22         73  
59             }
60 31         38 eval { $sshd->{logger}->($line) }
  31         68  
61             }
62            
63 2     2   4 sub _error { shift->_log(error => @_) }
64            
65             my $dev_null = File::Spec->devnull;
66 0     0   0 sub _dev_null { $dev_null }
67            
68             my $up_dir = File::Spec->updir;
69             my $cur_dir = File::Spec->curdir;
70            
71 0     0   0 sub _is_server_running { defined(shift->server_version) }
72            
73             sub _run_remote_cmd {
74 0     0   0 my ($sshd, @cmd) = @_;
75            
76 0 0       0 if ($sshd->_is_server_running) {
77 0         0 my $auth_method = $sshd->{auth_method};
78 0         0 my (@auth_args, @auth_opts);
79 0 0       0 if ($auth_method eq 'publickey') {
    0          
80             @auth_args = ( -i => $sshd->{key_path},
81 0         0 -o => 'PreferredAuthentications=publickey',
82             -o => 'BatchMode=yes' );
83             }
84             elsif ($auth_method eq 'password') {
85 0         0 @auth_args = ( -o => 'PreferredAuthentications=password,keyboard-interactive',
86             -o => 'BatchMode=no' );
87 0         0 @auth_opts = ( password => $sshd->{password} );
88             }
89             else {
90 0         0 $sshd->_error("unsupported authentication method $auth_method");
91 0         0 return;
92             }
93            
94             return $sshd->_run_cmd( { search_binary => 1, @auth_opts },
95             'ssh',
96             '-T',
97             -F => $dev_null,
98             -p => $sshd->{port},
99             -l => $sshd->{user},
100             -o => 'StrictHostKeyChecking=no',
101             -o => "UserKnownHostsFile=$dev_null",
102             @auth_args,
103             '--',
104             $sshd->{host},
105 0         0 @cmd );
106             }
107             }
108            
109             sub _find_binaries {
110 2     2   3 my ($sshd, @cmds) = @_;
111 2         7 $sshd->_log("resolving command(s) @cmds");
112 2         212 my @path = @{$sshd->{path}};
  2         11  
113            
114 2 50       6 if (defined $sshd->{_ssh_executable}) {
115 0         0 my $dir = File::Spec->join((File::Spec->splitpath($sshd->{_ssh_executable}))[0,1]);
116 0         0 unshift @path, $dir, File::Spec->join($dir, $up_dir, 'sbin');
117             }
118            
119 2         1 my @bins;
120 2         9 $sshd->_log("search path is " . join(":", @path));
121 2         195 for my $path (@path) {
122 24         20 for my $cmd (@cmds) {
123 24         116 my $fn = File::Spec->join($path, $cmd);
124 24 50       256 if (-f $fn) {
125 0         0 $sshd->_log("candidate found at $fn");
126 0 0       0 unless (-x $fn) {
127 0         0 $sshd->_log("file $fn is not executable");
128 0         0 next;
129             }
130 0 0       0 unless (-B $fn) {
131 0         0 $sshd->_log("file $fn looks like a wrapper, ignoring it");
132 0         0 next;
133             }
134 0 0       0 return $fn unless wantarray;
135 0         0 push @bins, $fn;
136             }
137             }
138             }
139 2         6 return @bins;
140             }
141            
142             sub _find_executable {
143 2     2   3 my ($sshd, $cmd, $version_flags, $min_version) = @_;
144 2         4 my $slot = "${cmd}_executable";
145 2 50       5 defined $sshd->{$slot} and return $sshd->{$slot};
146 2 50       5 if (defined $version_flags) {
147 2         7 for my $bin ($sshd->_find_binaries($cmd)) {
148 0         0 $sshd->_log("checking version of '$bin'");
149 0         0 my $out = $sshd->_capture_cmd( $bin, $version_flags );
150 0 0       0 if (defined $out) {
151 0 0       0 if (my ($ver, $mayor) = $out =~ /^(OpenSSH[_\-](\d+)\.\d+(?:\.\d+)?(?:p\d+))/m) {
152 0 0 0     0 if (!defined($min_version) or $mayor >= $min_version) {
153 0         0 $sshd->_log("executable version is $ver, selecting it!");
154 0         0 $sshd->{$slot} = $bin;
155 0         0 last;
156             }
157             else {
158 0         0 $sshd->_log("executable is too old ($ver), $min_version.x required");
159 0         0 next;
160             }
161             }
162             }
163 0         0 $sshd->_log("command failed");
164             }
165             }
166             else {
167 0         0 $sshd->{$slot} = $sshd->_find_binaries($cmd)
168             }
169 2 50       9 if (defined (my $bin = $sshd->{$slot})) {
170 0         0 $sshd->_log("command '$cmd' resolved as '$sshd->{$slot}'");
171 0         0 return $bin;
172             }
173             else {
174 2         9 $sshd->_error("no executable found for command '$cmd'");
175 2         242 return;
176             }
177             }
178            
179 0     0   0 sub _ssh_executable { shift->_find_executable('ssh', '-V', 5) }
180            
181             sub _mkdir {
182 32     32   29 my ($sshd, $dir) = @_;
183 32 50       52 if (defined $dir) {
184 32 100       472 -d $dir and return 1;
185 15 50 33     860 if (mkdir($dir, 0700) and -d $dir) {
186 15         50 $sshd->_log("directory '$dir' created");
187 15         1983 return 1;
188             }
189 0         0 $sshd->_error("unable to create directory '$dir'", $!);
190             }
191 0         0 return;
192             }
193            
194             sub _private_dir {
195 8     8   10 my ($sshd, $subdir) = @_;
196 8         4 my $slot = "private_dir";
197 8         10 my $pdir = $sshd->{$slot};
198 8 50       22 $sshd->_mkdir($pdir) or return;
199            
200 8 50       14 if (defined $subdir) {
201 8         22 for my $sd (split /\//, $subdir) {
202 28         32 $slot .= "/$sd";
203 28 100       43 if (defined $sshd->{$slot}) {
204 4         8 $pdir = $sshd->{$slot};
205             }
206             else {
207 24         227 $pdir = File::Spec->join($pdir, $sd);
208 24 50       41 $sshd->_mkdir($pdir) or return;
209 24         72 $sshd->{$slot} = $pdir;
210             }
211             }
212             }
213 8         28 return $pdir;
214             }
215            
216             sub _backend_dir {
217 8     8   9 my ($sshd, $subdir) = @_;
218 8 50       15 my $class = (ref $sshd ? ref $sshd : $sshd);
219 8 50       57 if (my ($be) = $class =~ /\b(\w+)$/) {
220 8         26 return $sshd->_private_dir(lc($be) . '/' . $subdir);
221             }
222 0         0 $sshd->_error("unable to infer backend name!");
223             return
224 0         0 }
225            
226             sub _run_dir {
227 10     10   11 my $sshd = shift;
228 10 100       18 unless (defined $sshd->{run_dir}) {
229 4         17 $sshd->{run_dir} = $sshd->_backend_dir("run/$$");
230             # $sshd->_log(run_dir => $sshd->{run_dir});
231             }
232             $sshd->{run_dir}
233 10         63 }
234            
235 4     4   7 sub _run_dir_last { shift->_backend_dir('openssh/run/last') }
236            
237             sub _fh {
238 4     4   5 my ($sshd, $name, $write) = @_;
239 4         5 my $slot = "${name}_fhs";
240 4 50       9 unless (defined $sshd->{$slot}) {
241 4         11 my $fn = File::Spec->join($sshd->_run_dir, "$name.out");
242 4         7 my ($rfh, $wfh);
243 4 50       229 unless (open $wfh, '>>', $fn) {
244 0         0 $sshd->_log("unable to open file '$fn' for writting");
245 0         0 return;
246             }
247 4 50       79 unless (open $rfh, '<', $fn) {
248 0         0 $sshd->_log("unable to open file '$fn' for writting");
249 0         0 return;
250             };
251 4         23 $rfh->autoflush(1);
252 4         151 $sshd->{$slot} = [$rfh, $wfh];
253             }
254 4 50       13 $sshd->{$slot}[$write ? 1 : 0];
255             }
256            
257            
258             sub _read_fh {
259 0     0   0 my ($sshd, $name) = @_;
260 0         0 $sshd->_fh($name, 0);
261             }
262            
263             sub _write_fh {
264 4     4   4 my ($sshd, $name) = @_;
265 4         11 $sshd->_fh($name, 1);
266             }
267            
268             sub _run_cmd {
269 0     0   0 my $sshd = shift;
270 0 0       0 my %opts = (ref $_[0] ? %{shift()} : ());
  0         0  
271 0         0 my @cmd = @_;
272            
273 0         0 $sshd->_log("running command '@cmd'");
274            
275 0         0 delete @{$sshd}{qw(cmd_output_offset cmd_output_name)};
  0         0  
276            
277 0 0       0 if (delete $opts{search_binary}) {
278 0 0 0     0 if (my $method = ($sshd->can("$cmd[0]_executable") or $sshd->can("_$cmd[0]_executable"))) {
279 0         0 $cmd[0] = $sshd->$method;
280 0 0       0 defined $cmd[0] or return;
281             }
282             }
283            
284 0         0 my $password = delete $opts{password};
285            
286 0   0     0 my $out_fn = delete $opts{out_name} || 'client';
287 0 0       0 my $out_fh = $sshd->_write_fh($out_fn) or return;
288 0         0 print $out_fh "=" x 80, "\ncmd: @cmd\n", "-" x 80, "\n";
289 0         0 $sshd->{cmd_output_offset} = tell $out_fh;
290 0         0 $sshd->{cmd_output_name} = $out_fn;
291            
292 0 0       0 if ($^O =~ /^MSWin/) {
293 0 0       0 if (defined $password) {
294 0         0 $sshd->_error('running commands with a password is not supported on windows');
295 0         0 return;
296             }
297 0         0 local $@;
298 0         0 my $r = eval {
299 0         0 local (*STDIN, *STDOUT, *STDERR);
300 0 0       0 open STDIN, '<', $dev_null or die $!;
301 0 0       0 open STDOUT, '>>&', $out_fh or die $!;
302 0 0       0 open STDOUT, '>>&', *STDOUT or die $!;
303             ( delete $opts{async}
304 0 0       0 ? ( system 1, @cmd )
305             : ( system(@cmd) == 0 ) )
306             };
307 0 0       0 $@ and $sshd->_log($@);
308 0         0 return $r;
309             }
310             else {
311 0         0 my $pty;
312 0 0       0 if (defined $password) {
313 0 0       0 unless (eval { require IO::Pty; 1 }) {
  0         0  
  0         0  
314 0         0 $sshd->_error("IO::Pty not available");
315 0         0 return;
316             }
317 0         0 $pty = IO::Pty->new;
318             }
319            
320 0         0 my $pid = fork;
321 0 0       0 unless ($pid) {
322 0 0       0 unless (defined $pid) {
323 0         0 $sshd->_log("fork failed", $!);
324 0         0 return;
325             }
326 0         0 eval {
327 0 0       0 $pty->make_slave_controlling_terminal if $pty;
328 0         0 open my $in, '
329 0 0       0 open my $out2, '>>&', $out_fh or die $!;
330 0 0       0 POSIX::dup2(fileno($in), 0) or die $!;
331 0 0       0 POSIX::dup2(fileno($out2), 1) or die $!;
332 0 0       0 POSIX::dup2(1, 2) or die $!;
333 0         0 exec @cmd;
334             };
335 0 0       0 $@ and $sshd->_error($@);
336 0         0 exit(1);
337             }
338 0 0       0 if (delete $opts{async}) {
339 0 0       0 return (wantarray ? ($pid, $pty) : $pid);
340             }
341             else {
342 0         0 local $SIG{PIPE} = 'IGNORE';
343 0         0 my $end = time + $sshd->{timeout};
344 0         0 my $buffer = '';
345 0         0 while (1) {
346 0 0       0 if (time > $end) {
347 0 0       0 kill ((time - $end > 3 ? 'KILL' : 'TERM'), $pid);
348             }
349 0 0       0 if (waitpid($pid, POSIX::WNOHANG()) > 0) {
350 0 0       0 if ($?) {
351 0         0 $sshd->_log("program failed, rc: $?");
352             return
353 0         0 }
354 0         0 return 1;
355             }
356 0 0       0 if ($pty) {
357 0         0 my $rv = '';
358 0         0 vec($rv, fileno($pty), 1) = 1;
359 0 0       0 if (select($rv, undef, undef, 0) > 0) {
360 0         0 sysread($pty, $buffer, 1024, length($buffer));
361 0 0       0 if ($buffer =~ s/.*[>:?]\s*$//s) {
362 0         0 print $pty "$password\n";
363             }
364             }
365             }
366 0         0 select(undef, undef, undef, 0.3);
367             }
368             }
369             }
370             }
371            
372             sub _capture_cmd {
373 0     0   0 my $sshd = shift;
374 0         0 $sshd->_run_cmd(@_);
375 0         0 my $name = $sshd->{cmd_output_name};
376 0 0       0 return unless defined $name;
377 0         0 my $fh = $sshd->_read_fh($name);
378 0         0 my $off = $sshd->{cmd_output_offset};
379 0         0 seek($fh, $off, 0);
380 0         0 do { local $/; <$fh> };
  0         0  
  0         0  
381             }
382            
383             sub _test_server {
384 0     0   0 my $sshd = shift;
385 0         0 for my $cmd (@{$sshd->{test_commands}}) {
  0         0  
386 0 0 0     0 if (defined $sshd->{requested_uri} or $sshd->_run_cmd($cmd)) {
387 0 0       0 if ($sshd->_run_remote_cmd($cmd)) {
388 0         0 $sshd->_log("connection ok");
389 0         0 return 1;
390             }
391             }
392             }
393             ()
394 0         0 }
395            
396             sub uri {
397 0     0 0 0 my ($sshd, %opts) = @_;
398 0         0 my $auth_method = $sshd->{auth_method};
399 0         0 my $uri = URI->new;
400 0         0 $uri->scheme('ssh');
401 0         0 $uri->user($sshd->{user});
402 0         0 $uri->host($sshd->{host});
403 0         0 $uri->port($sshd->{port});
404 0 0       0 if ($auth_method eq 'password') {
    0          
405 0 0       0 $uri->password($opts{hidden_password} ? '*****' : $sshd->{password});
406             }
407             elsif ($auth_method eq 'publickey') {
408 0         0 $uri->c_params(["key_path=$sshd->{key_path}"]);
409             }
410 0         0 $uri;
411             }
412            
413             sub connection_params {
414 0     0 0 0 my $sshd = shift;
415 0 0       0 if (wantarray) {
416 0         0 my @keys = qw(host port user);
417 0 0       0 push @keys, ($sshd->{auth_method} eq 'password' ? 'password' : 'key_path');
418 0         0 return map { $_ => $sshd->$_ } @keys;
  0         0  
419             }
420             else {
421 0         0 return $sshd->uri;
422             }
423             }
424            
425            
426            
427             sub server_version {
428 0     0 0 0 my $sshd = shift;
429 0 0       0 unless (defined $sshd->{server_version}) {
430 0         0 $sshd->_log("retrieving server version");
431 0         0 require IO::Socket::INET;
432 0         0 my $end = time + $sshd->{timeout};
433 0         0 my $buffer = '';
434 0 0       0 if (my $socket = IO::Socket::INET->new(PeerAddr => $sshd->{host},
435             PeerPort => $sshd->{port},
436             Timeout => $sshd->{timeout},
437             Proto => 'tcp',
438             Blocking => 0)) {
439 0   0     0 while (time <= $end and $buffer !~ /\n/) {
440 0         0 my $rv = '';
441 0         0 vec($rv, fileno($socket), 1) = 1;
442 0 0       0 if (select($rv, undef, undef, 1) > 0) {
443 0 0       0 sysread($socket, $buffer, 1024, length($buffer)) or last;
444             }
445             }
446 0 0       0 if ($buffer =~ /^(.*)\n/) {
447 0         0 $sshd->{server_version} = $1;
448             }
449             else {
450 0         0 $sshd->_log("unable to retrieve server version");
451             }
452             }
453             else {
454 0         0 $sshd->_log("unable to connect to server", $!);
455             }
456             }
457             $sshd->{server_version}
458 0         0 }
459            
460             sub server_os {
461 0     0 0 0 my $sshd = shift;
462 0 0       0 unless (defined $sshd->{server_os}) {
463 0         0 $sshd->_log("retrieving server operating system info");
464             }
465             }
466            
467             sub _rmdir {
468 4     4   5 my ($sshd, $dir) = @_;
469 4 50       90 if (opendir my $dh, $dir) {
470 4         77 while (defined (my $entry = readdir $dh)) {
471 12 100 100     57 next if $entry eq $up_dir or $entry eq $cur_dir;
472 4         171 unlink File::Spec->join($dir, $entry);
473             }
474 4         23 closedir $dh;
475             }
476 4         41 unlink $dir;
477             }
478            
479             sub DESTROY {
480 4     4   6 my $sshd = shift;
481 4         19 local ($@, $!, $?, $^E);
482 4         3 eval {
483 4 50       8 if (defined (my $run_dir = $sshd->_run_dir)) {
484 4 50       11 if (defined (my $last = $sshd->_run_dir_last)) {
485 4         14 $sshd->_rmdir($run_dir);
486 4         340 rename $sshd->{run_dir}, $last;
487 4         19 $sshd->_log("SSH server logs moved to '$last'");
488             }
489             }
490             };
491             }
492            
493             1;