File Coverage

blib/lib/Net/IMP/Remote.pm
Criterion Covered Total %
statement 46 97 47.4
branch 1 30 3.3
condition 0 10 0.0
subroutine 15 27 55.5
pod 5 5 100.0
total 67 169 39.6


line stmt bran cond sub pod time code
1 1     1   3113 use strict;
  1         3  
  1         36  
2 1     1   6 use warnings;
  1         3  
  1         55  
3              
4             package Net::IMP::Remote;
5 1     1   6 use base 'Net::IMP::Base';
  1         2  
  1         638  
6 1     1   10233 use fields qw(factory pid interface);
  1         3  
  1         7  
7 1     1   817 use Net::IMP::Remote::Client;
  1         3  
  1         43  
8 1     1   659 use Net::IMP::Remote::Connection;
  1         4  
  1         44  
9 1     1   10 use Net::IMP::Remote::Protocol;
  1         3  
  1         78  
10 1     1   762 use IO::Socket::INET;
  1         23256  
  1         9  
11 1     1   573 use IO::Socket::UNIX;
  1         3  
  1         8  
12 1     1   830 use Net::IMP::Debug;
  1         2  
  1         20  
13 1     1   117 use Scalar::Util 'weaken';
  1         3  
  1         67  
14 1     1   9 use Carp;
  1         2  
  1         146  
15              
16             our $VERSION = '0.010';
17              
18             my $INETCLASS = 'IO::Socket::INET';
19             BEGIN {
20 1     1   5 for(qw(IO::Socket::IP IO::Socket::INET6)) {
21 1 50       115 eval "require $_" or next;
22 1         18063 $INETCLASS = $_;
23 1         711 last;
24             }
25             }
26              
27             sub validate_cfg {
28 0     0 1   my ($class,%args) = @_;
29 0           my @err;
30 0 0         push @err,"no address given" if ! delete $args{addr};
31             push @err,"invalid value for 'fail'"
32 0 0 0       if ( delete $args{fail} // 'hard' ) !~m{^(soft|hard)$};
33 0 0         eval { Net::IMP::Remote::Protocol->load_implementation(delete $args{impl})}
  0            
34             or push @err,$@;
35 0           return (@err,$class->SUPER::validate_cfg(%args));
36             }
37              
38             sub new_factory {
39 0     0 1   my ($class,%args) = @_;
40 0           my $self = $class->SUPER::new_factory(%args);
41 0           $self->_factory();
42 0           return $self;
43             }
44              
45             sub set_interface {
46 0     0 1   my ($self,$if) = @_;
47 0           $self->{interface} = $if; # store for reconnects
48 0           return $self->_factory->set_interface($if);
49             }
50              
51             sub get_interface {
52 0     0 1   my $self = shift;
53 0           return $self->_factory->get_interface(@_);
54             }
55              
56             sub new_analyzer {
57 0     0 1   my ($self,%args) = @_;
58 0           return $self->_factory->new_analyzer(%args);
59             }
60              
61             sub _factory {
62 0     0     my $self = shift;
63              
64             # close and reconnect after fork
65 0           my $f = $self->{factory};
66 0 0 0       $f = undef if $f and $self->{pid} != $$;
67 0 0         if ( ! $f ) {
68 0           $f = $self->{factory} = $self->_reconnect();
69 0           $self->{pid} = $$;
70             }
71             # successful connected to IMP server
72 0 0         return $f if $f;
73              
74             # return dummy factory object which supports no interface
75             # and where each analyzer just issues IMP_FATAL
76 0           return Net::IMP::Remote::_Fail->new_factory(%{ $self->{factory_args}});
  0            
77             }
78              
79             sub _reconnect {
80 0     0     my $self = shift;
81 0 0         my $addr = $self->{factory_args}{addr} or croak("no addr given");
82 0 0         my $ev = $self->{factory_args}{eventlib} or croak(
83             "data provider does not offer integration into its event loop with eventlib argument");
84 0 0         my $fd = $addr =~m{/}
    0          
85             ? IO::Socket::UNIX->new(Peer => $addr, Type => SOCK_STREAM, Timeout => 10)
86             : $INETCLASS->new( PeerAddr => $addr, Timeout => 10)
87             or return;
88 0           $fd->blocking(0);
89 0           debug("connected to $addr");
90             my $conn = Net::IMP::Remote::Connection->new($fd,0,
91             impl => $self->{factory_args}{impl},
92 0           eventlib => $ev,
93             );
94 0           weaken(my $wself=$self);
95             $conn->onClose(sub {
96 0     0     my $why = shift;
97 0           $wself->{factory} = undef; # reconnect on new_analyzer
98 0           });
99             my $factory = Net::IMP::Remote::Client->new_factory(
100 0 0         %{ $self->{factory_args}},
  0            
101             conn => $conn,
102             ) or die "cannot create factory";
103              
104             # set last used interface again
105             $factory = $factory->set_interface($self->{interface})
106 0 0         if $self->{interface};
107 0           return $factory;
108             }
109              
110              
111             {
112             package Net::IMP::Remote::_Fail;
113 1     1   14 use base 'Net::IMP::Base';
  1         3  
  1         164  
114 1     1   8 use Net::IMP qw(:DEFAULT :log);
  1         2  
  1         483  
115 0     0     sub set_interface { return shift } # no change factory
116 0     0     sub get_interface { return () } # we don't support anything
117 0     0     sub data { return }
118              
119             sub new_analyzer {
120 0     0     my $class = shift;
121 0 0         my $self = $class->SUPER::new_analyzer(@_) or return;
122 0   0       my $fail = $self->{factory_args}{fail} || 'hard';
123 0   0       my $err = $self->{factory_args}{connect_error} || $!;
124 0 0         $self->run_callback(
125             $fail eq 'soft' ? (
126             [ IMP_LOG,0,0,0,IMP_LOG_ERR,
127             "connect to IMP server failed ($err): pass all" ],
128             [ IMP_PASS,0,IMP_MAXOFFSET ],
129             [ IMP_PASS,1,IMP_MAXOFFSET ],
130             ):(
131             [ IMP_FATAL,"connect to IMP server failed ($err)" ]
132             )
133             );
134 0           return $self;
135             }
136             }
137              
138             1;
139             __END__