line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Net::SSH::Any::Test::Isolated::_Base; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
382
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
21
|
|
4
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
21
|
|
5
|
1
|
|
|
1
|
|
3
|
use feature 'say'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
72
|
|
6
|
1
|
|
|
1
|
|
6
|
use Data::Dumper; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
55
|
|
7
|
1
|
|
|
1
|
|
4
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
51
|
|
8
|
|
|
|
|
|
|
|
9
|
1
|
|
|
1
|
|
613
|
BEGIN { *debug = \$Net::SSH::Any::Test::Isolated::debug } |
10
|
|
|
|
|
|
|
our $debug; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub _debug { |
13
|
80
|
|
|
80
|
|
87
|
my $self = shift; |
14
|
80
|
50
|
|
|
|
163
|
print STDERR "$self->{side}> " . join(': ', @_) . "\n" if $debug; |
15
|
|
|
|
|
|
|
} |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
sub _new { |
18
|
3
|
|
|
3
|
|
5
|
my ($class, $side, $in, $out) = @_; |
19
|
3
|
|
|
|
|
12
|
my $self = { side => $side, |
20
|
|
|
|
|
|
|
in => $in, |
21
|
|
|
|
|
|
|
out => $out, |
22
|
|
|
|
|
|
|
state => 'new'}; |
23
|
3
|
|
|
|
|
9
|
bless $self, $class; |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub _send { |
27
|
15
|
|
|
15
|
|
22
|
my ($self, $packet) = @_; |
28
|
15
|
|
|
|
|
35
|
$self->_debug(send => $packet); |
29
|
15
|
|
|
|
|
18
|
say {$self->{out}} $packet; |
|
15
|
|
|
|
|
150
|
|
30
|
|
|
|
|
|
|
} |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub _recv { |
33
|
31
|
|
|
31
|
|
29
|
my $self = shift; |
34
|
31
|
|
|
|
|
48
|
$self->_debug("waiting for data"); |
35
|
31
|
|
|
|
|
30
|
my $in = $self->{in}; |
36
|
31
|
|
50
|
|
|
271575
|
my $packet = <$in> // return; |
37
|
31
|
|
|
|
|
216
|
$packet =~ s/[\r\n]+$//; |
38
|
31
|
|
|
|
|
108
|
$self->_debug(recv => $packet); |
39
|
31
|
|
|
|
|
359
|
$packet; |
40
|
|
|
|
|
|
|
} |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
sub _serialize { |
43
|
9
|
|
|
9
|
|
18
|
my $self = shift; |
44
|
9
|
|
|
|
|
66
|
my $dump = Data::Dumper->new([\@_], ['D']); |
45
|
9
|
|
|
|
|
322
|
$dump->Terse(1)->Indent(0)->Useqq(1); |
46
|
9
|
|
|
|
|
171
|
my $data = $dump->Dump; |
47
|
|
|
|
|
|
|
# $self->_debug("serialized $data"); |
48
|
9
|
|
|
|
|
246
|
$data; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
sub _deserialize { |
52
|
22
|
|
|
22
|
|
28
|
my $self = shift; |
53
|
22
|
|
|
|
|
20
|
my ($r, $err); |
54
|
22
|
|
|
|
|
20
|
do { |
55
|
22
|
|
|
|
|
89
|
local ($@, $SIG{__DIE__}); |
56
|
|
|
|
|
|
|
#$self->_debug("deserializing $_[0]"); |
57
|
22
|
|
50
|
|
|
1488
|
$r = eval $_[0] // []; |
58
|
22
|
|
|
|
|
105
|
$err = $@; |
59
|
|
|
|
|
|
|
}; |
60
|
22
|
50
|
|
|
|
41
|
die $err if $err; |
61
|
|
|
|
|
|
|
# $self->_debug("deserialized args", Dumper($r)); |
62
|
22
|
50
|
|
|
|
74
|
wantarray ? @$r : $r->[0]; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
sub _recv_packet { |
66
|
18
|
|
|
18
|
|
25
|
my $self = shift; |
67
|
18
|
|
|
|
|
18
|
while (1) { |
68
|
31
|
|
50
|
|
|
51
|
my $packet = $self->_recv // return; |
69
|
31
|
100
|
|
|
|
202
|
if (my ($head, $args) = $packet =~ /^(\w+):\s+(.*)$/) { |
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
70
|
22
|
|
|
|
|
58
|
my @args = $self->_deserialize($args); |
71
|
22
|
100
|
|
|
|
45
|
if ($head eq 'log') { |
72
|
13
|
|
|
|
|
54
|
$self->_log(@args); |
73
|
13
|
|
|
|
|
4078
|
redo; |
74
|
|
|
|
|
|
|
} |
75
|
9
|
|
|
|
|
39
|
return ($head, @args); |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
elsif ($packet =~ /^\w+!$/) { |
78
|
9
|
|
|
|
|
54
|
return $packet |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
elsif ($packet =~ /^\s*(?:#.*)?$/) { |
81
|
|
|
|
|
|
|
# Ignore blank lines and comments. |
82
|
|
|
|
|
|
|
} |
83
|
|
|
|
|
|
|
else { |
84
|
0
|
|
|
|
|
0
|
$self->_debug("unexpected data packet: $packet"); |
85
|
0
|
|
|
|
|
0
|
die "Internal error: unexpected data packet $packet"; |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
} |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub _send_packet { |
91
|
9
|
|
|
9
|
|
16
|
my $self = shift; |
92
|
9
|
|
|
|
|
10
|
my $head = shift; |
93
|
9
|
|
|
|
|
23
|
my $args = $self->_serialize(@_); |
94
|
9
|
|
|
|
|
40
|
$self->_send("$head: $args"); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub _log { |
98
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
99
|
0
|
|
|
|
|
0
|
print STDERR join(': ', log => @_); |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
sub _check_state { |
103
|
6
|
|
|
6
|
|
13
|
my ($self, $state) = @_; |
104
|
6
|
50
|
|
|
|
20
|
$self->{state} eq $state or croak "invalid state for action, current state: $self->{state}, expected: $state"; |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
1; |