File Coverage

blib/lib/Net/SSH/Any/Test/Isolated/_Base.pm
Criterion Covered Total %
statement 61 65 93.8
branch 9 16 56.2
condition 3 6 50.0
subroutine 15 16 93.7
pod n/a
total 88 103 85.4


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;