File Coverage

lib/Net/Domain/SMD.pm
Criterion Covered Total %
statement 16 18 88.8
branch n/a
condition n/a
subroutine 6 6 100.0
pod n/a
total 22 24 91.6


line stmt bran cond sub pod time code
1             # Copyrights 2013-2015 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.02.
5 1     1   1183 use warnings;
  1         2  
  1         88  
6 1     1   7 use strict;
  1         2  
  1         34  
7              
8             package Net::Domain::SMD;
9 1     1   6 use vars '$VERSION';
  1         2  
  1         119  
10             $VERSION = '0.18';
11              
12 1     1   5 use Log::Report 'net-domain-smd';
  1         2  
  1         36  
13              
14 1     1   322 use MIME::Base64 qw/decode_base64/;
  1         2  
  1         41  
15 1     1   336 use XML::LibXML ();
  0            
  0            
16             use POSIX qw/mktime tzset/;
17             use XML::Compile::Util qw/type_of_node/;
18             use List::Util qw/first/;
19             use Scalar::Util qw/blessed/;
20             use DateTime ();
21              
22              
23             sub new($%) { my ($class, %args) = @_; (bless {}, $class)->init(\%args) }
24             sub init($)
25             { my ($self, $args) = @_;
26             $self->{NDS_data} = $args->{data} or panic;
27             $self->{NDS_payload} = $args->{payload} or panic;
28             $self;
29             }
30              
31              
32             sub fromNode($%)
33             { my ($class, $node, %args) = @_;
34             my $schemas = delete $args{schemas} or panic;
35              
36             $node = $node->documentElement
37             if $node->isa('XML::LibXML::Document');
38              
39             my $type = type_of_node $node;
40             my $data = $schemas->reader($type)->($node);
41              
42             $class->new(payload => $node, data => $data, %args);
43             }
44              
45             #----------------
46              
47             sub payload() {shift->{NDS_payload}}
48             sub data() {shift->{NDS_data}} # avoid, undocumented
49             sub _mark() {shift->data->{mark}} # hidden
50              
51             #----------------
52              
53             sub courts() { @{shift->_mark->{court} || []} }
54              
55              
56             sub trademarks() { @{shift->_mark->{trademark} || []} }
57              
58              
59             sub treaties() { @{shift->_mark->{treatyOrStatute} || []} }
60              
61              
62             sub certificates(%)
63             { my ($self, %args) = @_;
64              
65             my $tokens = $self->data->{ds_Signature}{ds_KeyInfo}{__TOKENS} || [];
66             my @certs = map $_->certificate, @$tokens;
67              
68             my $issuer = $args{issuer};
69             $issuer ? (grep $_->issuer eq $issuer, @certs) : @certs;
70             }
71              
72              
73             sub issuer()
74             { my $i = shift->data->{smd_issuerInfo} or return;
75             # remove smd namespace prefixes
76             my %issuer;
77             while(my($k, $v) = each %$i)
78             { $k =~ s/smd_//;
79             $issuer{$k} = $v;
80             }
81             \%issuer;
82             }
83              
84              
85             sub from() {shift->data->{smd_notBefore}}
86             sub until() {shift->data->{smd_notAfter}}
87             sub fromTime() {my $s = shift; $s->date2time($s->from)->hires_epoch}
88             sub untilTime() {my $s = shift; $s->date2time($s->until)->hires_epoch}
89              
90              
91             sub smdID() {shift->data->{smd_id}}
92              
93              
94             #----------------
95              
96             sub date2time($)
97             { my ($thing, $date) = @_;
98              
99             return $date
100             if blessed $date && $date->isa('DateTime');
101              
102             # For now, I only support Zulu time: 2013-07-12T12:53:48.408Z
103             $date =~ m/^ ([0-9]{4})\-([0-1]?[0-9])\-([0-3]?[0-9])
104             T ([0-2]?[0-9])\:([0-5]?[0-9])\:([0-6]?[0-9])(\.[0-9]+)?
105             ([+-][0-9]?[0-9]\:[0-9][0-9]|Z)? $/x
106             or return;
107              
108             DateTime->new
109             ( year => $1, month => $2, day => $3
110             , hour => $4, minute => $5, second => $6,
111             , nanosecond => int(1_000_000_000 * ($7 || 0))
112             , time_zone => ($8 || 'UTC')
113             );
114             }
115              
116             1;