diff options
| -rw-r--r-- | Changes | 37 | ||||
| -rw-r--r-- | META.json | 4 | ||||
| -rw-r--r-- | META.yml | 6 | ||||
| -rw-r--r-- | lib/Net/OpenSSH.pm | 165 | ||||
| -rw-r--r-- | t/quoting.t | 50 |
5 files changed, 200 insertions, 62 deletions
@@ -1,5 +1,36 @@ Revision history for Perl extension Net::OpenSSH. +0.73 Jun 10, 2016 + - Some old perl versions doesn't like Errno constant subs + being called without parents. Add them. + +0.72 Jun 9, 2016 + - Rerelease as stable. + +0.71_03 Mar 16, 2016 + - Improve shell detection code. + - Use a timeout to kill external commands not returning + control. + - improve ksh version checking in tests (bug report by jtzako + via PerlMonks) + +0.71_02 Mar 11, 2016 + - Lighten master socket checks in async mode in order to avoid + blocking and setting custom signal handlers which can + interfere with event-programming frameworks (bug report by + Doug Hoyte). + +0.71_01 Jan 20, 2016 + - Add entry on the documentation about how to integrate the + module with event-oriented programming frameworks (bug + report by Doug Hoyte, #gh17) + - Use an adaptative delaying algorithm while waiting for the + multiplexing socket to pop up (bug report by Doug Hoyte, + #gh17). + - Improve SIGCHLD handling and interoperability with other + modules setting custom handlers (bug report by Doug Hoyte, + #gh16). + 0.70 Jan 20, 2016 - Re-release as stable. @@ -667,16 +698,16 @@ Revision history for Perl extension Net::OpenSSH. - use correct ps args when testing on Solaris - new mux_socket_path method - more tests - + 0.09 Dec 10, 2008 - fallback testing method when ssh'ing to localhost is not enabled - add support for master_opts constructor argument - + 0.08 Dec 10, 2008 - require 5.8.x and remove compatibility hacks for older versions - solve bug in open_ex when pty is requested - perform sanity checks on child file handles on open_ex - + 0.07 Dec 9, 2008 - remove >>& incompatibility for perl 5.6.x - in tests, sort "ls" output, as it seems that it can change @@ -4,7 +4,7 @@ "Salvador Fandino <sfandino@yahoo.com>" ], "dynamic_config" : 1, - "generated_by" : "ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005", + "generated_by" : "ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005", "license" : [ "perl_5" ], @@ -42,6 +42,6 @@ "url" : "https://github.com/salva/p5-Net-OpenSSH" } }, - "version" : "0.70", + "version" : "0.73", "x_serialization_backend" : "JSON::PP version 2.27300" } @@ -7,7 +7,7 @@ build_requires: configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 -generated_by: 'ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005' +generated_by: 'ExtUtils::MakeMaker version 7.0401, CPAN::Meta::Converter version 2.150005' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -21,5 +21,5 @@ requires: Test::More: '0' resources: repository: https://github.com/salva/p5-Net-OpenSSH -version: '0.70' -x_serialization_backend: 'CPAN::Meta::YAML version 0.012' +version: '0.73' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff --git a/lib/Net/OpenSSH.pm b/lib/Net/OpenSSH.pm index 872ec5e..60c5b54 100644 --- a/lib/Net/OpenSSH.pm +++ b/lib/Net/OpenSSH.pm @@ -1,6 +1,6 @@ package Net::OpenSSH; -our $VERSION = '0.70'; +our $VERSION = '0.73'; use strict; use warnings; @@ -654,6 +654,11 @@ sub _master_gone { my @kill_signal = qw(0 0 TERM TERM TERM KILL); +sub __has_sigchld_handle { + my $h = $SIG{CHLD}; + defined $h and $h ne 'IGNORE' and $h ne 'DEFAULT' +} + sub _master_kill { my ($self, $async) = @_; @@ -665,7 +670,7 @@ sub _master_kill { $self->{_master_kill_last} ||= $now; $self->{_master_kill_count} ||= 0; - local $SIG{CHLD} = sub {} unless $async; + local $SIG{CHLD} = sub {} unless $async or __has_sigchld_handle; while (1) { if ($self->{_master_kill_last} < $now) { $self->{_master_kill_last} = $now; @@ -776,7 +781,7 @@ sub _waitpid { $timeout = 0 if $self->error == OSSH_SLAVE_TIMEOUT; $time_limit = time + $timeout; } - local $SIG{CHLD} = sub {}; + local $SIG{CHLD} = sub {} unless __has_sigchld_handle; while (1) { my $deceased; if (defined $time_limit) { @@ -817,7 +822,7 @@ sub _waitpid { elsif ($deceased < 0) { # at this point $deceased < 0 and so, $! has a valid error value. next if $! == Errno::EINTR(); - if ($! == Errno::ECHILD) { + if ($! == Errno::ECHILD()) { $self->_or_set_error(OSSH_SLAVE_FAILED, "child process $pid does not exist", $!); return undef } @@ -918,7 +923,6 @@ sub _master_start { my @call = $self->_make_ssh_call(\@master_opts); - local $SIG{CHLD}; my $pid = fork; unless ($pid) { defined $pid @@ -949,18 +953,25 @@ sub _master_start { sub _master_check { my ($self, $async) = @_; - my $out = $self->_master_ctl('check'); - my $error = $self->{_error}; - unless ($error) { - my $pid = $self->{_pid}; - if ($out =~ /pid=(\d+)/) { - return 1 if !$pid or $1 == $pid; - $error = "bad ssh master at $self->{_ctl_path} socket owned by pid $1 (pid $pid expected)"; - } - else { - $error = ($out =~ /illegal option/i - ? 'OpenSSH 4.1 or later required' - : 'unknown error'); + my $error; + if ($async) { + return 1 if -S $self->{_ctl_path}; + $error = "master SSH connection broken"; + } + else { + my $out = $self->_master_ctl('check'); + my $error = $self->{_error}; + unless ($error) { + my $pid = $self->{_pid}; + if ($out =~ /pid=(\d+)/) { + return 1 if !$pid or $1 == $pid; + $error = "bad ssh master at $self->{_ctl_path} socket owned by pid $1 (pid $pid expected)"; + } + else { + $error = ($out =~ /illegal option/i + ? 'OpenSSH 4.1 or later required' + : 'unknown error'); + } } } $self->_master_fail($async, $error); @@ -993,7 +1004,7 @@ sub _master_wait { my $pid = $self->_my_master_pid; if ($pid) { my $deceased = waitpid($pid, WNOHANG); - if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD)) { + if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD())) { $debug and $debug & 4 and _debug "master $pid exited, rc:", $?,", err: ",$!; return $self->_master_gone($async); } @@ -1058,12 +1069,13 @@ sub _master_wait { } my $timeout = $self->{_timeout}; - my $dt = ($async ? 0 : 0.1); + my $dt = ($async ? 0 : 0.02); my $start_time = time; my $error; # Loop until the mux socket appears or something goes wrong: while (1) { + $dt *= 1.10 if $dt < 0.2; # adaptative delay if (-e $self->{_ctl_path}) { $debug and $debug & 4 and _debug "file object found at $self->{_ctl_path}"; last; @@ -1076,7 +1088,7 @@ sub _master_wait { } my $deceased = waitpid($pid, WNOHANG); - if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD)) { + if ($deceased == $pid or ($deceased < 0 and $! == Errno::ECHILD())) { $error = "master process exited unexpectedly"; $error = "bad pass" . ($self->{_passphrase} ? 'phrase' : 'word') . " or $error" if defined $self->{_passwd}; @@ -1686,8 +1698,8 @@ sub _decode { $self->_check_eval_ok(OSSH_ENCODING_ERROR); } -my @retriable = (Errno::EINTR, Errno::EAGAIN); -push @retriable, Errno::EWOULDBLOCK if Errno::EWOULDBLOCK != Errno::EAGAIN; +my @retriable = (Errno::EINTR(), Errno::EAGAIN()); +push @retriable, Errno::EWOULDBLOCK() if Errno::EWOULDBLOCK() != Errno::EAGAIN(); sub _io3 { my ($self, $out, $err, $in, $stdin_data, $timeout, $encoding) = @_; @@ -3683,6 +3695,18 @@ If your program rips the master process and this method is not called, the OS could reassign the PID to a new unrelated process and the module would try to kill it at object destruction time. +=item $ssh->disconnect($async) + +Shuts down the SSH connection. + +Usually, you don't need to call this method explicitly, but just let +the Net::OpenSSH object go out of scope. + +If C<async> is true, it doesn't wait for the SSH connection to +terminate. In that case, L</wait_for_master> must be called repeatedly +until the shutdown sequence terminates (See the L</AnyEvent> +integration section bellow). + =item $pid = $ssh->sshfs_import(\%opts, $remote_fs, $local_mnt_point) =item $pid = $ssh->sshfs_export(\%opts, $local_fs, $remote_mnt_point) @@ -4154,6 +4178,86 @@ See L<method C<any>|/Net_SSH_Any>. See L<method C<object_remote>|/Object_Remote>. +=head2 AnyEvent (and similar frameworks) + +X<AnyEvent>Net::OpenSSH provides all the functionality required to be +integrated inside event oriented programming framework such as +L<AnyEvent> or L<IO::Async> in the following way: + +=over 4 + +=item 1. Create a disconnected Net::OpenSSH object: + + my $ssh = Net::OpenSSH->new($host, async => 1, ...); + +=item 2. Let the object connect to the remote host: + +Use a timer to call the C<wait_for_master> method in async mode +repeatedly until it returns a true value indicating success. + +Also, the object error state needs to be checked after every call in +order to detect failed connections. For instance: + + my $ssh = Net::OpenSSH->new(..., async => 1); + my $w; + $w = AE::timer 0.1, 0.1, sub { + if ($ssh->wait_for_master(1)) { + # the connection has been established! + # remote commands can be run now + undef $w; + on_ssh_success(...); + } + elsif ($ssh->error) { + # connection can not be established + undef $w; + on_ssh_failure(...); + } + } + +=item 3. Use the event framework to launch the remote processes: + +Call Net::OpenSSH C<make_remote_command> to construct commands which +can be run using the framework regular facilities for launching external +commands. + +Error checking should also be performed at this point because the SSH +connection could be broken. + +For instance: + + if (defined(my $cmd = $ssh->make_remote_command(echo => 'hello!')) { + AnyEvent::Util::run_cmd($cmd, %run_cmd_opts); + } + else { + # something went wrong! + } + +Alternatively, any of the C<open*> methods provided by Net::OpenSSH +could also be used to launch remote commands. + +=item 4. When finished, disconnect asynchronously + +After initiating an asynchronous disconnect with C<disconnect(1)>, +repeatedly call C<wait_for_master> until you get a defined but false +value: + + $ssh->disconnect(1); + + my $w; $w = AE::timer 0.1, 0.1, sub { + my $res = $ssh->wait_for_master(1); + + if (defined $res && !$res) { + undef $w; + undef $ssh; + } + }; + +Be careful not to let the C<$ssh> object go out of scope until the +disconnection has finished, otherwise its destructor will wait and +block your program until the disconnection has completed. + +=back + =head2 Other modules CPAN contains several modules that rely on SSH to perform their duties @@ -4523,8 +4627,8 @@ B<A>: Roughly, the SSH protocol allows for two modes of operation: command mode and interactive mode. Command mode is designed to run single commands on the remote host. It -opens an SSH channel between both hosts, ask the remote computer to -run some given command and when it finish the channel is closed. It +opens a SSH channel between both hosts, asks the remote computer to +run some given command and when it finishes, the channel is closed. It is what you get, for instance, when you run something as... $ ssh my.unix.box cat foo.txt @@ -4586,19 +4690,6 @@ If you want to use it anyway, past it to the constructor: master_opts => [-o => "StrictHostKeyChecking=no"], ...); - -=item child process 14947 does not exist: No child processes - -B<Q>: Calls to C<system>, C<capture> or C<capture2> fail with the -previous error, what I am doing wrong? - -B<A>: That usually happens when C<$SIG{CHLD}> is set to C<IGNORE> or -to some custom handler reaping child processes by itself. In order to -solve the problem just disable the handler during the method call: - - local $SIG{CHLD}; - $ssh->system($cmd); - =item child process STDIN/STDOUT/STDERR is not a real system file handle diff --git a/t/quoting.t b/t/quoting.t index 40bbed9..09ac46e 100644 --- a/t/quoting.t +++ b/t/quoting.t @@ -67,34 +67,50 @@ for my $shell (@shells) { } } +our $child_pid; sub capture { no warnings 'io'; - open my $fh, '-|', @_ or die "unable to exec @_"; + my $pid = open my $fh, '-|', @_ or die "unable to exec @_"; local $/; - my $out = <$fh>; + my $out = do { + local $child_pid = $pid; + <$fh> + }; close $fh; $out; } sub try_shell { my $shell = shift; - my $out = eval { capture($shell, '-c', 'echo good') }; - if ($out and $out =~ /^good$/) { - if ($shell =~ /ksh/) { - if (defined (my $version = eval { `$shell --version 2>&1` })) { - if ($version =~ /version\s+sh\s+\(AT\&T\s+Research\)/) { - diag "skipping tests for broken AT&T ksh shell!"; - return undef; - } + my $ok; + local $SIG{ALRM} = sub { + kill KILL => $child_pid if $child_pid; + die "timeout while waiting for shell $shell" + }; + eval { + eval { + no warnings 'uninitialized'; + alarm 10; + my $out = capture($shell, '-c', 'echo good'); + $out =~ /^good$/ or die "shell $shell not found"; + if ($shell =~ /ksh/) { + my $version = `$shell --version 2>&1 </dev/null`; + $version =~ /version\s+sh\s+\(AT\&T\s+Research\)/ + and die "skipping tests for broken AT&T ksh shell"; } - } - if ($shell eq '!!fish') { - diag "TODO: add support for fish shell!"; - return undef; - } - return 1; + else { + $shell eq '!!fish' and die "TODO: add support for fish shell"; + } + }; + alarm 0; + die $@ if $@; + $ok = 1; + }; + if ($@) { + $@ =~ s/ at .*//m; + diag $@; } - return undef; + $ok; } my $badfh; |