Commit | Line | Data |
47c83a13 |
1 | package Object::Remote::Connector::SSH; |
2 | |
84b04178 |
3 | use Object::Remote::ModuleSender; |
8ba4f2e3 |
4 | use Object::Remote::Handle; |
47c83a13 |
5 | use Moo; |
6 | |
a9fdb55e |
7 | with 'Object::Remote::Role::Connector::PerlInterpreter'; |
47c83a13 |
8 | |
fbd3b8ec |
9 | has ssh_to => (is => 'ro', required => 1); |
10 | |
498c4ad5 |
11 | has ssh_perl_command => (is => 'lazy'); |
12 | |
6ec765ba |
13 | has ssh_options => (is => 'ro', default => sub { [ '-A' ] }); |
14 | |
15 | has ssh_command => (is => 'ro', default => sub { 'ssh' }); |
16 | |
161fe284 |
17 | sub _escape_shell_arg { |
18 | my ($self, $str) = (@_); |
19 | $str =~ s/((?:^|[^\\])(?:\\\\)*)'/$1\\'/g; |
20 | return "$str"; |
21 | } |
22 | |
23 | |
498c4ad5 |
24 | sub _build_ssh_perl_command { |
25 | my ($self) = @_; |
161fe284 |
26 | my $perl_command = join('', @{$self->perl_command}); |
27 | |
28 | #TODO non-trivial to escape properly for ssh and shell |
29 | #this "works" but is not right, needs to be replaced |
30 | #after testing |
6ec765ba |
31 | return [ |
32 | do { my $c = $self->ssh_command; ref($c) ? @$c : $c }, |
33 | @{$self->ssh_options}, $self->ssh_to, |
161fe284 |
34 | $self->_escape_shell_arg($perl_command), |
6ec765ba |
35 | ]; |
498c4ad5 |
36 | } |
37 | |
38 | sub final_perl_command { shift->ssh_perl_command } |
84b04178 |
39 | |
7efea51f |
40 | no warnings 'once'; |
41 | |
84b04178 |
42 | push @Object::Remote::Connection::Guess, sub { |
43 | for ($_[0]) { |
44 | # 0-9 a-z _ - first char, those or . subsequent - hostnamish |
a9fdb55e |
45 | if (defined and !ref and /^(?:.*?\@)?[\w\-][\w\-\.]/) { |
69aaad21 |
46 | my $host = shift(@_); |
47 | return __PACKAGE__->new(@_, ssh_to => $host); |
84b04178 |
48 | } |
49 | } |
50 | return; |
51 | }; |
52 | |
47c83a13 |
53 | 1; |