File Coverage

lib/Net/Domain/SMD/RL.pm
Criterion Covered Total %
statement 18 48 37.5
branch 0 12 0.0
condition 0 7 0.0
subroutine 6 13 46.1
pod 5 6 83.3
total 29 86 33.7


line stmt bran cond sub pod time code
1             # Copyrights 2013-2014 by [Mark Overmeer].
2             # For other contributors see ChangeLog.
3             # See the manual pages for details on the licensing terms.
4             # Pod stripped from pm file by OODoc 2.01.
5 1     1   1977 use warnings;
  1         2  
  1         32  
6 1     1   6 use strict;
  1         3  
  1         39  
7              
8             package Net::Domain::SMD::RL;
9 1     1   5 use vars '$VERSION';
  1         3  
  1         96  
10             $VERSION = '0.17';
11              
12 1     1   6 use base 'Exporter';
  1         3  
  1         103  
13              
14 1     1   6 use Log::Report 'net-domain-smd';
  1         2  
  1         11  
15 1     1   478 use Scalar::Util qw(blessed);
  1         3  
  1         1026  
16              
17              
18              
19 0     0 1   sub new($%) { my ($class, %args) = @_; (bless {}, $class)->init(\%args) }
  0            
20              
21             sub init($)
22 0     0 0   { my ($self, $args) = @_;
23 0 0         $self->{NDSR_source} = $args->{source} or panic;
24              
25 0   0       my $rev = $args->{revoked} || [];
26 0 0         $rev = +{map +($_ => 1), @$rev} if ref $rev eq 'ARRAY';
27 0           $self->{NDSR_revoked} = $rev;
28 0           $self;
29             }
30              
31              
32             sub _process(@)
33 0     0     { my $self = shift;
34 0   0       my $revoked = $self->{NDSR_revoked} ||= {};
35              
36             # Compact code: needs to be fast.
37             # be warned: \n may end line, but last element not used (yet).
38 0           my ($version, $timestamp) = shift;
39 0           my $header = shift;
40 0           $revoked->{lc +(split /\,/, $_, 2)[0]} = 1 for @_;
41 0           $self;
42             }
43              
44             sub fromFile($%)
45 0     0 1   { my ($class, $fn) = (shift, shift);
46              
47 0 0         open my($fh), '<:raw', $fn
48             or fault "cannot read RL file {fn}", fn => $fn;
49              
50 0           my $self = $class->new(source => $fn, @_);
51 0           $self->_process($fh->getlines);
52             }
53              
54              
55             my $ua;
56             sub fromURI($%)
57 0     0 1   { my ($class, $uri) = (shift, shift);
58              
59 0           eval "require LWP::UserAgent";
60 0 0         $@ and error __x"need LWP::UserAgent to fetch RL: {err}", err => $@;
61              
62 0   0       $ua ||= LWP::UserAgent->new;
63 0           my $resp = $ua->get($uri);
64 0 0         $resp->is_success
65             or error __x"could not collect RL from {source}: {err}"
66             , $resp->status_line;
67              
68 0           my $self = $class->new(source => $uri, @_);
69 0           $self->_process(split /\r?\n/, $resp->decoded_content);
70             }
71              
72             #-------------------------
73              
74              
75 0     0 1   sub source() {shift->{NDSR_source}}
76              
77             #-------------------------
78              
79              
80             sub isRevoked($)
81 0     0 1   { my ($self, $smd) = @_;
82 0 0         my $smdid = blessed $smd ? $smd->smdID : $smd;
83 0           exists $self->{NDSR_revoked}{lc $smdid};
84             }
85              
86             1;