File Coverage

blib/lib/Net/OpenSSH/Compat/Perl.pm
Criterion Covered Total %
statement 24 127 18.9
branch 1 52 1.9
condition 2 12 16.6
subroutine 8 24 33.3
pod 1 8 12.5
total 36 223 16.1


line stmt bran cond sub pod time code
1             package Net::OpenSSH::Compat::Perl;
2              
3             our $VERSION = '0.08';
4              
5 1     1   12933 use strict;
  1         1  
  1         24  
6 1     1   3 use warnings;
  1         1  
  1         21  
7 1     1   2 use Carp ();
  1         2  
  1         10  
8              
9 1     1   926 use Net::OpenSSH;
  1         26574  
  1         39  
10 1     1   9 use Net::OpenSSH::Constants qw(OSSH_MASTER_FAILED OSSH_SLAVE_CMD_FAILED);
  1         2  
  1         221  
11              
12             require Exporter;
13             our @ISA = qw(Exporter);
14             our @CARP_NOT = qw(Net::OpenSSH);
15              
16             my $supplant;
17             my $session_id = 1;
18              
19             our %DEFAULTS = ( session => [protocol => 2,
20             strict_host_key_checking => 'no'],
21             connection => [] );
22              
23             sub import {
24 1     1   8 my $class = shift;
25 1 50 33     11 if (!$supplant and
      33        
26             $class eq __PACKAGE__ and
27             grep($_ eq ':supplant', @_)) {
28 0         0 $supplant = 1;
29 0         0 for my $end ('') { #, qw(Channel SFTP Dir File)) {
30 0         0 my $this = __PACKAGE__;
31 0         0 my $pkg = "Net::SSH::Perl";
32 0         0 my $file = "Net/SSH/Perl";
33 0 0       0 if ($end) {
34 0         0 $this .= "::$end";
35 0         0 $pkg .= "::$end";
36 0         0 $file .= "/$end";
37             }
38 0         0 $INC{$file . '.pm'} = __FILE__;
39 1     1   5 no strict 'refs';
  1         1  
  1         729  
40 0         0 @{"${pkg}::ISA"} = ($this);
  0         0  
41 0         0 ${"${pkg}::VERSION"} = __PACKAGE__->version;
  0         0  
42             }
43             }
44 1         69 __PACKAGE__->export_to_level(1, $class,
45             grep $_ ne ':supplant', @_);
46             }
47              
48 0     0 1   sub version { "1.34 (".__PACKAGE__."-$VERSION)" }
49              
50             sub new {
51 0     0 0   my $class = shift;
52 0           my $host = shift;
53 0           my $cfg = Net::OpenSSH::Compat::Perl::Config->new(@_);
54 0           my $cpt = { host => $host,
55             state => 'new',
56             cfg => $cfg,
57             session_id => $session_id++ };
58              
59 0           bless $cpt, $class;
60             }
61              
62             sub _entry_method {
63 0     0     my $n = 1;
64 0           my $last = 'unknown';
65 0           while (1) {
66 0           my $sub = (caller $n++)[3];
67 0 0         $sub =~ /^Net::OpenSSH::Compat::(?:\w+::)?(\w+)$/ or last;
68 0           $last = $1;
69             }
70 0           $last;
71             }
72              
73             sub _check_state {
74 0     0     my ($cpt, $expected) = @_;
75 0           my $state = $cpt->{state};
76 0 0         return 1 if $expected eq $state;
77 0           my $method = $cpt->_entry_method;
78 0           my $class = ref $cpt;
79 0           Carp::croak qq($class object can't do "$method" on state $state);
80             return
81 0           }
82              
83             sub _check_error {
84 0     0     my $cpt = shift;
85 0           my $ssh = $cpt->{ssh};
86 0 0 0       return if (!$ssh->error or $ssh->error == OSSH_SLAVE_CMD_FAILED);
87 0           my $method = $cpt->_entry_method;
88 0 0         $cpt->{state} = 'failed' if $ssh->error == OSSH_MASTER_FAILED;
89 0           Carp::croak "$method failed: " . $ssh->error;
90             }
91              
92             sub login {
93 0     0 0   my ($cpt, $user, $password, $suppress_shell) = @_;
94 0           $cpt->_check_state('new');
95              
96 0           $cpt->{user} = $user;
97 0 0         $cpt->{password} = '*****' if defined $password;
98 0           $cpt->{suppress_shell} = $suppress_shell;
99              
100 0           my @args = (host => $cpt->{host}, @{$DEFAULTS{connection}});
  0            
101 0 0         push @args, user => $user if defined $user;
102 0 0         push @args, password => $password if defined $password;
103              
104 0           my $cfg = $cpt->{cfg};
105 0 0         push @args, port => $cfg->{port} if defined $cfg->{port};
106 0 0         push @args, batch_mode => 1 unless $cfg->{interactive};
107              
108 0           my @more;
109 0 0         push @more, 'UsePrivilegedPort=yes' if $cfg->{privileged};
110 0 0         push @more, "Ciphers=$cfg->{ciphers}" if defined $cfg->{ciphers};
111 0 0         push @more, "Compression=$cfg->{compression}" if defined $cfg->{compression};
112 0 0         push @more, "CompressionLevel=$cfg->{compression_level}" if defined $cfg->{compression_level};
113 0 0         push @more, "StrictHostKeyChecking=$cfg->{strict_host_key_checking}" if defined $cfg->{strict_host_key_checking};
114 0 0         if ($cfg->{identity_files}) {
115 0           push @more, "IdentityFile=$_" for @{$cfg->{identity_files}};
  0            
116             }
117 0 0         if ($cfg->{options}) {
118 0           push @more, @{$cfg->{options}};
  0            
119             }
120 0           push @args, master_opts => [map { -o => $_ } @more];
  0            
121             # warn "args: @args";
122              
123 0           my $ssh = $cpt->{ssh} = Net::OpenSSH->new(@args);
124 0 0         if ($ssh->error) {
125 0           $ssh->{state} = 'failed';
126 0           $ssh->die_on_error;
127             }
128 0           $cpt->{state} = 'connected';
129             }
130              
131             sub cmd {
132 0     0 0   my ($cpt, $cmd, $stdin) = @_;
133 0           $cpt->_check_state('connected');
134 0           my $ssh = $cpt->{ssh};
135 0 0         $stdin = '' unless defined $stdin;
136 0           local $?;
137 0           my ($out, $err) = $ssh->capture2({stdin_data => $stdin}, $cmd);
138 0           $cpt->_check_error;
139 0           return ($out, $err, ($? >> 8));
140             }
141              
142             sub shell {
143 0     0 0   my $cpt = shift;
144 0           $cpt->_check_state('connected');
145 0           my $ssh = $cpt->{ssh};
146 0           my $tty = $cpt->{cfg}{use_pty};
147 0 0         $tty = 1 unless defined $tty;
148 0           $ssh->system({tty => $tty});
149             }
150              
151 0     0 0   sub config { shift->{cfg} }
152              
153 0 0   0 0   sub debug { Carp::carp("@_") if shift->{cfg}{debug} }
154              
155 0     0 0   sub session_id { shift->{session_id} }
156              
157             my $make_missing_methods = sub {
158             my $pkg = caller;
159             my $faked = $pkg;
160             $faked =~ s/^Net::OpenSSH::Compat::/Net::SSH::/;
161             for (@_) {
162             my $name = $_;
163 1     1   5 no strict 'refs';
  1         1  
  1         281  
164             *{$pkg.'::'.$name} = sub {
165 0     0     Carp::croak("method ${faked}::$name is not implemented by $pkg, report a bug if you want it supported!");
166             }
167             }
168             };
169              
170             $make_missing_methods->(qw(register_handler
171             sock
172             incomming_data
173             packet_start));
174              
175             package Net::OpenSSH::Compat::Perl::Config;
176              
177             my %option_perl2openssh = qw(protocol proto);
178              
179             sub new {
180 0     0     my $class = shift;
181 0           my %opts = (@{$DEFAULTS{session}}, @_);
  0            
182 0           my %cfg = map { my $v = delete $opts{$_};
  0            
183 0   0       my $name = $option_perl2openssh{$_} || $_;
184 0 0         defined $v ? ($name, $v) : () } qw(port protocol debug interactive
185             privileged identity_files cipher
186             ciphers compression
187             compression_level use_pty
188             options strict_host_key_checking);
189              
190 0 0         %opts and Carp::croak "unsupported configuration option(s) given: ".join(", ", keys %opts);
191 0 0         $cfg{proto} =~ /\b2\b/ or Carp::croak "Unsupported protocol version requested $cfg{proto}";
192              
193 0           bless \%cfg, $class;
194             }
195              
196 0     0     sub get { $_[0]->{$_[1]} }
197              
198             sub set {
199 0     0     my ($cfg, $k, $v) = @_;
200 0 0         $cfg->{$k} = $v if @_ == 3;
201 0           $cfg->{$k};
202             }
203              
204       0     sub DESTROY {};
205              
206             $make_missing_methods->(qw(read_config merge_directive AUTOLOAD));
207              
208             1;
209              
210             __END__