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   371 use strict;
  1         1  
  1         22  
4 1     1   3 use warnings;
  1         1  
  1         20  
5 1     1   2 use feature 'say';
  1         1  
  1         45  
6 1     1   3 use Data::Dumper;
  1         1  
  1         31  
7 1     1   3 use Carp;
  1         5  
  1         51  
8              
9 1     1   688 BEGIN { *debug = \$Net::SSH::Any::Test::Isolated::debug }
10             our $debug;
11              
12             sub _debug {
13 112     112   117 my $self = shift;
14 112 50       239 print STDERR "$self->{side}> " . join(': ', @_) . "\n" if $debug;
15             }
16              
17             sub _new {
18 3     3   6 my ($class, $side, $in, $out) = @_;
19 3         10 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         14 say {$self->{out}} $packet;
  15         111  
30             }
31              
32             sub _recv {
33 47     47   54 my $self = shift;
34 47         103 $self->_debug("waiting for data");
35 47         54 my $in = $self->{in};
36 47   50     348525 my $packet = <$in> // return;
37 47         349 $packet =~ s/[\r\n]+$//;
38 47         158 $self->_debug(recv => $packet);
39 47         115 $packet;
40             }
41              
42             sub _serialize {
43 9     9   11 my $self = shift;
44 9         54 my $dump = Data::Dumper->new([\@_], ['D']);
45 9         277 $dump->Terse(1)->Indent(0)->Useqq(1);
46 9         152 my $data = $dump->Dump;
47             # $self->_debug("serialized $data");
48 9         218 $data;
49             }
50              
51             sub _deserialize {
52 38     38   32 my $self = shift;
53 38         27 my ($r, $err);
54 38         26 do {
55 38         190 local ($@, $SIG{__DIE__});
56             #$self->_debug("deserializing $_[0]");
57 38   50     2422 $r = eval $_[0] // [];
58 38         181 $err = $@;
59             };
60 38 50       63 die $err if $err;
61             # $self->_debug("deserialized args", Dumper($r));
62 38 50       124 wantarray ? @$r : $r->[0];
63             }
64              
65             sub _recv_packet {
66 18     18   20 my $self = shift;
67 18         19 while (1) {
68 47   50     92 my $packet = $self->_recv // return;
69 47 100       276 if (my ($head, $args) = $packet =~ /^(\w+):\s+(.*)$/) {
    50          
    0          
70 38         74 my @args = $self->_deserialize($args);
71 38 100       77 if ($head eq 'log') {
72 29         92 $self->_log(@args);
73 29         3072 redo;
74             }
75 9         44 return ($head, @args);
76             }
77             elsif ($packet =~ /^\w+!$/) {
78 9         41 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   12 my $self = shift;
92 9         12 my $head = shift;
93 9         31 my $args = $self->_serialize(@_);
94 9         30 $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   11 my ($self, $state) = @_;
104 6 50       19 $self->{state} eq $state or croak "invalid state for action, current state: $self->{state}, expected: $state";
105             }
106              
107             1;