File Coverage

blib/lib/Net/SinFP3/DB/SinFP3.pm
Criterion Covered Total %
statement 24 302 7.9
branch 0 34 0.0
condition 0 4 0.0
subroutine 8 24 33.3
pod 4 12 33.3
total 36 376 9.5


line stmt bran cond sub pod time code
1             #
2             # $Id: SinFP3.pm 2234 2014-04-08 13:05:14Z gomor $
3             #
4             package Net::SinFP3::DB::SinFP3;
5 1     1   401 use strict;
  1         2  
  1         28  
6 1     1   6 use warnings;
  1         1  
  1         36  
7              
8 1     1   7 use base qw(Net::SinFP3::DB);
  1         1  
  1         175  
9             our @AS = qw(
10             file
11             _dbh
12             _prepared
13             );
14             our @AA = qw(
15             _PatternBinary
16             _PatternTcpFlags
17             _PatternTcpWindow
18             _PatternTcpOptions
19             _PatternTcpMss
20             _PatternTcpWScale
21             _PatternTcpOLength
22             );
23             __PACKAGE__->cgBuildIndices;
24             __PACKAGE__->cgBuildAccessorsScalar(\@AS);
25             __PACKAGE__->cgBuildAccessorsArray (\@AA);
26              
27 1     1   5902 use DBI;
  1         46768  
  1         125  
28 1     1   11 use Data::Dumper;
  1         2  
  1         72  
29              
30 1     1   905 use FindBin qw($Bin);
  1         1319  
  1         238  
31 1     1   882 use LWP::UserAgent;
  1         81313  
  1         39  
32 1     1   11 use Digest::MD5;
  1         2  
  1         3054  
33              
34             sub new {
35 0     0 1   my $self = shift->SUPER::new(
36             _dbh => 0,
37             _PatternBinary => [],
38             _PatternTcpFlags => [],
39             _PatternTcpWindow => [],
40             _PatternTcpOptions => [],
41             _PatternTcpMss => [],
42             _PatternTcpWScale => [],
43             _PatternTcpOLength => [],
44             @_,
45             );
46              
47 0           my $log = $self->global->log;
48              
49 0           my $file = $self->file;
50 0 0         if (!defined($file)) {
51 0           for ("$Bin/", "$Bin/../db/") {
52 0 0         if (-f $_.'sinfp3.db') {
53 0           $file = $_.'sinfp3.db';
54 0           last;
55             }
56             }
57             }
58              
59 0 0         if (!defined($file)) {
    0          
60 0           $log->fatal("No database file found");
61             }
62             elsif (!-f $file) {
63 0           $log->fatal("Database file not found [$file]: $!");
64             }
65              
66 0           $self->file($file);
67              
68 0           return $self;
69             }
70              
71             sub getOsVersionChildrenList {
72 0     0 0   my $self = shift;
73 0           my ($id) = @_;
74              
75 0           my $dbh = $self->_dbh;
76 0           my $idOsVersion = $self->_prepared->{idOsVersion};
77 0           my $rv = $idOsVersion->execute($id);
78 0           my $h = $idOsVersion->fetchall_hashref('idOsVersion');
79              
80 0           my @osVersionList = ();
81 0           my $sOsVersion = $self->_prepared->{osVersion};
82 0           for my $k (keys %$h) {
83 0           my $rv = $sOsVersion->execute($k);
84 0           my $h = $sOsVersion->fetchrow_hashref;
85 0           push @osVersionList, $h->{osVersion};
86             }
87              
88 0           return \@osVersionList;
89             }
90              
91             sub getOsVersionChildrenPList {
92 0     0 0   my $self = shift;
93 0           my ($id) = @_;
94              
95 0           my $dbh = $self->_dbh;
96 0           my $s = $dbh->prepare(qq{SELECT idOsVersion FROM OsVersionChildren WHERE idSignatureP=?});
97 0           my $rv = $s->execute($id);
98 0           my $h = $s->fetchall_hashref('idOsVersion');
99              
100 0           my @osVersionList = ();
101 0           my $sOsVersion = $dbh->prepare(qq{SELECT osVersion FROM OsVersion WHERE idOsVersion=?});
102 0           for my $k (keys %$h) {
103 0           my $rv = $sOsVersion->execute($k);
104 0           my $h = $sOsVersion->fetchrow_hashref;
105 0           push @osVersionList, $h->{osVersion};
106             }
107              
108 0           return \@osVersionList;
109             }
110              
111             sub init {
112 0 0   0 1   my $self = shift->SUPER::init(@_) or return;
113              
114 0           my $global = $self->global;
115 0           my $log = $global->log;
116              
117 0           $log->verbose("Using database file: ".$self->file);
118              
119             my $dbh = DBI->connect(
120             "dbi:SQLite:dbname=".$self->file, '', '', {
121             RaiseError => 0,
122             PrintError => 0,
123             AutoCommit => 0,
124             HandleError => sub {
125 0     0     my ($errstr, $dbh, $arg) = @_;
126             # Let's keep fatal() for all errors as a debugging mechanism for now
127 0           $log->fatal("Database error: [$errstr]");
128 0           return 1;
129             },
130 0 0         }) or $log->fatal("Database error: [".$DBI::errstr."]");
131 0           $self->_dbh($dbh);
132              
133 0           my $sSignature = $dbh->prepare(qq{SELECT count(*) from Signature});
134 0           my $sSignatureP = $dbh->prepare(qq{SELECT count(*) from SignatureP});
135              
136             # We fail if Signature or SignatureP is empty
137             # The problem may be solved by using the latest DBD::SQLite module
138 0           my $rv = $sSignature->execute;
139 0           my $h = $sSignature->fetchrow_hashref;
140 0           my ($k, $v) = each(%$h);
141 0 0         return unless $v > 0;
142              
143 0           $rv = $sSignatureP->execute;
144 0           $h = $sSignatureP->fetchrow_hashref;
145 0           ($k, $v) = each(%$h);
146 0 0         return unless $v > 0;
147              
148             # Cache tables for future matching
149 0           for my $tPattern (qw(
150             PatternBinary
151             PatternTcpFlags
152             PatternTcpWindow
153             PatternTcpOptions
154             PatternTcpMss
155             PatternTcpWScale
156             PatternTcpOLength
157             )) {
158 0           my $_table = "_$tPattern";
159 0           my $id = 'id'.$tPattern;
160 0           my $s = $dbh->prepare(qq{SELECT * FROM $tPattern});
161 0           my $rv = $s->execute;
162 0           my $h = $s->fetchall_hashref($id);
163 0           my @ary = ();
164 0           for my $k (keys %$h) {
165 0           push @ary, $h->{$k};
166             }
167             #print Dumper(\@ary),"\n";
168 0           $self->$_table(\@ary);
169             }
170              
171             # Create prepared statements
172 0           $self->_prepare;
173              
174 0           return 1;
175             }
176              
177             sub _prepare {
178 0     0     my $self = shift;
179              
180 0           my $dbh = $self->_dbh;
181              
182 0           my %select = (
183             idOsVersion => qq{SELECT idOsVersion FROM OsVersionChildren WHERE idSignature=?},
184              
185             osVersion => qq{SELECT osVersion FROM OsVersion WHERE idOsVersion=?},
186             ipVersion => qq{SELECT ipVersion FROM IpVersion WHERE idIpVersion=?},
187             os => qq{SELECT os FROM Os WHERE idOs=?},
188             osVersionFamily => qq{SELECT osVersionFamily FROM OsVersionFamily WHERE idOsVersionFamily=?},
189             systemClass => qq{SELECT systemClass FROM SystemClass WHERE idSystemClass=?},
190             vendor => qq{SELECT vendor FROM Vendor WHERE idVendor=?},
191              
192             patternBinary => qq{SELECT * FROM PatternBinary WHERE idPatternBinary=?},
193             patternTcpFlags => qq{SELECT * FROM PatternTcpFlags WHERE idPatternTcpFlags=?},
194             patternTcpWindow => qq{SELECT * FROM PatternTcpWindow WHERE idPatternTcpWindow=?},
195             patternTcpOptions => qq{SELECT * FROM PatternTcpOptions WHERE idPatternTcpOptions=?},
196             patternTcpMss => qq{SELECT * FROM PatternTcpMss WHERE idPatternTcpMss=?},
197             patternTcpWScale => qq{SELECT * FROM PatternTcpWScale WHERE idPatternTcpWScale=?},
198             patternTcpOLength => qq{SELECT * FROM PatternTcpOLength WHERE idPatternTcpOLength=?},
199             signature => qq{SELECT * FROM Signature WHERE idSignature=?},
200              
201             idS1PatternBinary => qq{SELECT idSignature FROM Signature WHERE idS1PatternBinary=?},
202             idS1PatternTcpFlags => qq{SELECT idSignature FROM Signature WHERE idS1PatternTcpFlags=?},
203             idS1PatternTcpWindow => qq{SELECT idSignature FROM Signature WHERE idS1PatternTcpWindow=?},
204             idS1PatternTcpOptions => qq{SELECT idSignature FROM Signature WHERE idS1PatternTcpOptions=?},
205             idS1PatternTcpMss => qq{SELECT idSignature FROM Signature WHERE idS1PatternTcpMss=?},
206             idS1PatternTcpWScale => qq{SELECT idSignature FROM Signature WHERE idS1PatternTcpWScale=?},
207             idS1PatternTcpOLength => qq{SELECT idSignature FROM Signature WHERE idS1PatternTcpOLength=?},
208             idS2PatternBinary => qq{SELECT idSignature FROM Signature WHERE idS2PatternBinary=?},
209             idS2PatternTcpFlags => qq{SELECT idSignature FROM Signature WHERE idS2PatternTcpFlags=?},
210             idS2PatternTcpWindow => qq{SELECT idSignature FROM Signature WHERE idS2PatternTcpWindow=?},
211             idS2PatternTcpOptions => qq{SELECT idSignature FROM Signature WHERE idS2PatternTcpOptions=?},
212             idS2PatternTcpMss => qq{SELECT idSignature FROM Signature WHERE idS2PatternTcpMss=?},
213             idS2PatternTcpWScale => qq{SELECT idSignature FROM Signature WHERE idS2PatternTcpWScale=?},
214             idS2PatternTcpOLength => qq{SELECT idSignature FROM Signature WHERE idS2PatternTcpOLength=?},
215             idS3PatternBinary => qq{SELECT idSignature FROM Signature WHERE idS3PatternBinary=?},
216             idS3PatternTcpFlags => qq{SELECT idSignature FROM Signature WHERE idS3PatternTcpFlags=?},
217             idS3PatternTcpWindow => qq{SELECT idSignature FROM Signature WHERE idS3PatternTcpWindow=?},
218             idS3PatternTcpOptions => qq{SELECT idSignature FROM Signature WHERE idS3PatternTcpOptions=?},
219             idS3PatternTcpMss => qq{SELECT idSignature FROM Signature WHERE idS3PatternTcpMss=?},
220             idS3PatternTcpWScale => qq{SELECT idSignature FROM Signature WHERE idS3PatternTcpWScale=?},
221             idS3PatternTcpOLength => qq{SELECT idSignature FROM Signature WHERE idS3PatternTcpWScale=?},
222             all => qq{SELECT idSignature FROM Signature},
223             idPatternTcpFlags => qq{SELECT idSignatureP from SignatureP WHERE idPatternTcpFlags=?},
224             idPatternTcpWindow => qq{SELECT idSignatureP from SignatureP WHERE idPatternTcpWindow=?},
225             idPatternTcpOptions => qq{SELECT idSignatureP from SignatureP WHERE idPatternTcpOptions=?},
226             idPatternTcpMss => qq{SELECT idSignatureP from SignatureP WHERE idPatternTcpMss=?},
227             idPatternTcpWScale => qq{SELECT idSignatureP from SignatureP WHERE idPatternTcpWScale=?},
228             idPatternTcpOLength => qq{SELECT idSignatureP from SignatureP WHERE idPatternTcpOLength=?},
229             allP => qq{SELECT idSignatureP FROM SignatureP},
230             );
231              
232 0           my %prepared = ();
233 0           for my $this (keys %select) {
234 0           my $select = $dbh->prepare($select{$this});
235 0           $prepared{$this} = $select;
236             }
237              
238 0           $self->_prepared(\%prepared);
239              
240 0           return 1;
241             }
242              
243             sub searchSignatureIds {
244 0     0 0   my $self = shift;
245 0           my ($key, $value) = @_;
246              
247 0           my $dbh = $self->_dbh;
248              
249 0   0       my $select = $self->_prepared->{$key || 'all'};
250              
251 0           my $rv;
252             # First case, we want only a subset of all signatures
253 0 0         if ($value) {
254 0           $rv = $select->execute($value);
255             }
256             # Second case, we want all signature IDs
257             else {
258 0           $rv = $select->execute;
259             }
260              
261 0           my @list = ();
262 0           my $a = $select->fetchall_arrayref;
263 0           for my $id (@$a) {
264 0           push @list, @$id;
265             }
266              
267 0           return \@list;
268             }
269              
270             sub searchSignaturePIds {
271 0     0 0   my $self = shift;
272 0           my ($key, $value) = @_;
273              
274 0           my $dbh = $self->_dbh;
275              
276 0   0       my $select = $self->_prepared->{$key || 'allP'};
277              
278 0           my $rv;
279             # First case, we want only a subset of all signatures
280 0 0         if ($value) {
281 0           $rv = $select->execute($value);
282             }
283             # Second case, we want all signature IDs
284             else {
285 0           $rv = $select->execute;
286             }
287              
288 0           my @list = ();
289 0           my $a = $select->fetchall_arrayref;
290 0           for my $id (@$a) {
291 0           push @list, @$id;
292             }
293              
294 0           return \@list;
295             }
296              
297             sub _lookupSignature {
298 0     0     my $self = shift;
299 0           my ($h) = @_;
300              
301 0           my $dbh = $self->_dbh;
302              
303 0           my $prepared = $self->_prepared;
304              
305 0           my $sIpVersion = $prepared->{ipVersion};
306 0           my $sOs = $prepared->{os};
307 0           my $sOsVersion = $prepared->{osVersion};
308 0           my $sOsVersionFamily = $prepared->{osVersionFamily};
309 0           my $sSystemClass = $prepared->{systemClass};
310 0           my $sVendor = $prepared->{vendor};
311              
312 0           my $rv;
313 0           $rv = $sIpVersion->execute($h->{idIpVersion});
314 0           $rv = $sOs->execute($h->{idOs});
315 0           $rv = $sOsVersion->execute($h->{idOsVersion});
316 0           $rv = $sOsVersionFamily->execute($h->{idOsVersionFamily});
317 0           $rv = $sSystemClass->execute($h->{idSystemClass});
318 0           $rv = $sVendor->execute($h->{idVendor});
319              
320 0           my $ipVersion = $sIpVersion->fetchrow_hashref;
321 0           my $os = $sOs->fetchrow_hashref;
322 0           my $osVersion = $sOsVersion->fetchrow_hashref;
323 0           my $osVersionFamily = $sOsVersionFamily->fetchrow_hashref;
324 0           my $systemClass = $sSystemClass->fetchrow_hashref;
325 0           my $vendor = $sVendor->fetchrow_hashref;
326              
327 0           my %l = (
328             %$h,
329             trusted => $h->{trusted},
330             ipVersion => $ipVersion->{ipVersion},
331             os => $os->{os},
332             osVersion => $osVersion->{osVersion},
333             osVersionFamily => $osVersionFamily->{osVersionFamily},
334             systemClass => $systemClass->{systemClass},
335             vendor => $vendor->{vendor},
336             );
337 0 0         if (exists($h->{idSignature})) {
338 0           $l{idSignature} = $h->{idSignature};
339             }
340             else {
341 0           $l{idSignatureP} = $h->{idSignatureP};
342             }
343              
344 0           return \%l;
345             }
346              
347             sub lookupPatterns {
348 0     0 0   my $self = shift;
349 0           my ($signature) = @_;
350              
351 0           my $dbh = $self->_dbh;
352              
353 0           my $prepared = $self->_prepared;
354              
355 0           my $sBinary = $prepared->{patternBinary};
356 0           my $sTcpFlags = $prepared->{patternTcpFlags};
357 0           my $sTcpWindow = $prepared->{patternTcpWindow};
358 0           my $sTcpOptions = $prepared->{patternTcpOptions};
359 0           my $sTcpMss = $prepared->{patternTcpMss};
360 0           my $sTcpWScale = $prepared->{patternTcpWScale};
361 0           my $sTcpOLength = $prepared->{patternTcpOLength};
362              
363 0           for my $p ('S1', 'S2', 'S3') {
364 0           my $idBinary = 'id'.$p.'PatternBinary';
365 0           my $idTcpFlags = 'id'.$p.'PatternTcpFlags';
366 0           my $idTcpWindow = 'id'.$p.'PatternTcpWindow';
367 0           my $idTcpOptions = 'id'.$p.'PatternTcpOptions';
368 0           my $idTcpMss = 'id'.$p.'PatternTcpMss';
369 0           my $idTcpWScale = 'id'.$p.'PatternTcpWScale';
370 0           my $idTcpOLength = 'id'.$p.'PatternTcpOLength';
371              
372 0           my $rv = $sBinary->execute($signature->{$idBinary});
373 0           my $binary = $sBinary->fetchrow_hashref;
374              
375 0           $rv = $sTcpFlags->execute($signature->{$idTcpFlags});
376 0           my $tcpFlags = $sTcpFlags->fetchrow_hashref;
377              
378 0           $rv = $sTcpWindow->execute($signature->{$idTcpWindow});
379 0           my $tcpWindow = $sTcpWindow->fetchrow_hashref;
380              
381 0           $rv = $sTcpOptions->execute($signature->{$idTcpOptions});
382 0           my $tcpOptions = $sTcpOptions->fetchrow_hashref;
383              
384 0           $rv = $sTcpMss->execute($signature->{$idTcpMss});
385 0           my $tcpMss = $sTcpMss->fetchrow_hashref;
386              
387 0           $rv = $sTcpWScale->execute($signature->{$idTcpWScale});
388 0           my $tcpWScale = $sTcpWScale->fetchrow_hashref;
389              
390 0           $rv = $sTcpOLength->execute($signature->{$idTcpOLength});
391 0           my $tcpOLength = $sTcpOLength->fetchrow_hashref;
392              
393 0           for my $h ('Heuristic0', 'Heuristic1', 'Heuristic2') {
394 0           my $mBinaryHeuristic = 'patternBinary'.$h;
395 0           my $mTcpFlagsHeuristic = 'patternTcpFlags'.$h;
396 0           my $mTcpWindowHeuristic = 'patternTcpWindow'.$h;
397 0           my $mTcpOptionsHeuristic = 'patternTcpOptions'.$h;
398 0           my $mTcpMssHeuristic = 'patternTcpMss'.$h;
399 0           my $mTcpWScaleHeuristic = 'patternTcpWScale'.$h;
400 0           my $mTcpOLengthHeuristic = 'patternTcpOLength'.$h;
401              
402 0           $signature->{$p.$mBinaryHeuristic} = $binary->{$mBinaryHeuristic};
403 0           $signature->{$p.$mTcpFlagsHeuristic} = $tcpFlags->{$mTcpFlagsHeuristic};
404 0           $signature->{$p.$mTcpWindowHeuristic} = $tcpWindow->{$mTcpWindowHeuristic};
405 0           $signature->{$p.$mTcpOptionsHeuristic} = $tcpOptions->{$mTcpOptionsHeuristic};
406 0           $signature->{$p.$mTcpMssHeuristic} = $tcpMss->{$mTcpMssHeuristic};
407 0           $signature->{$p.$mTcpWScaleHeuristic} = $tcpWScale->{$mTcpWScaleHeuristic};
408 0           $signature->{$p.$mTcpOLengthHeuristic} = $tcpOLength->{$mTcpOLengthHeuristic};
409             }
410             }
411              
412 0           return $signature;
413             }
414              
415             sub lookupPatternsP {
416 0     0 0   my $self = shift;
417 0           my ($signature) = @_;
418              
419 0           my $dbh = $self->_dbh;
420              
421 0           my $sBinary = $dbh->prepare(
422             qq{SELECT * FROM PatternBinary WHERE idPatternBinary=?}
423             );
424 0           my $sTcpFlags = $dbh->prepare(
425             qq{SELECT * FROM PatternTcpFlags WHERE idPatternTcpFlags=?}
426             );
427 0           my $sTcpWindow = $dbh->prepare(
428             qq{SELECT * FROM PatternTcpWindow WHERE idPatternTcpWindow=?}
429             );
430 0           my $sTcpOptions = $dbh->prepare(
431             qq{SELECT * FROM PatternTcpOptions WHERE idPatternTcpOptions=?}
432             );
433 0           my $sTcpMss = $dbh->prepare(
434             qq{SELECT * FROM PatternTcpMss WHERE idPatternTcpMss=?}
435             );
436 0           my $sTcpWScale = $dbh->prepare(
437             qq{SELECT * FROM PatternTcpWScale WHERE idPatternTcpWScale=?}
438             );
439 0           my $sTcpOLength = $dbh->prepare(
440             qq{SELECT * FROM PatternTcpOLength WHERE idPatternTcpOLength=?}
441             );
442              
443 0           my $idTcpFlags = 'idPatternTcpFlags';
444 0           my $idTcpWindow = 'idPatternTcpWindow';
445 0           my $idTcpOptions = 'idPatternTcpOptions';
446 0           my $idTcpMss = 'idPatternTcpMss';
447 0           my $idTcpWScale = 'idPatternTcpWScale';
448 0           my $idTcpOLength = 'idPatternTcpOLength';
449              
450 0           my $rv = $sTcpFlags->execute($signature->{$idTcpFlags});
451 0           my $tcpFlags = $sTcpFlags->fetchrow_hashref;
452              
453 0           $rv = $sTcpWindow->execute($signature->{$idTcpWindow});
454 0           my $tcpWindow = $sTcpWindow->fetchrow_hashref;
455              
456 0           $rv = $sTcpOptions->execute($signature->{$idTcpOptions});
457 0           my $tcpOptions = $sTcpOptions->fetchrow_hashref;
458              
459 0           $rv = $sTcpMss->execute($signature->{$idTcpMss});
460 0           my $tcpMss = $sTcpMss->fetchrow_hashref;
461              
462 0           $rv = $sTcpWScale->execute($signature->{$idTcpWScale});
463 0           my $tcpWScale = $sTcpWScale->fetchrow_hashref;
464              
465 0           $rv = $sTcpOLength->execute($signature->{$idTcpOLength});
466 0           my $tcpOLength = $sTcpOLength->fetchrow_hashref;
467              
468 0           for my $h ('Heuristic0', 'Heuristic1', 'Heuristic2') {
469 0           my $mTcpFlagsHeuristic = 'patternTcpFlags'.$h;
470 0           my $mTcpWindowHeuristic = 'patternTcpWindow'.$h;
471 0           my $mTcpOptionsHeuristic = 'patternTcpOptions'.$h;
472 0           my $mTcpMssHeuristic = 'patternTcpMss'.$h;
473 0           my $mTcpWScaleHeuristic = 'patternTcpWScale'.$h;
474 0           my $mTcpOLengthHeuristic = 'patternTcpOLength'.$h;
475              
476 0           $signature->{$mTcpFlagsHeuristic} = $tcpFlags->{$mTcpFlagsHeuristic};
477 0           $signature->{$mTcpWindowHeuristic} = $tcpWindow->{$mTcpWindowHeuristic};
478 0           $signature->{$mTcpOptionsHeuristic} = $tcpOptions->{$mTcpOptionsHeuristic};
479 0           $signature->{$mTcpMssHeuristic} = $tcpMss->{$mTcpMssHeuristic};
480 0           $signature->{$mTcpWScaleHeuristic} = $tcpWScale->{$mTcpWScaleHeuristic};
481 0           $signature->{$mTcpOLengthHeuristic} = $tcpOLength->{$mTcpOLengthHeuristic};
482             }
483              
484 0           return $signature;
485             }
486              
487             sub retrieveSignature {
488 0     0 0   my $self = shift;
489 0           my ($id) = @_;
490              
491 0           my $select = $self->_prepared->{signature};
492 0           my $rv = $select->execute($id);
493 0           my $h = $select->fetchrow_hashref;
494              
495 0           my $signature = $self->_lookupSignature($h);
496              
497 0           return $signature;
498             }
499              
500             sub retrieveSignatureP {
501 0     0 0   my $self = shift;
502 0           my ($id) = @_;
503              
504 0           my $dbh = $self->_dbh;
505 0           my $select = $dbh->prepare(qq{SELECT * FROM SignatureP WHERE idSignatureP=?});
506 0           my $rv = $select->execute($id);
507 0           my $h = $select->fetchrow_hashref;
508              
509 0           my $signature = $self->_lookupSignature($h);
510              
511 0           return $signature;
512             }
513              
514             sub post {
515 0     0 1   my $self = shift;
516              
517 0 0         if ($self->_dbh) {
518 0           $self->_dbh->disconnect;
519             }
520              
521 0           return 1;
522             }
523              
524             sub _updateDb {
525 0     0     my $self = shift;
526 0           my ($ua) = @_;
527              
528 0           my $log = $self->global->log;
529              
530 0           my $dbFile = $self->file;
531              
532 0           my $url = "http://www.networecon.com/files/sinfp/sinfp3-latest.db";
533 0           my $db = $ua->get($url);
534 0 0         if ($db->is_success) {
535 0 0         open(my $out, '>', $dbFile) or $log->fatal(
536             "open2: $dbFile: $!"
537             );
538 0           print $out $db->decoded_content;
539 0           CORE::close($out);
540             }
541             else {
542 0           $log->fatal("GET [$url]: ".$db->status_line);
543             }
544 0           $log->info("Update complete for [$dbFile]");
545              
546 0           return 1;
547             }
548              
549             sub update {
550 0     0 1   my $self = shift;
551              
552 0           my $log = $self->global->log;
553              
554 0           my $ua = LWP::UserAgent->new;
555 0           $ua->timeout(10);
556 0           $ua->env_proxy;
557 0           $ua->agent("Net::SinFP3 ".$Net::SinFP3::VERSION);
558              
559 0           my $dbFile = $self->file;
560              
561 0           my $url = "http://www.networecon.com/files/sinfp/sinfp3-latest.db.md5";
562 0           my $db = $ua->get($url);
563 0 0         if ($db->is_success) {
564 0           (my $md5 = $db->decoded_content) =~ s/^.*=\s+(.*)$/$1/;
565 0           chomp($md5);
566 0 0         open(my $in, '<', $dbFile) or $log->fatal(
567             "open1: $dbFile: $!"
568             );
569 0           my $old = Digest::MD5->new;
570 0           $old->addfile($in);
571 0           my $oldmd5 = $old->hexdigest;
572 0           CORE::close($in);
573 0 0         if ($oldmd5 ne $md5) {
574 0           $self->_updateDb($ua);
575             }
576             else {
577 0           $log->info("Database already up-to-date");
578             }
579             }
580             else {
581 0           $log->fatal("GET [$url]: ". $db->status_line);
582             }
583              
584 0           return 1;
585             }
586              
587             1;
588              
589             __END__