File Coverage

blib/lib/Net/DNS/RR/DS.pm
Criterion Covered Total %
statement 103 103 100.0
branch 38 38 100.0
condition 12 12 100.0
subroutine 22 22 100.0
pod 8 8 100.0
total 183 183 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::RR::DS;
2              
3 5     5   1591 use strict;
  5         11  
  5         177  
4 5     5   24 use warnings;
  5         10  
  5         225  
5             our $VERSION = (qw$Id: DS.pm 1909 2023-03-23 11:36:16Z willem $)[2];
6              
7 5     5   27 use base qw(Net::DNS::RR);
  5         12  
  5         455  
8              
9              
10             =head1 NAME
11              
12             Net::DNS::RR::DS - DNS DS resource record
13              
14             =cut
15              
16 5     5   30 use integer;
  5         9  
  5         28  
17              
18 5     5   136 use Carp;
  5         9  
  5         416  
19              
20 5     5   34 use constant BABBLE => defined eval { require Digest::BubbleBabble };
  5         11  
  5         9  
  5         2372  
21              
22             eval { require Digest::SHA }; ## optional for simple Net::DNS RR
23             eval { require Digest::GOST12 };
24             eval { require Digest::GOST::CryptoPro };
25              
26             my %digest = (
27             '1' => scalar( eval { Digest::SHA->new(1) } ),
28             '2' => scalar( eval { Digest::SHA->new(256) } ),
29             '3' => scalar( eval { Digest::GOST::CryptoPro->new() } ),
30             '4' => scalar( eval { Digest::SHA->new(384) } ),
31             '5' => scalar( eval { Digest::GOST12->new() } ),
32             );
33              
34              
35             sub _decode_rdata { ## decode rdata from wire-format octet string
36 2     2   4 my ( $self, $data, $offset ) = @_;
37              
38 2         5 my $rdata = substr $$data, $offset, $self->{rdlength};
39 2         11 @{$self}{qw(keytag algorithm digtype digestbin)} = unpack 'n C2 a*', $rdata;
  2         19  
40 2         9 return;
41             }
42              
43              
44             sub _encode_rdata { ## encode rdata as wire-format octet string
45 11     11   18 my $self = shift;
46              
47 11         16 return pack 'n C2 a*', @{$self}{qw(keytag algorithm digtype digestbin)};
  11         50  
48             }
49              
50              
51             sub _format_rdata { ## format rdata portion of RR string.
52 18     18   31 my $self = shift;
53              
54 18         38 my @rdata = @{$self}{qw(keytag algorithm digtype)};
  18         47  
55 18 100       41 if ( my $digest = $self->digest ) {
56 17         37 $self->_annotation( $self->babble ) if BABBLE;
57 17         88 push @rdata, split /(\S{64})/, $digest;
58             } else {
59 1         2 push @rdata, '""';
60             }
61 18         79 return @rdata;
62             }
63              
64              
65             sub _parse_rdata { ## populate RR from rdata in argument list
66 9     9   29 my ( $self, @argument ) = @_;
67              
68 9         26 $self->keytag( shift @argument );
69 9         13 my $algorithm = shift @argument;
70 9         29 $self->digtype( shift @argument );
71 9         27 $self->digest(@argument);
72 9         26 $self->algorithm($algorithm);
73 9         26 return;
74             }
75              
76              
77             sub keytag {
78 26     26 1 365 my ( $self, @value ) = @_;
79 26         55 for (@value) { $self->{keytag} = 0 + $_ }
  21         71  
80 26   100     124 return $self->{keytag} || 0;
81             }
82              
83              
84             sub algorithm {
85 41     41 1 1254 my ( $self, $arg ) = @_;
86              
87 41 100       93 unless ( ref($self) ) { ## class method or simple function
88 3         7 my $argn = pop;
89 3 100       15 return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn);
90             }
91              
92 38 100       162 return $self->{algorithm} unless defined $arg;
93 27 100       68 return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC';
94 25   100     47 return $self->{algorithm} = _algbyname($arg) || die _algbyname('') # disallow algorithm(0)
95             }
96              
97              
98             sub digtype {
99 58     58 1 950 my ( $self, $arg ) = @_;
100              
101 58 100       126 unless ( ref($self) ) { ## class method or simple function
102 3         6 my $argn = pop;
103 3 100       15 return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn);
104             }
105              
106 55 100       175 return $self->{digtype} unless defined $arg;
107 25 100       61 return _digestbyval( $self->{digtype} ) if uc($arg) eq 'MNEMONIC';
108 22   100     42 return $self->{digtype} = _digestbyname($arg) || die _digestbyname('') # disallow digtype(0)
109             }
110              
111              
112             sub digest {
113 35     35 1 2771 my ( $self, @value ) = @_;
114 35 100       100 return unpack "H*", $self->digestbin() unless scalar @value;
115 13 100       28 my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value;
  14         157  
  13         67  
116 12         143 return $self->digestbin( pack "H*", join "", @hex );
117             }
118              
119              
120             sub digestbin {
121 80     80 1 1174 my ( $self, @value ) = @_;
122 80         134 for (@value) { $self->{digestbin} = $_ }
  21         62  
123 80   100     395 return $self->{digestbin} || "";
124             }
125              
126              
127             sub babble {
128 21     21 1 1424 return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->digestbin ) : '';
129             }
130              
131              
132             sub create {
133 13     13 1 89 my ( $class, $keyrr, %args ) = @_;
134 13         54 my ($type) = reverse split '::', $class;
135              
136 13 100       43 croak "Unable to create $type record for invalid key" unless $keyrr->protocol == 3;
137 12 100       42 croak "Unable to create $type record for revoked key" if $keyrr->revoke;
138 11 100       36 croak "Unable to create $type record for non-zone key" unless $keyrr->zone;
139              
140             my $self = Net::DNS::RR->new(
141             owner => $keyrr->owner, # per definition, same as keyrr
142             type => $type,
143             class => $keyrr->class,
144             ttl => $keyrr->{ttl},
145 10         34 digtype => 1, # SHA1 by default
146             %args,
147             algorithm => $keyrr->algorithm,
148             keytag => $keyrr->keytag
149             );
150              
151 10         25 my $hash = $digest{$self->digtype};
152 10 100       53 croak join ' ', 'digtype', $self->digtype('MNEMONIC'), 'not supported' unless $hash;
153 9         58 my $clone = $hash->clone;
154 9         44 $clone->add( $keyrr->{owner}->canonical );
155 9         23 $clone->add( $keyrr->_encode_rdata );
156 9         95 $self->digestbin( $clone->digest );
157              
158 9         53 return $self;
159             }
160              
161              
162             sub verify {
163 6     6 1 17 my ( $self, $key ) = @_;
164 6         14 my $verify = Net::DNS::RR::DS->create( $key, ( digtype => $self->digtype ) );
165 6         21 return $verify->digestbin eq $self->digestbin;
166             }
167              
168              
169             ########################################
170              
171             {
172             my @digestbyname = (
173             'SHA-1' => 1, # [RFC3658]
174             'SHA-256' => 2, # [RFC4509]
175             'GOST-R-34.11-94' => 3, # [RFC5933]
176             'SHA-384' => 4, # [RFC6605]
177             'GOST-R-34.11-2012' => 5, # [RFC5933bis]
178             );
179              
180             my @digestalias = (
181             'SHA' => 1,
182             'GOST94' => 3,
183             'GOST12' => 5,
184             );
185              
186             my %digestbyval = reverse @digestbyname;
187              
188             foreach (@digestbyname) { s/[\W_]//g; } # strip non-alphanumerics
189             my @digestrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @digestbyname;
190             my %digestbyname = ( @digestalias, @digestrehash ); # work around broken cperl
191              
192             sub _digestbyname {
193 24     24   54 my $arg = shift;
194 24         38 my $key = uc $arg; # synthetic key
195 24         53 $key =~ s/[\W_]//g; # strip non-alphanumerics
196 24         46 my $val = $digestbyname{$key};
197 24 100       104 return $val if defined $val;
198 3 100       107 return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg];
199             }
200              
201             sub _digestbyval {
202 5     5   10 my $value = shift;
203 5   100     139 return $digestbyval{$value} || return $value;
204             }
205             }
206              
207              
208             {
209             my @algbyname = (
210             'DELETE' => 0, # [RFC4034][RFC4398][RFC8078]
211             'RSAMD5' => 1, # [RFC3110][RFC4034]
212             'DH' => 2, # [RFC2539]
213             'DSA' => 3, # [RFC3755][RFC2536]
214             ## Reserved => 4, # [RFC6725]
215             'RSASHA1' => 5, # [RFC3110][RFC4034]
216             'DSA-NSEC3-SHA1' => 6, # [RFC5155]
217             'RSASHA1-NSEC3-SHA1' => 7, # [RFC5155]
218             'RSASHA256' => 8, # [RFC5702]
219             ## Reserved => 9, # [RFC6725]
220             'RSASHA512' => 10, # [RFC5702]
221             ## Reserved => 11, # [RFC6725]
222             'ECC-GOST' => 12, # [RFC5933]
223             'ECDSAP256SHA256' => 13, # [RFC6605]
224             'ECDSAP384SHA384' => 14, # [RFC6605]
225             'ED25519' => 15, # [RFC8080]
226             'ED448' => 16, # [RFC8080]
227              
228             'INDIRECT' => 252, # [RFC4034]
229             'PRIVATEDNS' => 253, # [RFC4034]
230             'PRIVATEOID' => 254, # [RFC4034]
231             ## Reserved => 255, # [RFC4034]
232             );
233              
234             my %algbyval = reverse @algbyname;
235              
236             foreach (@algbyname) { s/[\W_]//g; } # strip non-alphanumerics
237             my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname;
238             my %algbyname = @algrehash; # work around broken cperl
239              
240             sub _algbyname {
241 27     27   58 my $arg = shift;
242 27         43 my $key = uc $arg; # synthetic key
243 27         71 $key =~ s/[\W_]//g; # strip non-alphanumerics
244 27         49 my $val = $algbyname{$key};
245 27 100       122 return $val if defined $val;
246 4 100       330 return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg];
247             }
248              
249             sub _algbyval {
250 4     4   9 my $value = shift;
251 4   100     25 return $algbyval{$value} || return $value;
252             }
253             }
254              
255             ########################################
256              
257              
258             1;
259             __END__