File Coverage

blib/lib/Net/IMP/Base.pm
Criterion Covered Total %
statement 65 143 45.4
branch 17 60 28.3
condition 0 15 0.0
subroutine 13 20 65.0
pod 13 14 92.8
total 108 252 42.8


line stmt bran cond sub pod time code
1 7     7   817 use strict;
  7         11  
  7         158  
2 7     7   28 use warnings;
  7         10  
  7         215  
3              
4             package Net::IMP::Base;
5 7     7   1006 use Net::IMP qw(:DEFAULT IMP_PASS_IF_BUSY);
  7         12  
  7         1017  
6 7     7   47 use Carp 'croak';
  7         14  
  7         388  
7             use fields (
8 7         27 'factory_args', # arguments given to new_factory
9             'meta', # hash with meta data given to new_analyzer
10             'analyzer_cb', # callback, set from new_analyzer or with set_callback
11             'analyzer_rv', # collected results for polling or callback, set
12             # from add_results
13             'ignore_rv', # hash with return values like IMP_PAUSE or
14             # IMP_REPLACE_LATER which are unsupported by the data
15             # provider and can be ignored
16             'busy', # if data provider is busy
17 7     7   2807 );
  7         8039  
18              
19 7     7   624 use Net::IMP::Debug;
  7         14  
  7         35  
20              
21              
22             ############################################################################
23             # API plugin methods
24             ############################################################################
25              
26             # creates new factory
27             sub new_factory {
28 63     63 1 361 my ($class,%args) = @_;
29 63         176 my Net::IMP::Base $factory = fields::new($class);
30 63         10562 $factory->{factory_args} = \%args;
31 63         196 return $factory;
32             }
33              
34             # make string from hash config, using URL encoding to escape special chars
35             sub cfg2str {
36 3     3 1 25 my (undef,%cfg) = @_;
37             return join('&', map {
38 3         15 my $v = $cfg{$_};
  19         31  
39             # only encode really necessary stuff
40 19         31 s{([=&%\x00-\x20\x7f-\xff])}{ sprintf("%%%02X",ord($1)) }eg; # key
  0         0  
41 19 100       32 if ( defined $v ) { # value
42 18         34 $v =~s{([&%\x00-\x20\x7f-\xff])}{ sprintf("%%%02X",ord($1)) }eg;
  4         19  
43 18         53 "$_=$v"
44             } else {
45 1         2 "$_"
46             }
47             } sort keys %cfg);
48             }
49              
50             # make has config from string created by cfg2str
51             sub str2cfg {
52 9     9 1 18 my (undef,$str) = @_;
53 9         23 my %cfg;
54 9         33 for my $kv (split('&',$str)) {
55 57         205 my ($k,$v) = $kv =~m{^([^=]+)(?:=(.*))?};
56 57         94 $k =~s{%([\dA-F][\dA-F])}{ chr(hex($1)) }ieg;
  0         0  
57 57 50       131 exists $cfg{$k} and croak "duplicate definition for key $k";
58 57 100       127 $v =~s{%([\dA-F][\dA-F])}{ chr(hex($1)) }ieg if defined $v;
  12         42  
59 57         113 $cfg{$k} = $v;
60             }
61 9         59 return %cfg;
62             }
63              
64             # validate config, return list of errors
65             sub validate_cfg {
66 46     46 1 108 my (undef,%cfg) = @_;
67 46         78 delete $cfg{eventlib}; # accepted everywhere
68 46 50       138 return %cfg ? "unexpected config keys ".join(', ',keys %cfg) : ();
69             }
70              
71             ############################################################################
72             # API factory methods
73             ############################################################################
74              
75             # create new analyzer
76             sub new_analyzer {
77 74     74 1 164 my Net::IMP::Base $factory = shift;
78 74         248 my %args = @_;
79 74         137 my $cb = delete $args{cb};
80              
81 74         215 my $analyzer = fields::new(ref($factory));
82 74         9398 %$analyzer = (
83             %$factory, # common properties of all analyzers
84             %args, # properties of this analyzer
85             analyzer_rv => [], # reset queued return values
86             busy => undef, # busy per dir
87             );
88 74 100       306 $analyzer->set_callback(@$cb) if $cb;
89 74         209 return $analyzer;
90             }
91              
92             # get available interfaces
93             # returns factory for the given interface
94             # might be a new one or same as called on
95             sub set_interface {
96 0     0 1 0 my Net::IMP::Base $factory = shift;
97 0         0 my $want = shift;
98 0 0       0 my ($if) = $factory->get_interface($want) or return;
99              
100 0         0 my %ignore = map { $_+0 => $_ }
  0         0  
101             ( IMP_PAUSE, IMP_CONTINUE, IMP_REPLACE_LATER );
102 0         0 delete @ignore{ map { $_+0 } @{$if->[1]}};
  0         0  
  0         0  
103 0 0       0 $factory->{ignore_rv} = %ignore ? \%ignore : undef;
104              
105 0 0       0 if ( my $adaptor = $if->[2] ) {
106             # use adaptor
107 0         0 return $adaptor->new_factory(factory => $factory)
108             } else {
109 0         0 return $factory
110             }
111             }
112              
113             # returns list of available [ if, adaptor_class ], restricted by given @if
114 0     0 0 0 sub INTERFACE { die "needs to be implemented" }
115             sub get_interface {
116 0     0 1 0 my Net::IMP::Base $factory = shift;
117 0         0 my @local = $factory->INTERFACE;
118              
119             # return all supported interfaces if none are given
120 0 0       0 return @local if ! @_;
121              
122             # find matching interfaces
123 0         0 my @match;
124 0         0 for my $if (@_) {
125 0         0 my ($in,$out) = @$if;
126 0         0 for my $lif (@local) {
127 0         0 my ($lin,$lout,$adaptor) = @$lif;
128 0 0 0     0 if ( $lin and $lin != $in ) {
129             # no match data type/proto
130 0         0 debug("data type mismatch: want $in have $lin");
131 0         0 next;
132             }
133              
134 0 0 0     0 if ( ! $out || ! @$out ) {
135             # caller will accept any return types
136             } else {
137             # any local return types from not in out?
138 0         0 my %lout = map { $_ => 1 } ( @$lout, IMP_FATAL );
  0         0  
139             delete @lout{
140 0         0 @$out,
141             # these don't need to be supported
142             (IMP_PAUSE, IMP_CONTINUE, IMP_REPLACE_LATER)
143             };
144 0 0       0 if ( %lout ) {
145             # caller does not support all return types
146 0         0 debug("no support for return types ".join(' ',keys %lout));
147 0         0 next;
148             }
149             }
150              
151 0 0       0 if ( $adaptor ) {
152             # make sure adaptor class exists
153 0 0       0 if ( ! eval "require $adaptor" ) {
154 0         0 debug("failed to load $adaptor: $@");
155 0         0 next;
156             }
157             }
158              
159             # matches
160 0         0 push @match, [ $in,$out,$adaptor ];
161 0         0 last;
162             }
163             }
164              
165 0         0 return @match;
166             }
167              
168             ############################################################################
169             # API analyzer methods
170             ############################################################################
171              
172             # set callback
173             sub set_callback {
174 74     74 1 147 my Net::IMP::Base $analyzer = shift;
175 74         161 my ($sub,@args) = @_;
176 74 50       242 $analyzer->{analyzer_cb} = $sub ? [ $sub,@args ]:undef;
177 74 50       274 $analyzer->run_callback if $analyzer->{analyzer_rv};
178             }
179              
180             # return queued results
181             sub poll_results {
182 0     0 1 0 my Net::IMP::Base $analyzer = shift;
183 0         0 my $rv = $analyzer->{analyzer_rv};
184 0         0 $analyzer->{analyzer_rv} = [];
185 0         0 return @$rv;
186             }
187              
188 0     0 1 0 sub data { die "needs to be implemented" }
189              
190             sub busy {
191 0     0 1 0 my Net::IMP::Base $analyzer = shift;
192 0         0 my ($dir,$busy) = @_;
193 0 0 0     0 if ( $busy ) {
    0          
194             return if $analyzer->{busy}
195 0 0 0     0 && $analyzer->{busy}[$dir]; # no change - stay busy
196 0         0 $analyzer->{busy}[$dir] = 1; # unbusy -> busy
197             } elsif ( ! $analyzer->{busy}
198             || ! $analyzer->{busy}[$dir] ) {
199 0         0 return; # no change - stay not busy
200             } else {
201             # set to no busy on $dir, maybe no busy at all
202 0         0 $analyzer->{busy}[$dir] = 0; # busy -> unbusy
203 0 0       0 if ( ! grep { $_ } @{$analyzer->{busy}} ) {
  0         0  
  0         0  
204             # all dir are not busy anymore
205 0         0 $analyzer->{busy} = undef;
206             }
207             }
208              
209             # run callback, either for important stuff on busy or for
210             # all stuff if not busy
211 0         0 $analyzer->run_callback;
212             }
213              
214              
215             ############################################################################
216             # internal analyzer methods
217             ############################################################################
218              
219             sub add_results {
220 0     0 1 0 my Net::IMP::Base $analyzer = shift;
221 0 0       0 if ( my $ignore = $analyzer->{ignore_rv} ) {
222 0         0 push @{$analyzer->{analyzer_rv}}, grep { ! $ignore->{$_->[0]+0} } @_;
  0         0  
  0         0  
223             } else {
224 0         0 push @{$analyzer->{analyzer_rv}},@_;
  0         0  
225             }
226             }
227              
228             {
229             my %important = do {
230             my $p = IMP_PASS_IF_BUSY;
231             map { $p->[$_]+0 => $_+1 } (0..$#$p)
232             };
233              
234             sub run_callback {
235 326     326 1 658 my Net::IMP::Base $analyzer = shift;
236 326         520 my $rv = $analyzer->{analyzer_rv}; # get collected results
237 326 100       740 if (@_) {
238             # add more results
239 252 50       506 if ( my $ignore = $analyzer->{ignore_rv} ) {
240 0         0 push @$rv, grep { ! $ignore->{$_->[0]+0} } @_;
  0         0  
241             } else {
242 252         529 push @$rv,@_;
243             }
244             }
245 326 50       750 if ( my $cb = $analyzer->{analyzer_cb} ) {
246 326         640 my ($sub,@args) = @$cb;
247 326 50       1004 if ( my $busy = $analyzer->{busy} ) {
    100          
248             # at least one dir is busy
249 0         0 my (@important,@nobusy,@busy);
250 0         0 for( @$rv ) {
251 0 0       0 if ( my $lvl = $important{ $_->[0]+0 } ) {
    0          
252 0         0 push @important,[ $_, $lvl ]
253             } elsif ( $busy->[$_->[1]] ) {
254 0         0 push @busy,$_
255             } else {
256 0         0 push @nobusy,$_
257             }
258             }
259             # sort by importance
260             @important =
261 0 0       0 map { $_->[0] } sort { $a->[1] <=> $b->[1] } @important
  0         0  
  0         0  
262             if @important;
263 0 0 0     0 if (@nobusy || @important) {
264 0         0 $analyzer->{analyzer_rv} = \@busy;
265 0         0 $sub->(@args,@important,@nobusy);
266             } else {
267             # nothing important enough to call back
268             }
269             } elsif (@$rv) {
270 252         418 $analyzer->{analyzer_rv} = []; # reset
271 252         664 $sub->(@args,@$rv); # and call back
272             }
273             }
274             }
275             }
276              
277              
278             1;
279             __END__