diff options
Diffstat (limited to 'lib')
-rw-r--r-- | lib/Net/OpenSSH.pm | 795 | ||||
-rw-r--r-- | lib/Net/OpenSSH/ModuleLoader.pm | 35 | ||||
-rw-r--r-- | lib/Net/OpenSSH/OSTracer.pm | 24 | ||||
-rw-r--r-- | lib/Net/OpenSSH/SSH.pm | 19 | ||||
-rw-r--r-- | lib/Net/OpenSSH/ShellQuoter.pm | 36 | ||||
-rw-r--r-- | lib/Net/OpenSSH/ShellQuoter/Chain.pm | 38 | ||||
-rw-r--r-- | lib/Net/OpenSSH/ShellQuoter/MSCmd.pm | 69 | ||||
-rw-r--r-- | lib/Net/OpenSSH/ShellQuoter/MSWin.pm | 53 | ||||
-rw-r--r-- | lib/Net/OpenSSH/ShellQuoter/POSIX.pm | 66 | ||||
-rw-r--r-- | lib/Net/OpenSSH/ShellQuoter/csh.pm | 70 |
10 files changed, 904 insertions, 301 deletions
diff --git a/lib/Net/OpenSSH.pm b/lib/Net/OpenSSH.pm index 8d7f872..9fc72cb 100644 --- a/lib/Net/OpenSSH.pm +++ b/lib/Net/OpenSSH.pm @@ -1,6 +1,6 @@ package Net::OpenSSH; -our $VERSION = '0.60'; +our $VERSION = '0.62'; use strict; use warnings; @@ -17,14 +17,20 @@ use Cwd (); use Scalar::Util (); use Errno (); use Net::OpenSSH::Constants qw(:error); +use Net::OpenSSH::ModuleLoader; +use Net::OpenSSH::ShellQuoter; my $thread_generation = 0; sub CLONE { $thread_generation++ }; -sub _debug { print STDERR '# ', (map { defined($_) ? $_ : '<undef>' } @_), "\n" } +sub _debug { + local ($!, $@); + print STDERR '# ', (map { defined($_) ? $_ : '<undef>' } @_), "\n" +} sub _debug_dump { + local ($!, $@); require Data::Dumper; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 0; @@ -65,6 +71,14 @@ sub _hexdump { } } +sub _croak_scalar_context { + my ($sub, $wantarray) = (caller 1)[3, 5]; + unless ($wantarray) { + $sub =~ s/^.*:://; + croak "method '$sub' called in scalar context"; + } +} + sub _tcroak { if (${^TAINT} > 0) { push @_, " while running with -T switch"; @@ -214,13 +228,12 @@ sub new { $external_master = delete $opts{reuse_master} unless defined $external_master; if (not defined $opts{host} and defined $external_master) { - $opts{host} = 'UNKNOWN'; + $opts{host} = '0.0.0.0'; } my ($host, $port, $user, $passwd, $host_squared) = $class->parse_connection_opts(\%opts); my ($passphrase, $key_path, $login_handler); - unless (defined $passwd) { $key_path = delete $opts{key_path}; $passwd = delete $opts{passphrase}; @@ -232,6 +245,7 @@ sub new { } } + my $ssh_version = delete $opts{ssh_version}; my $batch_mode = delete $opts{batch_mode}; my $ctl_path = delete $opts{ctl_path}; my $ctl_dir = delete $opts{ctl_dir}; @@ -247,7 +261,7 @@ sub new { my $kill_ssh_on_timeout = delete $opts{kill_ssh_on_timeout}; my $strict_mode = _first_defined delete $opts{strict_mode}, 1; my $async = delete $opts{async}; - my $target_os = _first_defined delete $opts{target_os}, 'unix'; + my $remote_shell = _first_defined delete $opts{remote_shell}, 'POSIX'; my $expand_vars = delete $opts{expand_vars}; my $vars = _first_defined delete $opts{vars}, {}; my $default_encoding = delete $opts{default_encoding}; @@ -258,10 +272,14 @@ sub new { my $forward_agent = delete $opts{forward_agent}; $forward_agent and $passphrase and croak "agent forwarding can not be used when a passphrase has also been given"; + my $forward_X11 = delete $opts{forward_X11}; + my $passwd_prompt = delete $opts{password_prompt}; + $passwd_prompt = delete $opts{passwd_prompt} unless defined $passwd_prompt; my ($master_opts, @master_opts, $master_stdout_fh, $master_stderr_fh, - $master_stdout_discard, $master_stderr_discard); + $master_stdout_discard, $master_stderr_discard, + $master_setpgrp); unless ($external_master) { ($master_stdout_fh = delete $opts{master_stdout_fh} or $master_stdout_discard = delete $opts{master_stdout_discard}); @@ -280,6 +298,11 @@ sub new { @master_opts = $master_opts; } } + $master_setpgrp = delete $opts{master_setpgrp}; + + # when a password/passphrase is given, calling setpgrp is + # useless because the process runs attached to a different tty + undef $master_setpgrp if $login_handler or defined $passwd; } my $default_ssh_opts = delete $opts{default_ssh_opts}; @@ -331,6 +354,7 @@ sub new { _error_prefix => [], _perl_pid => $$, _thread_generation => $thread_generation, + _ssh_version => $ssh_version, _ssh_cmd => $ssh_cmd, _scp_cmd => $scp_cmd, _rsync_cmd => $rsync_cmd, @@ -342,6 +366,7 @@ sub new { _user => $user, _port => $port, _passwd => $obfuscate->($passwd), + _passwd_prompt => $passwd_prompt, _passphrase => $passphrase, _key_path => $key_path, _login_handler => $login_handler, @@ -352,6 +377,7 @@ sub new { _batch_mode => $batch_mode, _home => $home, _forward_agent => $forward_agent, + _forward_X11 => $forward_X11, _external_master => $external_master, _default_ssh_opts => $default_ssh_opts, _default_stdin_fh => $default_stdin_fh, @@ -361,7 +387,8 @@ sub new { _master_stderr_fh => $master_stderr_fh, _master_stdout_discard => $master_stdout_discard, _master_stderr_discard => $master_stderr_discard, - _target_os => $target_os, + _master_setpgrp => $master_setpgrp, + _remote_shell => $remote_shell, _default_stream_encoding => $default_stream_encoding, _default_argument_encoding => $default_argument_encoding, _expand_vars => $expand_vars, @@ -369,6 +396,8 @@ sub new { }; bless $self, $class; + $self->_detect_ssh_version; + # default file handles are opened so late in order to have the # $self object to report errors $self->{_default_stdout_fh} = $self->_open_file('>', $default_stdout_file) @@ -507,6 +536,32 @@ sub _is_secure_path { return 1; } +sub _detect_ssh_version { + my $self = shift; + if (defined $self->{_ssh_version}) { + $debug and $debug & 4 and _debug "ssh version given as $self->{_ssh_version}"; + } + else { + my (undef, $out, undef, $pid) = $self->open_ex({_cmd => 'raw', + _no_master_required => 1, + stdout_pipe => 1, + stdin_discard => 1, + stderr_to_stdout => 1 }, + $self->{_ssh_cmd}, '-V'); + my ($txt) = $self->_io3($out, undef, undef, undef, 10, 'bytes'); + local $self->{_kill_ssh_on_timeout} = 1; + $self->_waitpid($pid, 10); + if (my ($full, $num) = $txt =~ /^OpenSSH_((\d+\.\d+)\S*)/mi) { + $debug and $debug & 4 and _debug "OpenSSH verion is $full"; + $self->{_ssh_version} = $num; + } + else { + $self->{_ssh_version} = 0; + $debug and $debug & 4 and _debug "unable to determine version, '$self->{_ssh_cmd} -V', output:\n$txt" + } + } +} + sub _make_ssh_call { my $self = shift; my @before = @{shift || []}; @@ -642,9 +697,13 @@ sub _connect { $self->_set_error; my $timeout = int((($self->{_timeout} || 90) + 2)/3); + my $ssh_flags= '-2MN'; + $ssh_flags .= ($self->{_forward_agent} ? 'A' : 'a') if defined $self->{_forward_agent}; + $ssh_flags .= ($self->{_forward_X11} ? 'X' : 'x'); my @master_opts = (@{$self->{_master_opts}}, -o => "ServerAliveInterval=$timeout", - '-x2MN'); + ($self->{_ssh_version} >= 5.6 ? (-o => "ControlPersist=no") : ()), + $ssh_flags); my ($mpty, $use_pty, $pref_auths); $use_pty = 1 if defined $self->{_login_handler}; @@ -664,10 +723,6 @@ sub _connect { push @master_opts, -i => $self->{_key_path}; } - if (defined $self->{_forward_agent}) { - push @master_opts, ($self->{_forward_agent} ? '-A' : '-a'); - } - my $proxy_command = $self->{_proxy_command}; my $gateway; @@ -709,11 +764,12 @@ sub _connect { local $SIG{CHLD}; my $pid = fork; - unless (defined $pid) { - $self->_set_error(OSSH_MASTER_FAILED, "unable to fork ssh master: $!"); - return undef; - } unless ($pid) { + unless (defined $pid) { + $self->_set_error(OSSH_MASTER_FAILED, "unable to fork ssh master: $!"); + return undef; + } + if ($debug and $debug & 512) { require Net::OpenSSH::OSTracer; Net::OpenSSH::OSTracer->trace; @@ -727,6 +783,8 @@ sub _connect { delete $ENV{SSH_ASKPASS} if defined $self->{_passwd}; delete $ENV{SSH_AUTH_SOCK} if defined $self->{_passphrase}; + setpgrp if $self->{_master_setpgrp}; + local $SIG{__DIE__}; eval { exec @call }; POSIX::_exit(255); @@ -842,9 +900,9 @@ sub _wait_for_master { if ($reset) { $$bout = ''; - $state = ( (defined $passwd and $pid) ? 'waiting_for_password_prompt' : - (defined $login_handler) ? 'waiting_for_login_handler' : - 'waiting_for_mux_socket' ); + $state = ( (defined $passwd and $pid) ? 'waiting_for_passwd_prompt' : + (defined $login_handler) ? 'waiting_for_login_handler' : + 'waiting_for_mux_socket' ); } my $ctl_path = $self->{_ctl_path}; @@ -854,11 +912,24 @@ sub _wait_for_master { my $fnopty; my $rv = ''; - if ($state eq 'waiting_for_password_prompt') { + if ($state eq 'waiting_for_passwd_prompt') { $fnopty = fileno $mpty; vec($rv, $fnopty, 1) = 1 } + my $old_tcpgrp; + if ($pid and $self->{_master_setpgrp} and not $async and not $self->{_batch_mode}) { + $old_tcpgrp = POSIX::tcgetpgrp(0); + if ($old_tcpgrp > 0) { + # let the master process ask for passwords at the TTY + POSIX::tcsetpgrp(0, $pid); + } + else { + undef $old_tcpgrp; + } + } + + # Loop until the mux socket appears or something goes wrong: local $self->{_error_prefix} = [@{$self->{_error_prefix}}, "unable to establish master SSH connection"]; while (1) { @@ -869,14 +940,24 @@ sub _wait_for_master { unless (-S $ctl_path) { $self->_set_error(OSSH_MASTER_FAILED, "bad ssh master at $ctl_path, object is not a socket"); - $self->_kill_master; - return undef; + goto kill_master_and_fail; } my $check = $self->_master_ctl('check'); if (defined $check) { my $error; if ($check =~ /pid=(\d+)/) { - return 1 if (!$pid or $1 == $pid); + if (!$pid or $1 == $pid) { + if ($self->{_master_setpgrp} and $old_tcpgrp) { + if ($debug and $debug & 4) { + my $pgrp = getpgrp($pid); + my $tcpgrp = POSIX::tcgetpgrp(0); + $debug and _debug "ssh pid: $pid, pgrp: $pgrp \$\$: $$, tcpgrp: $tcpgrp old_tcppgrp: $old_tcpgrp"; + } + local $SIG{TTOU} = 'IGNORE'; + POSIX::tcsetpgrp(0, $old_tcpgrp); + } + return 1; + } $error = "bad ssh master at $ctl_path, socket owned by pid $1 (pid $pid expected)"; } elsif ($check =~ /illegal option/i) { @@ -887,28 +968,32 @@ sub _wait_for_master { } $self->_or_set_error(OSSH_MASTER_FAILED, $error); } - $self->_kill_master; - return undef; + goto kill_master_and_fail; } - $debug and $debug & 4 and _debug "file object not yet found at $ctl_path"; + $debug and $debug & 4 and _debug "file object not yet found at $ctl_path, state: $state"; if ($self->{_perl_pid} != $$ or $self->{_thread_generation} != $thread_generation) { $self->_set_error(OSSH_MASTER_FAILED, "process was forked or threaded before SSH connection had been established"); + # just return, the thread creating the mess should clean it all up! return undef; } + if (!$pid) { + # when using an external master the mux socket must be + # there from the first time $self->_set_error(OSSH_MASTER_FAILED, "socket does not exist"); - return undef; + goto fail; } elsif (waitpid($pid, WNOHANG) == $pid or $! == Errno::ECHILD) { my $error = "master process exited unexpectedly"; $error = "bad pass" . ($self->{_passphrase} ? 'phrase' : 'word') . " or $error" if defined $self->{_passwd}; $self->_set_error(OSSH_MASTER_FAILED, $error); - return undef; + goto fail; # master has already died } + if ($state eq 'waiting_for_login_handler') { local ($@, $SIG{__DIE__}); if (eval { $login_handler->($self, $mpty, $bout) }) { @@ -918,7 +1003,7 @@ sub _wait_for_master { if ($@) { $self->_set_error(OSSH_MASTER_FAILED, "custom login handler failed: $@"); - return undef; + goto kill_master_and_fail; } } else { @@ -929,21 +1014,29 @@ sub _wait_for_master { or die "internal error"; my $read = sysread($mpty, $$bout, 4096, length $$bout); if ($read) { - if ($state eq 'waiting_for_password_prompt') { + my $passwd_prompt = _first_defined $self->{_passwd_prompt}, qr/[:?]/; + $passwd_prompt = quotemeta $passwd_prompt unless ref $passwd_prompt; + + if ($state eq 'waiting_for_passwd_prompt') { if ($$bout =~ /The authenticity of host.*can't be established/si) { $self->_set_error(OSSH_MASTER_FAILED, "the authenticity of the target host can't be established, the remote host " . "public key is probably not present on the '~/.ssh/known_hosts' file"); - $self->_kill_master; - return undef; + goto kill_master_and_fail; } - if ($$bout =~ s/^(.*:)//s) { + + if ($$bout =~ /^(.*$passwd_prompt)/s) { $debug and $debug & 4 and _debug "passwd/passphrase requested ($1)"; print $mpty "$passwd\n"; + $$bout = ''; # reset $state = 'waiting_for_mux_socket'; } } - else { $$bout = '' } + elsif (length($passwd_prompt) and $$bout =~ /^(.*$passwd_prompt)\s*$/s) { + $debug and $debug & 4 and _debug "passwd/passphrase requested again ($1)"; + $self->_set_error(OSSH_MASTER_FAILED, "password authentication failed"); + goto kill_master_and_fail; + } next; } } @@ -957,8 +1050,21 @@ sub _wait_for_master { } } $self->_set_error(OSSH_MASTER_FAILED, "login timeout"); + + kill_master_and_fail: $self->_kill_master; - undef; + + fail: + if ($pid and $self->{_master_setpgrp} and $old_tcpgrp) { + if ($debug and $debug & 4) { + my $pgrp = getpgrp($pid); + my $tcpgrp = POSIX::tcgetpgrp(0); + $debug and _debug "ssh pid: $pid, pgrp: $pgrp \$\$: $$, tcpgrp: $tcpgrp old_tcppgrp: $old_tcpgrp"; + } + local $SIG{TTOU} = 'IGNORE'; + POSIX::tcsetpgrp(0, $old_tcpgrp); + } + return undef; } sub _master_ctl { @@ -1008,74 +1114,12 @@ sub _make_pipe { return; } -my %loaded_module; -sub _load_module { - my ($module, $version) = @_; - $loaded_module{$module} ||= do { - do { - local ($@, $SIG{__DIE__}); - eval "require $module; 1" - } or croak "unable to load Perl module $module"; - 1 - }; - if (defined $version) { - local ($@, $SIG{__DIE__}); - my $mv = eval "\$${module}::VERSION" || 0; - (my $mv1 = $mv) =~ s/_\d*$//; - croak "$module version $version required, $mv is available" - if $mv1 < $version; - } - 1 -} - -my $noquote_class = '.\\w/\\-@,:'; -my $glob_class = '*?\\[\\],{}:!^~'; - -sub _arg_quoter { - sub { - my $quoted = join '', - map { ( m|^'$| ? "\\'" : - m|^[$noquote_class]*$|o ? $_ : - "'$_'" ) } split /(')/, $_[0]; - length $quoted ? $quoted : "''"; - } -} - -sub _arg_quoter_glob { - sub { - my $arg = shift; - my @parts; - while ((pos $arg ||0) < length $arg) { - if ($arg =~ m|\G'|gc) { - push @parts, "\\'"; - } - elsif ($arg =~ m|\G([$noquote_class$glob_class]+)|gco) { - push @parts, $1; - } - elsif ($arg =~ m|\G(\\[$glob_class\\])|gco) { - push @parts, $1; - } - elsif ($arg =~ m|\G\\|gc) { - push @parts, '\\\\' - } - elsif ($arg =~ m|\G([^$glob_class\\']+)|gco) { - push @parts, "'$1'"; - } - else { - require Data::Dumper; - $arg =~ m|\G(.+)|gc; - die "Internal error: unquotable string:\n". Data::Dumper::Dumper($1) ."\n"; - } - } - my $quoted = join('', @parts); - length $quoted ? $quoted : "''"; - - # my $arg = shift; - # return $arg if $arg =~ m|^[\w/\-+=?\[\],{}\@!.^~]+$|; - # return "''" if $arg eq ''; - # $arg =~ s|(?<!\\)([^\w/\-+=*?\[\],{}:\@!.^\\~])|ord($1) > 127 ? $1 : $1 eq "\n" ? "'\n'" : "\\$1"|ge; - # $arg; +sub _remote_quoter { + my ($self, $remote_shell) = @_; + if (ref $self and not defined $remote_shell) { + return $self->{remote_quoter} ||= Net::OpenSSH::ShellQuoter->quoter($self->{_remote_shell}); } + Net::OpenSSH::ShellQuoter->quoter($remote_shell); } sub _quote_args { @@ -1088,11 +1132,9 @@ sub _quote_args { $quote = (@_ > 1) unless defined $quote; if ($quote) { - my $quoter_glob = $self->_arg_quoter_glob; - my $quoter = ($glob_quoting - ? $quoter_glob - : $self->_arg_quoter); - + my $remote_shell = delete $opts->{remote_shell}; + my $quoter = $self->_remote_quoter($remote_shell); + my $quote_method = ($glob_quoting ? 'quote_glob' : 'quote'); # foo => $quoter # \foo => $quoter_glob # \\foo => no quoting at all and disable extended quoting as it is not safe @@ -1100,7 +1142,7 @@ sub _quote_args { for (@_) { if (ref $_) { if (ref $_ eq 'SCALAR') { - push @quoted, $quoter_glob->($self->_expand_vars($$_)); + push @quoted, $quoter->quote_glob($self->_expand_vars($$_)); } elsif (ref $_ eq 'REF' and ref $$_ eq 'SCALAR') { push @quoted, $self->_expand_vars($$$_); @@ -1111,19 +1153,22 @@ sub _quote_args { } } else { - push @quoted, $quoter->($self->_expand_vars($_)); + push @quoted, $quoter->$quote_method($self->_expand_vars($_)); } } if ($quote_extended) { - push @quoted, '</dev/null' if $opts->{stdin_discard}; - if ($opts->{stdout_discard}) { - push @quoted, '>/dev/null'; - push @quoted, '2>&1' if ($opts->{stderr_to_stdout} || $opts->{stderr_discard}) - } - else { - push @quoted, '2>/dev/null' if $opts->{stderr_discard}; - } + my @fragments; + if ( $opts->{stdout_discard} and + ( $opts->{stderr_discard} or $opts->{stderr_to_stdout} ) ) { + @fragments = ('stdout_and_stderr_discard'); + push @fragments, 'stdin_discard' if $opts->{stdin_discard}; + } + else { + @fragments = grep $opts->{$_}, qw(stdin_discard stdout_discard + stderr_discard stderr_to_stdout); + } + push @quoted, $quoter->shell_fragments(@fragments); } wantarray ? @quoted : join(" ", @quoted); } @@ -1152,10 +1197,15 @@ sub make_remote_command { my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ()); my @ssh_opts = _array_or_scalar_to_list delete $opts{ssh_opts}; my $tty = delete $opts{tty}; - push @ssh_opts, ($tty ? '-qtt' : '-T') if defined $tty; + my $ssh_flags = ''; + $ssh_flags .= ($tty ? 'qtt' : 'T') if defined $tty; if ($self->{_forward_agent}) { my $forward_agent = delete $opts{forward_agent}; - push @ssh_opts, ($forward_agent ? '-A' : '-a') if defined $forward_agent; + $ssh_flags .= ($forward_agent ? 'A' : 'a') if defined $forward_agent; + } + if ($self->{_forward_X11}) { + my $forward_X11 = delete $opts{forward_X11}; + $ssh_flags .= ($forward_X11 ? 'X' : 'x'); } my $tunnel = delete $opts{tunnel}; my (@args); @@ -1168,6 +1218,7 @@ sub make_remote_command { } _croak_bad_options %opts; + push @ssh_opts, "-$ssh_flags" if length $ssh_flags; my @call = $self->_make_ssh_call(\@ssh_opts, @args); if (wantarray) { $debug and $debug & 16 and _debug_dump make_remote_command => \@call; @@ -1199,12 +1250,10 @@ sub _open_file { sub _fileno_dup_over { my ($good_fn, $fh) = @_; if (defined $fh) { - my @keep_open; my $fn = fileno $fh; for (1..5) { $fn >= $good_fn and return $fn; $fn = POSIX::dup($fn); - push @keep_open, $fn; } POSIX::_exit(255); } @@ -1243,9 +1292,30 @@ sub _delete_argument_encoding { sub open_ex { ${^TAINT} and &_catch_tainted_args; my $self = shift; - $self->wait_for_master or return; my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ()); + unless (delete $opts{_no_master_required}) { + $self->wait_for_master or return; + } + + my $ssh_flags = ''; my $tunnel = delete $opts{tunnel}; + my ($cmd, $close_slave_pty, @args); + if ($tunnel) { + @_ == 2 or croak 'bad number of arguments for tunnel, use $ssh->method(\\%opts, $host, $port)'; + @args = @_; + } + else { + my $argument_encoding = $self->_delete_argument_encoding(\%opts); + my $tty = delete $opts{tty}; + $ssh_flags .= ($tty ? 'qtt' : 'T') if defined $tty; + + $cmd = delete $opts{_cmd} || 'ssh'; + $opts{quote_args_extended} = 1 + if (not defined $opts{quote_args_extended} and $cmd eq 'ssh'); + @args = $self->_quote_args(\%opts, @_); + $self->_encode_args($argument_encoding, @args) or return; + } + my ($stdinout_socket, $stdinout_dpipe_make_parent); my $stdinout_dpipe = delete $opts{stdinout_dpipe}; if ($stdinout_dpipe) { @@ -1260,11 +1330,16 @@ sub open_ex { $stdout_discard, $stdout_pipe, $stdout_fh, $stdout_file, $stdout_pty, $stderr_discard, $stderr_pipe, $stderr_fh, $stderr_file, $stderr_to_stdout); unless ($stdinout_socket) { - ( $stdin_discard = delete $opts{stdin_discard} or - $stdin_pipe = delete $opts{stdin_pipe} or - $stdin_fh = delete $opts{stdin_fh} or - $stdin_file = delete $opts{stdin_file} or - (not $tunnel and $stdin_pty = delete $opts{stdin_pty}) ); + unless ($stdin_discard = delete $opts{stdin_discard} or + $stdin_pipe = delete $opts{stdin_pipe} or + $stdin_fh = delete $opts{stdin_fh} or + $stdin_file = delete $opts{stdin_file}) { + unless ($tunnel) { + if ($stdin_pty = delete $opts{stdin_pty}) { + $close_slave_pty = _first_defined delete $opts{close_slave_pty}, 1; + } + } + } ( $stdout_discard = delete $opts{stdout_discard} or $stdout_pipe = delete $opts{stdout_pipe} or @@ -1282,36 +1357,21 @@ sub open_ex { $stderr_to_stdout = delete $opts{stderr_to_stdout} or $stderr_file = delete $opts{stderr_file} ); - my $argument_encoding = $self->_delete_argument_encoding(\%opts); my $ssh_opts = delete $opts{ssh_opts}; $ssh_opts = $self->{_default_ssh_opts} unless defined $ssh_opts; my @ssh_opts = $self->_expand_vars(_array_or_scalar_to_list $ssh_opts); if ($self->{_forward_agent}) { my $forward_agent = delete $opts{forward_agent}; - push @ssh_opts, ($forward_agent ? '-A' : '-a') if defined $forward_agent; + $ssh_flags .= ($forward_agent ? 'A' : 'a') if defined $forward_agent; } - - my ($cmd, $close_slave_pty, @args); - if ($tunnel) { - @_ == 2 or croak 'bad number of arguments for tunnel, use $ssh->method(\\%opts, $host, $port)'; - @args = @_; + if ($self->{_forward_X11}) { + my $forward_X11 = delete $opts{forward_X11}; + $ssh_flags .= ($forward_X11 ? 'X' : 'x'); } - else { - if ($stdin_pty) { - $close_slave_pty = delete $opts{close_slave_pty}; - $close_slave_pty = 1 unless defined $close_slave_pty; - } - - my $tty = delete $opts{tty}; - push @ssh_opts, ($tty ? '-qtt' : '-T') if defined $tty; - $cmd = delete $opts{_cmd} || 'ssh'; - $opts{quote_args_extended} = 1 - if (not defined $opts{quote_args_extended} and $cmd eq 'ssh'); - @args = $self->_quote_args(\%opts, @_); - $self->_encode_args($argument_encoding, @args) or return; - } + my $setpgrp = delete $opts{setpgrp}; + undef $setpgrp if defined $stdin_pty; _croak_bad_options %opts; @@ -1383,10 +1443,13 @@ sub open_ex { _check_is_system_fh STDERR => $werr; } + push @ssh_opts, "-$ssh_flags" if length $ssh_flags; + my @call = ( $tunnel ? $self->_make_tunnel_call(\@ssh_opts, @args) : $cmd eq 'ssh' ? $self->_make_ssh_call(\@ssh_opts, @args) : $cmd eq 'scp' ? $self->_make_scp_call(\@ssh_opts, @args) : $cmd eq 'rsync' ? $self->_make_rsync_call(\@ssh_opts, @args) : + $cmd eq 'raw' ? @args : die "internal error: bad _cmd protocol" ); $debug and $debug & 16 and _debug_dump open_ex => \@call; @@ -1399,6 +1462,8 @@ sub open_ex { return; } + setpgrp if $setpgrp; + $stdin_discard and (open $rin, '<', '/dev/null' or POSIX::_exit(255)); $stdout_discard and (open $wout, '>', '/dev/null' or POSIX::_exit(255)); $stderr_discard and (open $werr, '>', '/dev/null' or POSIX::_exit(255)); @@ -1456,7 +1521,7 @@ sub pipe_in { "unable to fork new ssh slave: $!"); return; } - return wantarray ? ($rin, $pid) : $rin; + wantarray ? ($rin, $pid) : $rin; } sub pipe_out { @@ -1477,7 +1542,7 @@ sub pipe_out { "unable to fork new ssh slave: $!"); return; } - return wantarray ? ($rout, $pid) : $rout; + wantarray ? ($rout, $pid) : $rout; } sub _find_encoding { @@ -1538,9 +1603,12 @@ sub _decode { $self->_check_eval_ok(OSSH_ENCODING_ERROR); } +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) = @_; - $self->wait_for_master or return; + # $self->wait_for_master or return; my @data = _array_or_scalar_to_list $stdin_data; my ($cout, $cerr, $cin) = (defined($out), defined($err), defined($in)); $timeout = $self->{_timeout} unless defined $timeout; @@ -1604,17 +1672,16 @@ sub _io3 { _debug "stdout, bytes read: ", $read, " at offset $offset"; $read and $debug & 128 and _hexdump substr $bout, $offset; } - unless ($read) { + unless ($read or grep $! == $_, @retriable) { close $out; undef $cout; $recalc_vecs = 1; - last unless $rv =~ /[^\x00]/; } } if ($cerr and vec($rv1, $fnoerr, 1)) { my $read = sysread($err, $berr, 20480, length($berr)); $debug and $debug & 64 and _debug "stderr, bytes read: ", $read; - unless ($read) { + unless ($read or grep $! == $_, @retriable) { close $err; undef $cerr; $recalc_vecs = 1; @@ -1633,6 +1700,10 @@ sub _io3 { if (defined $data[0] and length $data[0]); shift @data; } + # fallback when stdin queue is exhausted + } + elsif (grep $! == $_, @retriable) { + next FAST; } close $in; undef $cin; @@ -1640,7 +1711,7 @@ sub _io3 { } } else { - next if ($n < 0 and $! == Errno::EINTR()); + next if $n < 0 and grep $! == $_, @retriable; $self->_set_error(OSSH_SLAVE_TIMEOUT, 'ssh slave failed', 'timed out'); last MLOOP; } @@ -1665,8 +1736,8 @@ sub _io3 { _sub_options spawn => qw(stderr_to_stdout stdin_discard stdin_fh stdin_file stdout_discard stdout_fh stdout_file stderr_discard stderr_fh stderr_file - stdinout_dpipe stdinout_dpipe_make_parent quote_args tty ssh_opts tunnel - encoding argument_encoding forward_agent); + stdinout_dpipe stdinout_dpipe_make_parent quote_args quote_args_extended remote_shell glob_quoting + tty ssh_opts tunnel encoding argument_encoding forward_agent forward_X11 setpgrp); sub spawn { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1676,13 +1747,15 @@ sub spawn { return scalar $self->open_ex(\%opts, @_); } -_sub_options open2 => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file quote_args - tty ssh_opts tunnel encoding argument_encoding forward_agent); +_sub_options open2 => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file quote_args quote_args_extended + remote_shell glob_quoting tty ssh_opts tunnel encoding argument_encoding forward_agent + forward_X11 setpgrp); sub open2 { ${^TAINT} and &_catch_tainted_args; my $self = shift; my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ()); _croak_bad_options %opts; + _croak_scalar_context; my ($in, $out, undef, $pid) = $self->open_ex({ stdout_pipe => 1, @@ -1691,8 +1764,10 @@ sub open2 { return ($in, $out, $pid); } -_sub_options open2pty => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file quote_args tty - close_slave_pty ssh_opts encoding argument_encoding forward_agent); +_sub_options open2pty => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file + quote_args quote_args_extended remote_shell glob_quoting tty + close_slave_pty ssh_opts encoding argument_encoding forward_agent + forward_X11 setpgrp); sub open2pty { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1704,11 +1779,13 @@ sub open2pty { stdin_pty => 1, tty => 1, %opts }, @_) or return (); - return ($pty, $pid); + wantarray ? ($pty, $pid) : $pty; } -_sub_options open2socket => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file quote_args tty - ssh_opts tunnel encoding argument_encoding forward_agent); +_sub_options open2socket => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file + quote_args quote_args_extended remote_shell glob_quoting tty + ssh_opts tunnel encoding argument_encoding forward_agent + forward_X11 setpgrp); sub open2socket { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1718,15 +1795,17 @@ sub open2socket { my ($socket, undef, undef, $pid) = $self->open_ex({ stdinout_socket => 1, %opts }, @_) or return (); - return ($socket, $pid); + wantarray ? ($socket, $pid) : $socket; } -_sub_options open3 => qw(quote_args tty ssh_opts encoding argument_encoding forward_agent); +_sub_options open3 => qw(quote_args quote_args_extended remote_shell glob_quoting tty ssh_opts + encoding argument_encoding forward_agent forward_X11 setpgrp); sub open3 { ${^TAINT} and &_catch_tainted_args; my $self = shift; my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ()); _croak_bad_options %opts; + _croak_scalar_context; my ($in, $out, $err, $pid) = $self->open_ex({ stdout_pipe => 1, @@ -1737,13 +1816,14 @@ sub open3 { return ($in, $out, $err, $pid); } -_sub_options open3pty => qw(quote_args tty close_slave_pty ssh_opts - encoding argument_encoding forward_agent); +_sub_options open3pty => qw(quote_args quote_args_extended remote_shell glob_quoting tty close_slave_pty ssh_opts + encoding argument_encoding forward_agent forward_X11 setpgrp); sub open3pty { ${^TAINT} and &_catch_tainted_args; my $self = shift; my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ()); _croak_bad_options %opts; + _croak_scalar_context; my ($pty, undef, $err, $pid) = $self->open_ex({ stdout_pty => 1, @@ -1755,10 +1835,28 @@ sub open3pty { return ($pty, $err, $pid); } +_sub_options open3socket => qw(quote_args quote_args_extended remote_shell glob_quoting tty ssh_opts encoding + argument_encoding forward_agent + forward_X11 setpgrp); +sub open3socket { + ${^TAINT} and &_catch_tainted_args; + my $self = shift; + my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ()); + _croak_bad_options %opts; + _croak_scalar_context; + + my ($socket, undef, $err, $pid) = + $self->open_ex({ stdinout_socket => 1, + stderr_pipe => 1, + %opts }, @_) or return (); + return ($socket, $err, $pid); +} + _sub_options system => qw(stdout_discard stdout_fh stdin_discard stdout_file stdin_fh stdin_file - quote_args stderr_to_stdout stderr_discard stderr_fh stderr_file + quote_args quote_args_extended remote_shell glob_quoting + stderr_to_stdout stderr_discard stderr_fh stderr_file stdinout_dpipe stdinout_dpipe_make_parent tty ssh_opts tunnel encoding - argument_encoding forward_agent); + argument_encoding forward_agent forward_X11 setpgrp); sub system { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1785,9 +1883,10 @@ sub system { } _sub_options test => qw(stdout_discard stdout_fh stdin_discard stdout_file stdin_fh stdin_file - quote_args stderr_to_stdout stderr_discard stderr_fh stderr_file + quote_args quote_args_extended remote_shell glob_quoting + stderr_to_stdout stderr_discard stderr_fh stderr_file stdinout_dpipe stdinout_dpipe_make_parent tty ssh_opts timeout stdin_data - encoding stream_encoding argument_encoding forward_agent); + encoding stream_encoding argument_encoding forward_agent forward_X11 setpgrp); sub test { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1811,8 +1910,9 @@ sub test { } _sub_options capture => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file - stdin_discard stdin_fh stdin_file quote_args tty ssh_opts tunnel - encoding argument_encoding forward_agent); + stdin_discard stdin_fh stdin_file quote_args quote_args_extended + remote_shell glob_quoting tty ssh_opts tunnel + encoding argument_encoding forward_agent forward_X11 setpgrp); sub capture { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1840,8 +1940,9 @@ sub capture { } _sub_options capture2 => qw(stdin_discard stdin_fh stdin_file - quote_args tty ssh_opts encoding - argument_encoding forward_agent); + quote_args quote_args_extended remote_shell glob_quoting + tty ssh_opts encoding stream_encoding + argument_encoding forward_agent forward_X11 setpgrp); sub capture2 { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1865,7 +1966,8 @@ sub capture2 { wantarray ? @capture : $capture[0]; } -_sub_options open_tunnel => qw(ssh_opts stderr_discard stderr_fh stderr_file encoding argument_encoding forward_agent); +_sub_options open_tunnel => qw(ssh_opts stderr_discard stderr_fh stderr_file + encoding argument_encoding forward_agent setpgrp); sub open_tunnel { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1879,7 +1981,7 @@ sub open_tunnel { _sub_options capture_tunnel => qw(ssh_opts stderr_discard stderr_fh stderr_file stdin_discard stdin_fh stdin_file stdin_data timeout encoding stream_encoding - argument_encoding forward_agent); + argument_encoding forward_agent setpgrp); sub capture_tunnel { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -1911,10 +2013,11 @@ sub _scp_get_args { my $prefix = $self->{_host_squared}; $prefix = "$self->{_user}\@$prefix" if defined $self->{_user}; - my @src = map "$prefix:$_", $self->_quote_args({quote_args => 1, - glob_quoting => $glob}, - @_); - ($self, \%opts, $target, @src); + + my $src = "$prefix:". join(" ", $self->_quote_args({quote_args => 1, + glob_quoting => $glob}, + @_)); + ($self, \%opts, $target, $src); } sub scp_get { @@ -1942,8 +2045,9 @@ sub _scp_put_args { my $prefix = $self->{_host_squared}; $prefix = "$self->{_user}\@$prefix" if defined $self->{_user}; + my $remote_shell = delete $opts{remote_shell}; my $target = $prefix . ':' . ( @_ > 1 - ? $self->_quote_args({quote_args => 1}, pop(@_)) + ? $self->_quote_args({quote_args => 1, remote_shell => $remote_shell}, pop(@_)) : ''); my @src = @_; @@ -1978,7 +2082,7 @@ sub rsync_put { _sub_options _scp => qw(stderr_to_stdout stderr_discard stderr_fh stderr_file stdout_discard stdout_fh stdout_file encoding argument_encoding - forward_agent); + forward_agent setpgrp); sub _scp { my $self = shift; my %opts = (ref $_[0] eq 'HASH' ? %{shift()} : ()); @@ -1999,7 +2103,7 @@ sub _scp { push @opts, '-v' if $verbose; push @opts, '-r' if $recursive; push @opts, '-p' if $copy_attrs; - push @opts, '-l', $bwlimit if defined $bwlimit; + push @opts, '-l', $bwlimit if $bwlimit; local $self->{_error_prefix} = [@{$self->{_error_prefix}}, 'scp failed']; @@ -2063,7 +2167,7 @@ sub _rsync { my @opts = qw(--blocking-io) ; push @opts, '-q' if $quiet; - push @opts, '-p' if $copy_attrs; + push @opts, '-pt' if $copy_attrs; push @opts, '-' . ($verbose =~ /^\d+$/ ? 'v' x $verbose : 'v') if $verbose; my %opts_open_ex = ( _cmd => 'rsync', @@ -2109,7 +2213,7 @@ sub _rsync { } _sub_options sftp => qw(autoflush timeout argument_encoding encoding block_size - queue_size late_set_perm forward_agent); + queue_size late_set_perm forward_agent setpgrp); sub sftp { ${^TAINT} and &_catch_tainted_args; @@ -2144,7 +2248,7 @@ sub sftp { } _sub_options sshfs_import => qw(stderr_discard stderr_fh stderr_file - ssh_opts argument_encoding sshfs_opts); + ssh_opts argument_encoding sshfs_opts setpgrp); sub sshfs_import { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -2162,7 +2266,7 @@ sub sshfs_import { } _sub_options sshfs_export => qw(stderr_discard stderr_fh stderr_file - ssh_opts argument_encoding sshfs_opts); + ssh_opts argument_encoding sshfs_opts setpgrp); sub sshfs_export { ${^TAINT} and &_catch_tainted_args; my $self = shift; @@ -2174,9 +2278,12 @@ sub sshfs_export { _croak_bad_options %opts; $opts{stdinout_dpipe} = $self->{_sftp_server_cmd}; - my $hostname = eval { - require Sys::Hostname; - Sys::Hostname::hostname(); + my $hostname = do { + local ($@, $SIG{__DIE__}); + eval { + require Sys::Hostname; + Sys::Hostname::hostname(); + }; }; $hostname = 'remote' if (not defined $hostname or not length $hostname or @@ -2257,19 +2364,19 @@ OpenSSH binary client (C<ssh>). =head2 Under the hood This package is implemented around the multiplexing feature found in -later versions of OpenSSH. That feature allows reuse of a previous SSH -connection for running new commands (I believe that OpenSSH 4.1 is the -first one to provide all the required functionality). +later versions of OpenSSH. That feature allows one to run several +commands over a single SSH connection (IIRC, OpenSSH 4.1 is the first +one to provide all the required functionality). When a new Net::OpenSSH object is created, the OpenSSH C<ssh> client -is run in master mode, establishing a permanent (actually, for the -lifetime of the object) connection to the server. +is run in master mode, establishing a persistent (for the lifetime of +the object) connection to the server. Then, every time a new operation is requested a new C<ssh> process is started in slave mode, effectively reusing the master SSH connection to send the request to the remote side. -=head2 Net::OpenSSH Vs Net::SSH::.* modules +=head2 Net::OpenSSH Vs. Net::SSH::.* modules Why should you use Net::OpenSSH instead of any of the other Perl SSH clients available? @@ -2295,13 +2402,13 @@ Net::SSH is just a wrapper around any SSH binary commands available on the machine. It can be very slow as they establish a new SSH connection for every operation performed. -In comparison, Net::OpenSSH is a pure perl module that doesn't have +In comparison, Net::OpenSSH is a pure perl module that does not have any mandatory dependencies (obviously, besides requiring OpenSSH binaries). Net::OpenSSH has a very perlish interface. Most operations are performed in a fashion very similar to that of the Perl builtins and -common modules (i.e. L<IPC::Open2|IPC::Open2>). +common modules (e.g. L<IPC::Open2|IPC::Open2>). It is also very fast. The overhead introduced by launching a new ssh process for every operation is not appreciable (at least on my Linux @@ -2309,7 +2416,7 @@ box). The bottleneck is the latency intrinsic to the protocol, so Net::OpenSSH is probably as fast as an SSH client can be. Being based on OpenSSH is also an advantage: a proved, stable, secure -(to paranoic levels), interoperable and well maintained implementation +(to paranoid levels), inseparably and well maintained implementation of the SSH protocol is used. On the other hand, Net::OpenSSH does not work on Windows, not even @@ -2393,9 +2500,7 @@ Login name TCP port number where the server is running -=item passwd => $passwd - -=item password => $passwd +=item password => $password User given password for authentication. @@ -2403,7 +2508,6 @@ Note that using password authentication in automated scripts is a very bad idea. When possible, you should use public key authentication instead. - =item passphrase => $passphrase X<passphrase>Uses given passphrase to open private key. @@ -2466,6 +2570,10 @@ By default it is inferred from the C<ssh> one. Name or full path to C<rsync> binary. Defaults to C<rsync>. +=item remote_shell => $name + +Name of the remote shell. Used to select the argument quoter backend. + =item timeout => $timeout Maximum acceptable time that can elapse without network traffic or any @@ -2500,7 +2608,7 @@ For instance, the following code connects to several remote machines in parallel: my (%ssh, %ls); - # multiple connections are stablished in parallel: + # multiple connections are established in parallel: for my $host (@hosts) { $ssh{$host} = Net::OpenSSH->new($host, async => 1); } @@ -2534,6 +2642,14 @@ Enables forwarding of the authentication agent. This option can not be used when passing a passphrase (via L</passphrase>) to unlock the login private key. +Note that Net::OpenSSH will not run C<ssh-agent> for you. This has to +be done ahead of time and the environment variable C<SSH_AUTH_SOCK> +set pointing to the proper place. + +=item forward_X11 => 1 + +Enables forwarding of the X11 protocol + =item default_stdin_fh => $fh =item default_stdout_fh => $fh @@ -2562,7 +2678,7 @@ For instance: =item default_stderr_file = $fn -Opens the given filenames and use it as the defaults. +Opens the given file names and use them as the defaults. =item master_stdout_fh => $fh @@ -2597,6 +2713,9 @@ Example: $ssh = Net::OpenSSH->new('foo', external_master => 1, ctl_path = $path); +When C<external_master> is set, the hostname argument becomes optional +(C<0.0.0.0> is passed to OpenSSH which does not use it at all). + =item default_encoding => $encoding =item default_stream_encoding => $encoding @@ -2605,13 +2724,28 @@ Example: Set default encodings. See L</Data encoding>. +=item password_prompt => $string + +=item password_prompt => $re + +By default, when using password authentication, the module expects the +remote side to send a password prompt matching C</[?:]/>. + +This option can be used to override that default for the rare cases +when a different prompt is used. + +Examples: + + password_prompt => ']'; # no need to escape ']' + password_prompt => qr/[:?>]/; + =item login_handler => \&custom_login_handler Some remote SSH server may require a custom login/authentication interaction not natively supported by Net::OpenSSH. In that cases, you can use this option to replace the default login logic. -The callback will be invoked repeatly as C<custom_login_handler($ssh, +The callback will be invoked repeatedly as C<custom_login_handler($ssh, $pty, $data)> where C<$ssh> is the current Net::OpenSSH object, C<pty> a L<IO::Pty> object attached to the slave C<ssh> process tty and C<$data> a reference to an scalar you can use at will. @@ -2631,6 +2765,21 @@ Usage of this option is incompatible with the C<password> and C<passphrase> options, you will have to handle password or passphrases from the custom handler yourself. +=item master_setpgrp => 1 + +When this option is set, the master process is run as a different +process group. As a consequence it will not die when the user presses +Ctrl-C at the terminal. + +In order to allow the master SSH process to request any information +from the user, the module may set it as the terminal controlling +process while the connection is established (using +L<POSIX/tcsetpgrp>). Afterwards, the terminal controlling process is +reset. + +This feature is highly experimental. Report any problems you may find, +please. + =back =item $ssh->error @@ -2657,7 +2806,8 @@ process listens for new multiplexed connections. =item ($in, $out, $err, $pid) = $ssh->open_ex(\%opts, @cmd) -X<open_ex>I<Note: this is a low level method that, probably, you don't need to use!> +X<open_ex>I<Note: this is a low level method which, probably, you do +not need to use!> That method starts the command C<@cmd> on the remote machine creating new pipes for the IO channels as specified on the C<%opts> hash. @@ -2687,9 +2837,9 @@ value (C<$in>). Similar to C<stdin_pipe>, but instead of a regular pipe it uses a pseudo-tty (pty). -Note that on some OSs (i.e. HP-UX, AIX), ttys are not reliable. They -can overflow when large chunks are written or when data is -written faster than it is read. +Note that on some operating systems (e.g. HP-UX, AIX), ttys are not +reliable. They can overflow when large chunks are written or when data +is written faster than it is read. =item stdin_fh => $fh @@ -2739,7 +2889,7 @@ Uses /dev/null as the remote process stdout stream. =item stdinout_socket => 1 -Creates a new socketpair, attachs the stdin an stdout streams of the +Creates a new socketpair, attaches the stdin an stdout streams of the slave SSH process to one end and returns the other as the first value (C<$in>) and undef for the second (C<$out>). @@ -2783,9 +2933,9 @@ Makes stderr point to stdout. =item tty => $bool -Tells ssh to allocate a pseudo-tty for the remote process. By default, -a tty is allocated if remote command stdin stream is attached to a -tty. +Tells C<ssh> to allocate a pseudo-tty for the remote process. By +default, a tty is allocated if remote command stdin stream is attached +to a tty. When this flag is set and stdin is not attached to a tty, the ssh master and slave processes may generate spurious warnings about failed @@ -2798,7 +2948,7 @@ When a pseudo pty is used for the stdin stream, the slave side is automatically closed on the parent process after forking the ssh command. -This option dissables that feature, so that the slave pty can be +This option disables that feature, so that the slave pty can be accessed on the parent process as C<$pty-E<gt>slave>. It will have to be explicitly closed (see L<IO::Pty|IO::Pty>) @@ -2806,6 +2956,19 @@ be explicitly closed (see L<IO::Pty|IO::Pty>) See L</"Shell quoting"> below. +=item remote_shell => $shell + +Sets the remote shell. Allows to change the argument quoting mechanism +in a per-command fashion. + +This may be useful when interacting with a Windows machine where +argument parsing may be done at the command level in custom ways. + +Example: + + $ssh->system({remote_shell => 'MSWin'}, echo => $line); + $ssh->system({remote_shell => 'MSCmd,MSWin'}, type => $file); + =item forward_agent => $bool Enables/disables forwarding of the authentication agent. @@ -2813,6 +2976,13 @@ Enables/disables forwarding of the authentication agent. This option can only be used when agent forwarding has been previously requested on the constructor. +=item forward_X11 => $bool + +Enables/disables forwarding of the X11 protocol. + +This option can only be used when X11 forwarding has been previously +requested on the constructor. + =item ssh_opts => \@opts List of extra options for the C<ssh> command. @@ -2852,11 +3022,23 @@ Usage example: # ... waitpid($pid); +=item setpgrp => 1 + +Calls C<setpgrp> after forking the child process. As a result it will +not die when the user presses Ctrl+C at the console. See also +L<perlfunc/setpgrp>. + +Using this option without also setting C<master_setpgrp> on the +constructor call is mostly useless as the signal will be delivered to +the master process and all the remote commands aborted. + +This feature is experimental. + =item $ssh->system(\%opts, @cmd) Runs the command C<@cmd> on the remote machine. -Returns true on sucess, undef otherwise. +Returns true on success, undef otherwise. The error status is set to C<OSSH_SLAVE_CMD_FAILED> when the remote command exits with a non zero code (the code is available from C<$?>, @@ -2960,7 +3142,7 @@ C<async> and C<tunnel>. =item @output = $ssh->capture(\%opts, @cmd); This method is conceptually equivalent to the perl backquote operator -(i.e. C<`ls`>): it runs the command on the remote machine and captures +(e.g. C<`ls`>): it runs the command on the remote machine and captures its output. In scalar context returns the output as a scalar. In list context @@ -3109,7 +3291,7 @@ with the following code: waitpid($_, 0) for @pid; -Note that C<spawn> shouldn't be used to start detached remote +Note that C<spawn> should not be used to start detached remote processes that may survive the local program (see also the L</FAQ> about running remote processes detached). @@ -3146,7 +3328,7 @@ master connection. When transferring several files, the target argument must point to an existing directory. If only one file is to be transferred, the target -argument can be a directory or a file name or can be ommited. For +argument can be a directory or a file name or can be omitted. For instance: $ssh->scp_get({glob => 1}, '/var/tmp/foo*', '/var/tmp/bar*', '/tmp'); @@ -3163,7 +3345,7 @@ Accepted options: By default, C<scp> is called with the quiet flag C<-q> enabled in order to suppress progress information. This option allows one to -reenable the progress indication bar. +re-enable the progress indication bar. =item verbose => 1 @@ -3180,8 +3362,8 @@ wildcards can be used to select files. =item glob_flags => $flags -Second argument passed to L<File::Glob::bsd_glob|File::Glob/bsd_glob> function. Only -available for L</scp_put> method. +Second argument passed to L<File::Glob::bsd_glob|File::Glob/bsd_glob> +function. Only available for L</scp_put> method. =item copy_attrs => 1 @@ -3190,7 +3372,7 @@ files. =item bwlimit => $Kbits -Limits the used bandwith, specified in Kbit/s. +Limits the used bandwidth, specified in Kbit/s. =item timeout => $secs @@ -3199,7 +3381,7 @@ given timeout elapses. See also L</Timeouts>. =item async => 1 -Doesn't wait for the C<scp> command to finish. When this option is +Does not wait for the C<scp> command to finish. When this option is used, the method returns the PID of the child C<scp> process. For instance, it is possible to transfer files to several hosts in @@ -3239,6 +3421,13 @@ capture of the output of the C<scp> program. Note that C<scp> will not generate progress reports unless its stdout stream is attached to a tty. +=item ssh_opts => \@opts + +List of extra options for the C<ssh> command. + +This feature should be used with care, as the given options are not +checked in any way by the module, and they could interfere with it. + =back =item $ssh->rsync_get(\%opts, $remote1, $remote2,..., $local_dir_or_file) @@ -3248,7 +3437,7 @@ stream is attached to a tty. These methods use C<rsync> over SSH to transfer files from/to the remote machine. -They accept the same set of options as the SCP ones. +They accept the same set of options as the C<scp> ones. Any unrecognized option will be passed as an argument to the C<rsync> command (see L<rsync(1)>). Underscores can be used instead of dashes @@ -3313,7 +3502,7 @@ When the connection has been established by calling the constructor with the C<async> option, this call allows one to advance the process. If C<$async> is true, it will perform any work that can be done -inmediately without waiting (for instance, entering the password or +immediately without waiting (for instance, entering the password or checking for the existence of the multiplexing socket) and then return. If a false value is given, it will finalize the connection process and wait until the multiplexing socket is available. @@ -3406,7 +3595,7 @@ They return the C<$pid> of the C<sshfs> process or of the slave C<ssh> process used to proxy it. Killing that process unmounts the file system, though, it may be probably better to use L<fusermount(1)>. -The options acepted are as follows: +The options accepted are as follows: =over @@ -3478,7 +3667,7 @@ will correctly handle the spaces in the program path. The shell quoting mechanism implements some extensions (for instance, performing redirections to /dev/null on the remote side) that can be -dissabled with the option C<quote_args_extended>: +disabled with the option C<quote_args_extended>: $ssh->system({ stderr_discard => 1, quote_args => 1, quote_args_extended => 0 }, @@ -3497,10 +3686,10 @@ arguments and leave others untouched: $ssh->shell_quote('ls', '-l'), "/tmp/files_*.dat"); -When the glob option is set in scp and rsync file transfer methods, an -alternative quoting method that knows about file wildcards and passes -them unquoted is used. The set of wildcards recognized currently is -the one supported by L<bash(1)>. +When the glob option is set in C<scp> and C<rsync> file transfer +methods, an alternative quoting method which knows about file +wildcards and passes them unquoted is used. The set of wildcards +recognized currently is the one supported by L<bash(1)>. Another way to selectively use quote globing or fully disable quoting for some specific arguments is to pass them as scalar references or @@ -3522,28 +3711,36 @@ the following debug flag: $Net::OpenSSH::debug |= 16; -Also, the current shell quoting implementation expects a shell -compatible with Unix C<sh> in the remote side. It will not work as -expected if for instance, the remote machine runs Windows, VMS or it -is a router. +By default, the module assumes the remote shell is some variant of a +POSIX or Bourne shell (C<bash>, C<dash>, C<ksh>, etc.). If this is not +the case, the construction option C<remote_shell> can be used to +select an alternative quoting mechanism. -As a workaround, do any required quoting yourself and pass the quoted -command as a string so that no further quoting is performed. For -instance: +For instance: + + $ssh = Net::OpenSSH->new($host, remote_shell => 'csh'); + $ssh->system(echo => "hard\n to\n quote\n argument!"); + +Currently there are quoters available for POSIX (Bourne) compatible +shells, C<csh> and the two Windows variants C<MSWin> (for servers +using L<Win32::CreateProcess>, see +L<Net::OpenSSH::ShellQuoter::MSWin>) and C<MSCmd> (for servers using +C<cmd.exe>, see L<Net::OpenSSH::ShellQuoter::MSCmd>). + +In any case, you can always do the quoting yourself and pass the +quoted remote command as a single string: # for VMS $ssh->system('DIR/SIZE NFOO::USERS:[JSMITH.DOCS]*.TXT;0'); -I plan to add support for different quoting mechanisms in the -future... if you need it now, just ask for it!!! - -The current quoting mechanism does not handle possible aliases defined -by the remote shell. In that case, to force execution of the command -instead of the alias, the full path to the command must be used. +Note that the current quoting mechanism does not handle possible +aliases defined by the remote shell. In that case, to force execution +of the command instead of the alias, the full path to the command must +be used. =head2 Timeouts -In order to stop remote processes when they timeout, the ideal aproach +In order to stop remote processes when they timeout, the ideal approach would be to send them signals through the SSH connection as specified by the protocol standard. @@ -3659,7 +3856,7 @@ or received from the remote server to Perl internal unicode representation. The methods supporting that feature are those that move data from/to -Perl data structures (i.e. C<capture>, C<capture2>, C<capture_tunnel> +Perl data structures (e.g. C<capture>, C<capture2>, C<capture_tunnel> and methods supporting the C<stdin_data> option). Data accessed through pipes, sockets or redirections is not affected by the encoding options. @@ -3668,7 +3865,7 @@ passed to the remote server on the command line. By default, if no encoding option is given on the constructor or on the method calls, Net::OpenSSH will not perform any encoding transformation, -effectively processing the data as latin1. +effectively processing the data as C<latin1>. When data can not be converted between the Perl internal representation and the selected encoding inside some Net::OpenSSH @@ -3765,7 +3962,7 @@ not backed up by real file descriptors at the operative system level. Net::OpenSSH will fail if any of these handles is used explicitly or implicitly when calling some remote command. -The workaround is to redirect them to C</dev/null> or to some file: +The work-around is to redirect them to C</dev/null> or to some file: open my $def_in, '<', '/dev/null' or die "unable to open /dev/null"; my $ssh = Net::OpenSSH->new($host, @@ -3775,10 +3972,10 @@ The workaround is to redirect them to C</dev/null> or to some file: $ssh->system({stdout_discard => 1}, $cmd2); $ssh->system({stdout_to_file => '/tmp/output'}, $cmd3); -Also, note that from a security stand point, running ssh from inside -the webserver process is not a great idea. An attacker exploiting some -Apache bug would be able to access the ssh keys and passwords and gain -unlimited access to the remote systems. +Also, note that from a security stand point, running C<ssh> from +inside the web server process is not a great idea. An attacker +exploiting some Apache bug would be able to access the SSH keys and +passwords and gain unlimited access to the remote systems. If you can, use a queue (as L<TheSchwartz|TheSchwartz>) or any other mechanism to execute the ssh commands from another process running @@ -3853,11 +4050,11 @@ use. For instance: $ssh = Net::OpenSSH->new($host, ssh_cmd => "/opt/OpenSSH/5.8/bin/ssh") -Some hardware vendors (i.e. Sun) include custom versions of OpenSSH -bundled with the operative system. In priciple, Net::OpenSSH should -work with these SSH clients as long as they are derived from some -version of OpenSSH recent enough. Anyway, I advise you to use the real -OpenSSH software if you can! +Some hardware vendors (e.g. Sun, err... Oracle) include custom +versions of OpenSSH bundled with the operative system. In principle, +Net::OpenSSH should work with these SSH clients as long as they are +derived from some version of OpenSSH recent enough. Anyway, my advise +is to use the real OpenSSH software if you can! =item 3 - run ssh from the command line @@ -3865,7 +4062,7 @@ Check you can connect to the remote host using the same parameters you are passing to Net::OpenSSH. In particular, ensure that you are running C<ssh> as the same local user. -If you are running your script from a webserver, the user +If you are running your script from a web server, the user would probably be C<www>, C<apache> or something alike. Common problems are: @@ -3887,7 +4084,7 @@ implementations may use other file locations). Maintaining the server keys when several hosts and clients are involved may be somewhat inconvenient, so most SSH clients, by -default, when a new connection is stablished to a host whose key is +default, when a new connection is established to a host whose key is not in the C<known_hosts> file, show the key and ask the user if he wants the key copied there. @@ -4027,15 +4224,15 @@ Frequent questions about the module: =item Connecting to switches, routers, etc. -B<Q>: I can't get the method C<system>, C<capture>, etc., to work when -connecting to some router, switch, etc. What I am doing wrong? +B<Q>: I can not get the method C<system>, C<capture>, etc., to work +when connecting to some router, switch, etc. What I am doing wrong? 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 finnish the channel is closed. It +run some given command and when it finish the channel is closed. It is what you get, for instance, when you run something as... $ ssh my.unix.box cat foo.txt @@ -4048,16 +4245,16 @@ streams redirected to the local ones so that the user can transparently interact with it. Some devices (as probably the one you are using) do not run an -standard, general purpose shell (i.e. C<bash>, C<csh> or C<ksh>) but +standard, general purpose shell (e.g. C<bash>, C<csh> or C<ksh>) but some custom program specially targeted and limited to the task of configuring the device. Usually, the SSH server running on these devices does not support -command mode. It unconditionally attachs the restricted shell to any +command mode. It unconditionally attaches the restricted shell to any incoming SSH connection and waits for the user to enter commands through the redirected stdin stream. -The only way to workaround this limitation is to make your script talk +The only way to work-around this limitation is to make your script talk to the restricted shell (1-open a new SSH session, 2-wait for the shell prompt, 3-send a command, 4-read the output until you get to the shell prompt again, repeat from 3). The best tool for this task is @@ -4072,16 +4269,16 @@ probably the best option. B<Q>: I am unable to make the module connect to the remote host... -B<A>: Have you read the trubleshooting section? (see +B<A>: Have you read the troubleshooting section? (see L</TROUBLESHOOTING>). =item Disable StrictHostKeyChecking -B<Q>: Why don't you run C<ssh> with C<StrictHostKeyChecking=no>? +B<Q>: Why is C<ssh> not run with C<StrictHostKeyChecking=no>? B<A>: Using C<StrictHostKeyChecking=no> relaxes the default security level of SSH and it will be relatively easy to end with a -misconfigured SSH (for instance, when C<known_hosts> is unwriteable) +misconfigured SSH (for instance, when C<known_hosts> is unwritable) that could be forged to connect to a bad host in order to perform man-in-the-middle attacks, etc. @@ -4114,7 +4311,7 @@ B<Q>: Calls to C<system>, C<capture>, etc. fail with the previous error, what's happening? B<A>: The reported stdio stream is closed or is not attached to a real -file handle (i.e. it is a tied handle). Redirect it to C</dev/null> or +file handle (e.g. it is a tied handle). Redirect it to C</dev/null> or to a real file: my $out = $ssh->capture({stdin_discard => 1, stderr_to_stdout => 1}, @@ -4148,7 +4345,7 @@ AIX and probably some other unixen, also bundle SSH clients lacking the multiplexing functionality and require installation of the real OpenSSH. -=item Can't change working directory +=item Can not change working directory B<Q>: I want to run some command inside a given remote directory but I am unable to change the working directory. For instance: @@ -4163,7 +4360,7 @@ What am I doing wrong? B<A>: Net::OpenSSH (and, for that matter, all the SSH modules available from CPAN but L<Net::SSH::Expect>) runs every command in a new session so most shell builtins that are run for its side effects -become useless (i.e. C<cd>, C<export>, C<ulimit>, C<umask>, etc., +become useless (e.g. C<cd>, C<export>, C<ulimit>, C<umask>, etc., usually, you can list them running help from the shell). A work around is to combine several commands in one, for instance: @@ -4195,7 +4392,7 @@ Also, it may be possible to demonize the remote program. If it is written in Perl you can use L<App::Daemon> for that (actually, there are several CPAN modules that provided that kind of functionality). -In any case, note that you shouldn't use L</spawn> for that. +In any case, note that you should not use L</spawn> for that. =item MaxSessions server limit reached @@ -4207,7 +4404,7 @@ password. B<A>: When the slave SSH client gets a response from the remote servers saying that the maximum number of sessions for the current -connection has been reached, it fallbacks to open a new direct +connection has been reached, it fall backs to open a new direct connection without going through the multiplexing socket. To stop that for happening, the following hack can be used: @@ -4301,32 +4498,49 @@ Net::OpenSSH to handle the connections. =head1 BUGS AND SUPPORT -Support for the gateway feature is highly experimental. +=head2 Experimental features + +Support for the setpgrp feature is highly experimental. + +Support for the gateway feature is highly experimental and mostly stalled. Support for data encoding is experimental. Support for taint mode is experimental. -Tested on Linux, OpenBSD, NetBSD and Solaris with OpenSSH 5.1 to 5.9. +=head2 Known issues Net::OpenSSH does not work on Windows. OpenSSH multiplexing feature requires passing file handles through sockets, something that is not supported by any version of Windows. -It doesn't work on VMS either... well, probably, it doesn't work on +It does not work on VMS either... well, probably, it does not work on anything not resembling a modern Linux/Unix OS. +Old versions of OpenSSH C<ssh> may leave stdio streams in non-blocking +mode. That can result on failures when writing to C<STDOUT> or +C<STDERR> after using the module. In order to work-around this issue, +Perl L<perlfunc/fcntl> can be used to unset the non-blocking flag: + + use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK); + my $flags = fcntl(STDOUT, F_GETFL, 0); + fcntl(STDOUT, F_SETFL, $flags & ~O_NONBLOCK); + +=head2 Git repository + +The source code of this module is hosted at GitHub: +L<http://github.com/salva/p5-Net-OpenSSH>. + +=head2 Reporting bugs and asking for help + To report bugs send an email to the address that appear below or use the CPAN bug tracking system at L<http://rt.cpan.org>. -B<Post questions related to how to use the module in Perlmonks> +B<Post questions related to how to use the module in PerlMonks> L<http://perlmonks.org/>, you will probably get faster responses than -if you address me directly and I visit Perlmonks quite often, so I +if you address me directly and I visit PerlMonks quite often, so I will see your question anyway. -The source code of this module is hosted at GitHub: -L<http://github.com/salva/p5-Net-OpenSSH>. - =head2 Commercial support Commercial support, professional services and custom software @@ -4336,17 +4550,18 @@ requirements and we will get back to you ASAP. =head2 My wishlist -If you like this module and you're feeling generous, take a look at my -Amazon Wish List: L<http://amzn.com/w/1WU1P6IR5QZ42>. +If you like this module and you are feeling generous, take a look at +my Amazon Wish List: L<http://amzn.com/w/1WU1P6IR5QZ42>. Also consider contributing to the OpenSSH project this module builds upon: L<http://www.openssh.org/donations.html>. =head1 TODO -- *** add tests for scp, rsync and sftp methods +- *** add tests for C<scp_*>, C<rsync_*> and C<sftp> methods -- *** add support for more target OSs (quoting, OpenVMS, Windows & others) +- *** add support for more target operating systems (quoting, OpenVMS, + Windows & others) - better timeout handling in system and capture methods @@ -4363,11 +4578,13 @@ upon: L<http://www.openssh.org/donations.html>. - add proper shell quoting for Windows (see L<http://blogs.msdn.com/b/twistylittlepassagesallalike/archive/2011/04/23/everyone-quotes-arguments-the-wrong-way.aspx>). +- refactor open_ex support for multiple commands, maybe just keeping tunnel, ssh and raw + Send your feature requests, ideas or any feedback, please! =head1 COPYRIGHT AND LICENSE -Copyright (C) 2008-2013 by Salvador FandiE<ntilde>o +Copyright (C) 2008-2014 by Salvador FandiE<ntilde>o (sfandino@yahoo.com) This library is free software; you can redistribute it and/or modify diff --git a/lib/Net/OpenSSH/ModuleLoader.pm b/lib/Net/OpenSSH/ModuleLoader.pm new file mode 100644 index 0000000..149a517 --- /dev/null +++ b/lib/Net/OpenSSH/ModuleLoader.pm @@ -0,0 +1,35 @@ +package Net::OpenSSH::ModuleLoader; + +use strict; +use warnings; +use Carp; + +our %loaded_module; + +use Exporter qw(import); +our @EXPORT = qw(_load_module); + +sub _load_module { + my ($module, $version) = @_; + $loaded_module{$module} ||= do { + my $err; + do { + local ($@, $SIG{__DIE__}); + my $ok = eval "require $module; 1"; + $err = $@; + $ok; + } or croak "unable to load Perl module $module: $err"; + }; + if (defined $version) { + my $mv = do { + local ($@, $SIG{__DIE__}); + eval "\$${module}::VERSION"; + } || 0; + (my $mv1 = $mv) =~ s/_\d*$//; + croak "$module version $version required, $mv is available" + if $mv1 < $version; + } + 1 +} + +1; diff --git a/lib/Net/OpenSSH/OSTracer.pm b/lib/Net/OpenSSH/OSTracer.pm index 0742521..6593c41 100644 --- a/lib/Net/OpenSSH/OSTracer.pm +++ b/lib/Net/OpenSSH/OSTracer.pm @@ -116,9 +116,9 @@ Net::OpenSSH::OSTracer - trace ssh master process at the OS level =head1 DESCRIPTION This is a Net::OpenSSH helper module that allows you to trace the -master ssh process at the operating system level using the proper -utility available in your system (i.e, strace, truss, ktruss, tusc, -etc.). +master C<ssh> process at the operating system level using the proper +utility available in your system (e.g., C<strace>, C<truss>, +C<ktruss>, C<tusc>, etc.). This feature can be used when debugging your programs or to report bugs on the module. @@ -127,7 +127,7 @@ It is enabled setting the flag 512 on the C<$Net::OpenSSH::debug> variable: $Net::OpenSSH::debug |= 512; -By default the ouput files of the tracer are saved as +By default the output files of the tracer are saved as C</tmp/net_openssh_master.$pid.$tracer_type>. Also, the output send by the tracer to stdout/stderr is saved as @@ -140,22 +140,22 @@ The module can be configured through the following global variables: =item $Net::OpenSSH::OSTracer::type By default, the module decides which tracer to use in base to the -operative system name. This variable allows to select a different +operating system name. This variable allows one to select a different tracer. -Currently accepted types are: strace (linux), ktrace (*bsd), tusc -(hp-ux) and truss (solaris and aix). +Currently accepted types are: C<strace> (Linux), C<ktrace> (*BSD), +C<tusc> (HP-UX) and C<truss> (Solaris and AIX). =item $Net::OpenSSH::OSTracer::cmd -Command to execute for tracing the ssh process. +Command to execute for tracing the C<ssh> process. -By default, it inferres it from the tracer type selected. +By default, it infers it from the tracer type selected. =item $Net::OpenSSH::OSTracer::output -Basename for the destination file. The PID of the ssh process and the -tracer type will be appended. +Basename for the destination file. The PID of the C<ssh> process and +the tracer type will be appended. =item $Net::OpenSSH::OSTracer::sudo @@ -175,7 +175,7 @@ variable C<SUDO_ASKPASS>. For instance: =item $Net::OpenSSH::OSTracer::delay -This variable can be used to delay the ssh execution so that the +This variable can be used to delay the C<ssh> execution so that the tracer can attach the process first. This is specially handy when using C<sudo> with a password. diff --git a/lib/Net/OpenSSH/SSH.pm b/lib/Net/OpenSSH/SSH.pm new file mode 100644 index 0000000..fb0449c --- /dev/null +++ b/lib/Net/OpenSSH/SSH.pm @@ -0,0 +1,19 @@ +package Net::OpenSSH::SSH; + +1; + +__END__ + +=head1 NAME + +Net::OpenSSH::SSH - Perl SSH client package implemented on top of OpenSSH + +=head1 DESCRIPTION + +Use the real thing: L<Net::OpenSSH>. + +This namespace is used so that the module gets indexed under the +C<SSH> tag on popular CPAN search engines such as +L<http://metacpan.org> and L<http://search.cpan.org>. + +=cut diff --git a/lib/Net/OpenSSH/ShellQuoter.pm b/lib/Net/OpenSSH/ShellQuoter.pm new file mode 100644 index 0000000..e9939d6 --- /dev/null +++ b/lib/Net/OpenSSH/ShellQuoter.pm @@ -0,0 +1,36 @@ +package Net::OpenSSH::ShellQuoter; + +use strict; +use warnings; +use Carp; + +use Net::OpenSSH::ModuleLoader; + +my %alias = (bash => 'POSIX', + sh => 'POSIX', + ksh => 'POSIX', + ash => 'POSIX', + dash => 'POSIX', + pdksh => 'POSIX', + mksh => 'POSIX', + zsh => 'POSIX', + tcsh => 'csh'); + +sub quoter { + my ($class, $shell) = @_; + $shell = 'POSIX' unless defined $shell; + return $shell if ref $shell; + if ($shell =~ /,/) { + require Net::OpenSSH::ShellQuoter::Chain; + return Net::OpenSSH::ShellQuoter::Chain->chain(split /\s*,\s*/, $shell); + } + else { + $shell = $alias{$shell} if defined $alias{$shell}; + $shell =~ /^\w+$/ or croak "bad quoting style $shell"; + my $impl = "Net::OpenSSH::ShellQuoter::$shell"; + _load_module($impl); + return $impl->new; + } +} + +1; diff --git a/lib/Net/OpenSSH/ShellQuoter/Chain.pm b/lib/Net/OpenSSH/ShellQuoter/Chain.pm new file mode 100644 index 0000000..a68692a --- /dev/null +++ b/lib/Net/OpenSSH/ShellQuoter/Chain.pm @@ -0,0 +1,38 @@ +package Net::OpenSSH::ShellQuoter::Chain; + +use strict; +use warnings; + +use Net::OpenSSH::ShellQuoter; + +sub chain { + my $class = shift; + my @quoters = map Net::OpenSSH::ShellQuoter->quoter($_), reverse @_; + my $self = \@quoters; + bless $self, $class; + $self; +} + +sub quote { + my ($self, $arg) = @_; + $arg = $_->quote($arg) for @$self; + $arg; +} + +sub quote_glob { + my ($self, $arg) = @_; + if (@$self) { + $arg = $self->[0]->quote_glob($arg); + $arg = $self->[$_]->quote($arg) for 1..$#$self; + } + $arg +} + +sub shell_fragments { + my $self = shift; + @$self or return (wantarray ? () : ''); + $self->[-1]->shell_fragments(@_) +} + + +1; diff --git a/lib/Net/OpenSSH/ShellQuoter/MSCmd.pm b/lib/Net/OpenSSH/ShellQuoter/MSCmd.pm new file mode 100644 index 0000000..04732f2 --- /dev/null +++ b/lib/Net/OpenSSH/ShellQuoter/MSCmd.pm @@ -0,0 +1,69 @@ +package Net::OpenSSH::ShellQuoter::MSCmd; + +use strict; +use warnings; +use Carp; + +sub new { shift() } + +sub quote { + shift; + my $arg = shift; + if ($arg =~ /[\r\n\0]/) { + croak "can't quote newlines to pass through MS cmd.exe"; + } + $arg =~ s/([()%!^"<>&|])/^$1/g; + $arg; +} + +*quote_glob = \"e; + +my %fragments = ( stdin_discard => '<NUL:', + stdout_discard => '>NUL:', + stderr_discard => '2>NUL:', + stdout_and_stderr_discard => '>NUL: 2>&1', + stderr_to_stdout => '2>&1' ); + +sub shell_fragments { + shift; + my @f = grep defined, @fragments{@_}; + wantarray ? @f : join(' ', @f); +} + +1; + +__END__ + +=head1 NAME + +Net::OpenSSH::ShellQuoter::MSCmd - Quoter for Windows cmd.exe + +=head1 DESCRIPTION + +This quoter is intended for interaction with SSH servers running on +Windows which invoke the requested commands through the C<cmd.exe> shell. + +Because of C<cmd.exe> not doing wildcard expansion (on Windows this +task is left to the final command), glob quoting just quotes +everything. + +Some Windows servers use C<Win32::CreateProcess> to run the C<cmd.exe> +shell which runs the requested command. In that case, both the C<MSCmd> +and C<MSWin> quoters have to be chained (and BTW, order matters): + + $ssh = Net::OpenSSH->new(..., + remote_shell => 'MSCmd,MSWin'); + +Actually, C<cmd.exe> may require not quoting at all when the requested +command is a builtin (for instance, C<echo>). + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2008-2014 by Salvador FandiE<ntilde>o +(sfandino@yahoo.com) + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.10.0 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/lib/Net/OpenSSH/ShellQuoter/MSWin.pm b/lib/Net/OpenSSH/ShellQuoter/MSWin.pm new file mode 100644 index 0000000..34a789d --- /dev/null +++ b/lib/Net/OpenSSH/ShellQuoter/MSWin.pm @@ -0,0 +1,53 @@ +package Net::OpenSSH::ShellQuoter::MSWin; + +use strict; +use warnings; +use Carp; + +sub new { shift() } + +sub quote { + shift; + my $arg = shift; + if ($arg eq '') { + return '""'; + } + if ($arg =~ /[ \t\n\x0b"]/) { + $arg =~ s{(\\+)(?="|\z)}{$1$1}g; + $arg =~ s{"}{\\"}g; + return qq("$arg"); + } + return $arg; +} + +*quote_glob = \"e; + +sub shell_fragments { wantarray ? () : '' } + +1; + +__END__ + +=head1 NAME + +Net::OpenSSH::ShellQuoter::MSWin - Quoter for Win32::CreateProcess + +=head1 DESCRIPTION + +This quoter is intended for interaction with SSH servers running on +Windows which use the C<Win32::CreateProcess> system call to launch the +requested command. + +Because of C<Win32::CreateProcess> not doing wildcard expansion, glob +quoting just quotes everything. + +=head1 COPYRIGHT AND LICENSE + +Copyright (C) 2008-2014 by Salvador FandiE<ntilde>o +(sfandino@yahoo.com) + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself, either Perl version 5.10.0 or, +at your option, any later version of Perl 5 you may have available. + +=cut diff --git a/lib/Net/OpenSSH/ShellQuoter/POSIX.pm b/lib/Net/OpenSSH/ShellQuoter/POSIX.pm new file mode 100644 index 0000000..21f6125 --- /dev/null +++ b/lib/Net/OpenSSH/ShellQuoter/POSIX.pm @@ -0,0 +1,66 @@ +package Net::OpenSSH::ShellQuoter::POSIX; + +use strict; +use warnings; +use Carp; + +sub new { __PACKAGE__ } + +my $noquote_class = '.\\w/\\-@,:'; +my $glob_class = '*?\\[\\],{}:!^~'; + +sub quote { + shift; + my $quoted = join '', + map { ( m|\A'\z| ? "\\'" : + m|\A'| ? "\"$_\"" : + m|\A[$noquote_class]+\z|o ? $_ : + "'$_'" ) + } split /('+)/, $_[0]; + length $quoted ? $quoted : "''"; +} + + +sub quote_glob { + shift; + my $arg = shift; + my @parts; + while ((pos $arg ||0) < length $arg) { + if ($arg =~ m|\G('+)|gc) { + push @parts, (length($1) > 1 ? "\"$1\"" : "\\'"); + } + elsif ($arg =~ m|\G([$noquote_class$glob_class]+)|gco) { + push @parts, $1; + } + elsif ($arg =~ m|\G(\\[$glob_class\\])|gco) { + push @parts, $1; + } + elsif ($arg =~ m|\G\\|gc) { + push @parts, '\\\\' + } + elsif ($arg =~ m|\G([^$glob_class\\']+)|gco) { + push @parts, "'$1'"; + } + else { + require Data::Dumper; + $arg =~ m|\G(.+)|gc; + die "Internal error: unquotable string:\n". Data::Dumper::Dumper($1) ."\n"; + } + } + my $quoted = join('', @parts); + length $quoted ? $quoted : "''"; +} + +my %fragments = ( stdin_discard => '</dev/null', + stdout_discard => '>/dev/null', + stderr_discard => '2>/dev/null', + stdout_and_stderr_discard => '>/dev/null 2>&1', + stderr_to_stdout => '2>&1' ); + +sub shell_fragments { + shift; + my @f = grep defined, @fragments{@_}; + wantarray ? @f : join(' ', @f); +} + +1; diff --git a/lib/Net/OpenSSH/ShellQuoter/csh.pm b/lib/Net/OpenSSH/ShellQuoter/csh.pm new file mode 100644 index 0000000..f4cfe96 --- /dev/null +++ b/lib/Net/OpenSSH/ShellQuoter/csh.pm @@ -0,0 +1,70 @@ +package Net::OpenSSH::ShellQuoter::csh; + +use strict; +use warnings; +use Carp; + +# Fixme: copied from POSIX + +sub new { __PACKAGE__ } + +my $noquote_class = q(.\\w/\\-@,:); +my $glob_class = q(*?\\[\\],{}:!^~); +my $escape_inside_single_quotes_class = q(\!\n); + +sub _single_quote { + my $arg = shift; + $arg =~ s/([$escape_inside_single_quotes_class])/\\$1/go; + "'$arg'" +} + +sub quote { + shift; + my $quoted = join '', + map { ( m|\A'\z| ? "\\'" : + m|\A'| ? "\"$_\"" : + m|\A[$noquote_class]*\z|o ? $_ : + _single_quote($_) ) + } split /(')/o, $_[0]; + length $quoted ? $quoted : "''"; +} + + +sub quote_glob { + shift; + my $arg = shift; + my @parts; + while ((pos $arg ||0) < length $arg) { + if ($arg =~ m|\G('+)|gc) { + push @parts, (length($1) > 1 ? "\"$1\"" : "\\'"); + } + elsif ($arg =~ m|\G([$noquote_class$glob_class]+)|gco) { + push @parts, $1; + } + elsif ($arg =~ m|\G(\\[$glob_class\\])|gco) { + push @parts, $1; + } + elsif ($arg =~ m|\G([^$glob_class\\']+)|gco) { + push @parts, _single_quote($1); + } + else { + require Data::Dumper; + $arg =~ m|\G(.+)|gc; + die "Internal error: unquotable string:\n". Data::Dumper::Dumper($1) ."\n"; + } + } + my $quoted = join('', @parts); + length $quoted ? $quoted : "''"; +} + +my %fragments = ( stdin_discard => '</dev/null', + stdout_discard => '>/dev/null', + stdout_and_stderr_discard => '>&/dev/null' ); + +sub shell_fragments { + shift; + my @f = grep defined, @fragments{@_}; + wantarray ? @f : join(' ', @f); +} + +1; |