File Coverage

blib/lib/Net/DNS/RR/APL.pm
Criterion Covered Total %
statement 96 96 100.0
branch 20 20 100.0
condition 12 12 100.0
subroutine 17 17 100.0
pod 1 1 100.0
total 146 146 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::RR::APL;
2              
3 2     2   22 use strict;
  2         4  
  2         61  
4 2     2   12 use warnings;
  2         3  
  2         109  
5             our $VERSION = (qw$Id: APL.pm 1896 2023-01-30 12:59:25Z willem $)[2];
6              
7 2     2   16 use base qw(Net::DNS::RR);
  2         3  
  2         238  
8              
9              
10             =head1 NAME
11              
12             Net::DNS::RR::APL - DNS APL resource record
13              
14             =cut
15              
16 2     2   15 use integer;
  2         10  
  2         16  
17              
18 2     2   70 use Carp;
  2         6  
  2         1655  
19              
20              
21             sub _decode_rdata { ## decode rdata from wire-format octet string
22 5     5   21 my ( $self, $data, $offset ) = @_;
23              
24 5         15 my $limit = $offset + $self->{rdlength};
25              
26 5         12 my $aplist = $self->{aplist} = [];
27 5         17 while ( $offset < $limit ) {
28 25         67 my $xlen = unpack "\@$offset x3 C", $$data;
29 25         39 my $size = ( $xlen & 0x7F );
30 25         48 my $item = bless {}, 'Net::DNS::RR::APL::Item';
31 25         49 $item->{negate} = $xlen - $size;
32 25         87 @{$item}{qw(family prefix address)} = unpack "\@$offset n C x a$size", $$data;
  25         65  
33 25         43 $offset += $size + 4;
34 25         58 push @$aplist, $item;
35             }
36 5 100       267 croak('corrupt APL data') unless $offset == $limit; # more or less FUBAR
37 4         10 return;
38             }
39              
40              
41             sub _encode_rdata { ## encode rdata as wire-format octet string
42 7     7   11 my $self = shift;
43              
44 7         11 my @rdata;
45 7         8 my $aplist = $self->{aplist};
46 7         13 foreach (@$aplist) {
47 27         40 my $address = $_->{address};
48 27         52 $address =~ s/[\000]+$//; # strip trailing null octets
49 27 100       47 my $xlength = ( $_->{negate} ? 0x80 : 0 ) | length($address);
50 27         31 push @rdata, pack 'n C2 a*', @{$_}{qw(family prefix)}, $xlength, $address;
  27         78  
51             }
52 7         32 return join '', @rdata;
53             }
54              
55              
56             sub _format_rdata { ## format rdata portion of RR string.
57 2     2   3 my $self = shift;
58              
59 2         3 my $aplist = $self->{aplist};
60 2         5 my @rdata = map { $_->string } @$aplist;
  2         4  
61 2         8 return @rdata;
62             }
63              
64              
65             sub _parse_rdata { ## populate RR from rdata in argument list
66 4     4   18 my ( $self, @argument ) = @_;
67              
68 4         12 $self->aplist(@argument);
69 3         8 return;
70             }
71              
72              
73             sub aplist {
74 20     20 1 51 my ( $self, @argument ) = @_;
75              
76 20         40 while ( scalar @argument ) { # parse apitem strings
77 26 100       90 last unless $argument[0] =~ m#[!:./]#;
78 13         24 local $_ = shift @argument;
79 13         51 m#^(!?)(\d+):(.+)/(\d+)$#;
80 13 100       36 my $n = $1 ? 1 : 0;
81 13   100     34 my $f = $2 || 0;
82 13         19 my $a = $3;
83 13   100     42 my $p = $4 || 0;
84 13         32 $self->aplist( negate => $n, family => $f, address => $a, prefix => $p );
85             }
86              
87 19   100     53 my $aplist = $self->{aplist} ||= [];
88 19 100       64 if ( my %argval = @argument ) { # parse attribute=value list
89 13         27 my $item = bless {}, 'Net::DNS::RR::APL::Item';
90 13         38 while ( my ( $attribute, $value ) = each %argval ) {
91 52 100       138 $item->$attribute($value) unless $attribute eq 'address';
92             }
93 13         29 $item->address( $argval{address} ); # address must be last
94 12         36 push @$aplist, $item;
95             }
96              
97 18         30 my @ap = @$aplist;
98 18 100       71 return unless defined wantarray;
99 2 100       8 return wantarray ? @ap : join ' ', map { $_->string } @ap;
  1         3  
100             }
101              
102              
103             ########################################
104              
105              
106             package Net::DNS::RR::APL::Item; ## no critic ProhibitMultiplePackages
107              
108 2     2   526 use Net::DNS::RR::A;
  2         6  
  2         73  
109 2     2   490 use Net::DNS::RR::AAAA;
  2         3  
  2         823  
110              
111             my %family = qw(1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA);
112              
113              
114             sub negate {
115 18     18   1790 my ( $self, @value ) = @_;
116 18         31 for (@value) { return $self->{negate} = $_ }
  13         44  
117 5         21 return $self->{negate};
118             }
119              
120              
121             sub family {
122 52     52   1519 my ( $self, @value ) = @_;
123 52         79 for (@value) { $self->{family} = 0 + $_ }
  13         24  
124 52   100     206 return $self->{family} || 0;
125             }
126              
127              
128             sub prefix {
129 33     33   56 my ( $self, @value ) = @_;
130 33         53 for (@value) { $self->{prefix} = 0 + $_ }
  13         31  
131 33   100     104 return $self->{prefix} || 0;
132             }
133              
134              
135             sub address {
136 26     26   1519 my ( $self, @value ) = @_;
137              
138 26   100     41 my $family = $family{$self->family} || die 'unknown address family';
139 25 100       123 return bless( {%$self}, $family )->address unless scalar @value;
140              
141 12         21 my $bitmask = $self->prefix;
142 12         47 my $address = bless( {}, $family )->address( shift @value );
143 12         69 return $self->{address} = pack "B$bitmask", unpack 'B*', $address;
144             }
145              
146              
147             sub string {
148 8     8   1137 my $self = shift;
149              
150 8 100       17 my $not = $self->{negate} ? '!' : '';
151 8         15 my ( $family, $address, $prefix ) = ( $self->family, $self->address, $self->prefix );
152 8         59 return "$not$family:$address/$prefix";
153             }
154              
155              
156             1;
157             __END__