File Coverage

blib/lib/Net/DNS/DomainName.pm
Criterion Covered Total %
statement 62 62 100.0
branch 16 16 100.0
condition 10 11 100.0
subroutine 10 10 100.0
pod 3 3 100.0
total 101 102 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::DomainName;
2              
3 97     97   1547 use strict;
  97         200  
  97         2974  
4 97     97   500 use warnings;
  97         184  
  97         5031  
5              
6             our $VERSION = (qw$Id: DomainName.pm 1898 2023-02-15 14:27:22Z willem $)[2];
7              
8              
9             =head1 NAME
10              
11             Net::DNS::DomainName - DNS name representation
12              
13             =head1 SYNOPSIS
14              
15             use Net::DNS::DomainName;
16              
17             $object = Net::DNS::DomainName->new('example.com');
18             $name = $object->name;
19             $data = $object->encode;
20              
21             ( $object, $next ) = Net::DNS::DomainName->decode( \$data, $offset );
22              
23             =head1 DESCRIPTION
24              
25             The Net::DNS::DomainName module implements the concrete representation
26             of DNS domain names used within DNS packets.
27              
28             Net::DNS::DomainName defines methods for encoding and decoding wire
29             format octet strings. All other behaviour is inherited from
30             Net::DNS::Domain.
31              
32             The Net::DNS::DomainName1035 and Net::DNS::DomainName2535 packages
33             implement disjoint domain name subtypes which provide the name
34             compression and canonicalisation specified by RFC1035 and RFC2535.
35             These are necessary to meet the backward compatibility requirements
36             introduced by RFC3597.
37              
38             =cut
39              
40              
41 97     97   577 use base qw(Net::DNS::Domain);
  97         220  
  97         42979  
42              
43 97     97   818 use integer;
  97         209  
  97         572  
44 97     97   3208 use Carp;
  97         191  
  97         72894  
45              
46              
47             =head1 METHODS
48              
49             =head2 new
50              
51             $object = Net::DNS::DomainName->new('example.com');
52              
53             Creates a domain name object which identifies the domain specified
54             by the character string argument.
55              
56              
57             =head2 canonical
58              
59             $data = $object->canonical;
60              
61             Returns the canonical wire-format representation of the domain name
62             as defined in RFC2535(8.1).
63              
64             =cut
65              
66             sub canonical {
67 932     932 1 2176 my @label = shift->_wire;
68 932         1678 for (@label) {
69 2197         3897 tr /\101-\132/\141-\172/;
70             }
71 932         1568 return join '', map { pack 'C a*', length($_), $_ } @label, '';
  3129         8899  
72             }
73              
74              
75             =head2 decode
76              
77             $object = Net::DNS::DomainName->decode( \$buffer, $offset, $hash );
78              
79             ( $object, $next ) = Net::DNS::DomainName->decode( \$buffer, $offset, $hash );
80              
81             Creates a domain name object which represents the DNS domain name
82             identified by the wire-format data at the indicated offset within
83             the data buffer.
84              
85             The argument list consists of a reference to a scalar containing the
86             wire-format data and specified offset. The optional reference to a
87             hash table provides improved efficiency of decoding compressed names
88             by exploiting already cached compression pointers.
89              
90             The returned offset value indicates the start of the next item in the
91             data buffer.
92              
93             =cut
94              
95             sub decode {
96 11498     11498 1 24682 my $label = [];
97 11498         29268 my $self = bless {label => $label}, shift;
98 11498         17880 my $buffer = shift; # reference to data buffer
99 11498   100     23431 my $offset = shift || 0; # offset within buffer
100 11498         15731 my $linked = shift; # caller's compression index
101 11498         15383 my $cache = $linked;
102 11498         35159 $cache->{$offset} = $self; # hashed objectref by offset
103              
104 11498         17163 my $buflen = length $$buffer;
105 11498         17013 my $index = $offset;
106              
107 11498         22631 while ( $index < $buflen ) {
108 15844   100     56067 my $header = unpack( "\@$index C", $$buffer )
109             || return wantarray ? ( $self, ++$index ) : $self;
110              
111 14148 100       30880 if ( $header < 0x40 ) { # non-terminal label
    100          
112 4361         11448 push @$label, substr( $$buffer, ++$index, $header );
113 4361         9510 $index += $header;
114              
115             } elsif ( $header < 0xC0 ) { # deprecated extended label types
116 2         205 croak 'unimplemented label type';
117              
118             } else { # compression pointer
119 9785         21243 my $link = 0x3FFF & unpack( "\@$index n", $$buffer );
120 9785 100       19510 croak 'corrupt compression pointer' unless $link < $offset;
121 9784 100       17525 croak 'invalid compression pointer' unless $linked;
122              
123             # uncoverable condition false
124 9783   66     23951 $self->{origin} = $cache->{$link} ||= __PACKAGE__->decode( $buffer, $link, $cache );
125 9783 100       32843 return wantarray ? ( $self, $index + 2 ) : $self;
126             }
127             }
128 15         1810 croak 'corrupt wire-format data';
129             }
130              
131              
132             =head2 encode
133              
134             $data = $object->encode;
135              
136             Returns the wire-format representation of the domain name suitable
137             for inclusion in a DNS packet buffer.
138              
139             =cut
140              
141             sub encode {
142 124     124 1 1462 return join '', map { pack 'C a*', length($_), $_ } shift->_wire, '';
  414         1782  
143             }
144              
145              
146             ########################################
147              
148             package Net::DNS::DomainName1035; ## no critic ProhibitMultiplePackages
149             our @ISA = qw(Net::DNS::DomainName);
150              
151             =head1 Net::DNS::DomainName1035
152              
153             Net::DNS::DomainName1035 implements a subclass of domain name
154             objects which are to be encoded using the compressed wire format
155             defined in RFC1035.
156              
157             use Net::DNS::DomainName;
158              
159             $object = Net::DNS::DomainName1035->new('compressible.example.com');
160             $data = $object->encode( $offset, $hash );
161              
162             ( $object, $next ) = Net::DNS::DomainName1035->decode( \$data, $offset );
163              
164             Note that RFC3597 implies that the RR types defined in RFC1035
165             section 3.3 are the only types eligible for compression.
166              
167              
168             =head2 encode
169              
170             $data = $object->encode( $offset, $hash );
171              
172             Returns the wire-format representation of the domain name suitable
173             for inclusion in a DNS packet buffer.
174              
175             The optional arguments are the offset within the packet data where
176             the domain name is to be stored and a reference to a hash table used
177             to index compressed names within the packet.
178              
179             If the hash reference is undefined, encode() returns the lowercase
180             uncompressed canonical representation defined in RFC2535(8.1).
181              
182             =cut
183              
184             sub encode {
185 1514     1514   2380 my $self = shift;
186 1514   100     3055 my $offset = shift || 0; # offset in data buffer
187 1514   100     3212 my $hash = shift || return $self->canonical; # hashed offset by name
188              
189 1410         3275 my @labels = $self->_wire;
190 1410         2416 my $data = '';
191 1410         2949 while (@labels) {
192 2436         5025 my $name = join( '.', @labels );
193              
194 2436 100       6172 return $data . pack( 'n', 0xC000 | $hash->{$name} ) if defined $hash->{$name};
195              
196 1881         3075 my $label = shift @labels;
197 1881         2895 my $length = length $label;
198 1881         4791 $data .= pack( 'C a*', $length, $label );
199              
200 1881 100       4570 next unless $offset < 0x4000;
201 870         2196 $hash->{$name} = $offset;
202 870         2106 $offset += 1 + $length;
203             }
204 855         2653 return $data .= pack 'x';
205             }
206              
207              
208             ########################################
209              
210             package Net::DNS::DomainName2535; ## no critic ProhibitMultiplePackages
211             our @ISA = qw(Net::DNS::DomainName);
212              
213             =head1 Net::DNS::DomainName2535
214              
215             Net::DNS::DomainName2535 implements a subclass of domain name
216             objects which are to be encoded using uncompressed wire format.
217              
218             Note that RFC3597, and latterly RFC4034, specifies that the lower
219             case canonical encoding defined in RFC2535 is to be used for RR
220             types defined prior to RFC3597.
221              
222             use Net::DNS::DomainName;
223              
224             $object = Net::DNS::DomainName2535->new('incompressible.example.com');
225             $data = $object->encode( $offset, $hash );
226              
227             ( $object, $next ) = Net::DNS::DomainName2535->decode( \$data, $offset );
228              
229              
230             =head2 encode
231              
232             $data = $object->encode( $offset, $hash );
233              
234             Returns the uncompressed wire-format representation of the domain
235             name suitable for inclusion in a DNS packet buffer.
236              
237             If the hash reference is undefined, encode() returns the lowercase
238             canonical form defined in RFC2535(8.1).
239              
240             =cut
241              
242             sub encode {
243 114     114   236 my ( $self, $offset, $hash ) = @_;
244 114 100       246 return $self->canonical unless defined $hash;
245 56         126 return join '', map { pack 'C a*', length($_), $_ } $self->_wire, '';
  196         615  
246             }
247              
248             1;
249             __END__