File Coverage

blib/lib/Net/DNS/Text.pm
Criterion Covered Total %
statement 76 76 100.0
branch 14 14 100.0
condition 2 2 100.0
subroutine 15 15 100.0
pod 7 7 100.0
total 114 114 100.0


line stmt bran cond sub pod time code
1             package Net::DNS::Text;
2              
3 27     27   1617 use strict;
  27         53  
  27         831  
4 27     27   141 use warnings;
  27         56  
  27         1436  
5              
6             our $VERSION = (qw$Id: Text.pm 1894 2023-01-12 10:59:08Z willem $)[2];
7              
8              
9             =head1 NAME
10              
11             Net::DNS::Text - DNS text representation
12              
13             =head1 SYNOPSIS
14              
15             use Net::DNS::Text;
16              
17             $object = Net::DNS::Text->new('example');
18             $string = $object->string;
19              
20             $object = Net::DNS::Text->decode( \$data, $offset );
21             ( $object, $next ) = Net::DNS::Text->decode( \$data, $offset );
22              
23             $data = $object->encode;
24             $text = $object->value;
25              
26             =head1 DESCRIPTION
27              
28             The C module implements a class of text objects
29             with associated class and instance methods.
30              
31             Each text object instance has a fixed identity throughout its
32             lifetime.
33              
34             =cut
35              
36              
37 27     27   667 use integer;
  27         69  
  27         235  
38 27     27   771 use Carp;
  27         66  
  27         2857  
39              
40              
41 27         73 use constant ASCII => ref eval {
42 27         652 require Encode;
43 27         10519 Encode::find_encoding('ascii');
44 27     27   199 };
  27         67  
45              
46 27         62 use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6]
47 27         280 Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' );
48 27     27   4261 };
  27         194  
49              
50              
51             =head1 METHODS
52              
53             =head2 new
54              
55             $object = Net::DNS::Text->new('example');
56              
57             Creates a text object which encapsulates a single character
58             string component of a resource record.
59              
60             Arbitrary single-byte characters can be represented by \ followed
61             by exactly three decimal digits. Such characters are devoid of
62             any special meaning.
63              
64             A character preceded by \ represents itself, without any special
65             interpretation.
66              
67             =cut
68              
69             my ( %escape, %escapeUTF8, %unescape ); ## precalculated escape tables
70              
71             sub new {
72 494     494 1 11890 my $self = bless [], shift;
73 494         861 local $_ = &_encode_utf8;
74              
75 492         2261 s/^\042(.*)\042$/$1/s; # strip paired quotes
76              
77 492         1093 s/\134([\060-\071]{3})/$unescape{$1}/eg; # restore numeric escapes
  303         891  
78 492         793 s/\134([^\134])/$1/g; # restore character escapes
79 492         691 s/\134\134/\134/g; # restore escaped escapes
80              
81 492         1057 while ( length $_ > 255 ) {
82 2         6 my $chunk = substr( $_, 0, 255 ); # carve into chunks
83 2         10 $chunk =~ s/[\300-\377][\200-\277]*$//;
84 2         5 push @$self, $chunk;
85 2         8 substr( $_, 0, length $chunk ) = '';
86             }
87 492         1116 push @$self, $_;
88              
89 492         1856 return $self;
90             }
91              
92              
93             =head2 decode
94              
95             $object = Net::DNS::Text->decode( \$buffer, $offset );
96              
97             ( $object, $next ) = Net::DNS::Text->decode( \$buffer, $offset );
98              
99             Creates a text object which represents the decoded data at the
100             indicated offset within the data buffer.
101              
102             The argument list consists of a reference to a scalar containing
103             the wire-format data and offset of the text data.
104              
105             The returned offset value indicates the start of the next item in
106             the data buffer.
107              
108             =cut
109              
110             sub decode {
111 15056     15056 1 24565 my $class = shift;
112 15056         17423 my $buffer = shift; # reference to data buffer
113 15056   100     24721 my $offset = shift || 0; # offset within buffer
114 15056         18275 my $size = shift; # specify size of unbounded text
115              
116 15056 100       23247 unless ( defined $size ) {
117 14999         29986 $size = unpack "\@$offset C", $$buffer;
118 14999         21303 $offset++;
119             }
120              
121 15056         19834 my $next = $offset + $size;
122 15056 100       24812 croak 'corrupt wire-format data' if $next > length $$buffer;
123              
124 15055         48292 my $self = bless [unpack( "\@$offset a$size", $$buffer )], $class;
125              
126 15055 100       41469 return wantarray ? ( $self, $next ) : $self;
127             }
128              
129              
130             =head2 encode
131              
132             $data = $object->encode;
133              
134             Returns the wire-format encoded representation of the text object
135             suitable for inclusion in a DNS packet buffer.
136              
137             =cut
138              
139             sub encode {
140 337     337 1 460 my $self = shift;
141 337         590 return join '', map { pack( 'C a*', length $_, $_ ) } @$self;
  337         1604  
142             }
143              
144              
145             =head2 raw
146              
147             $data = $object->raw;
148              
149             Returns the wire-format encoded representation of the text object
150             without the explicit length field.
151              
152             =cut
153              
154             sub raw {
155 52     52 1 593 my $self = shift;
156 52         103 return join '', map { pack( 'a*', $_ ) } @$self;
  52         337  
157             }
158              
159              
160             =head2 value
161              
162             $value = $text->value;
163              
164             Character string representation of the text object.
165              
166             =cut
167              
168             sub value {
169 59 100   59 1 965 return unless defined wantarray;
170 33         57 my $self = shift;
171 33         98 return _decode_utf8( join '', @$self );
172             }
173              
174              
175             =head2 string
176              
177             $string = $text->string;
178              
179             Conditionally quoted RFC1035 zone file representation of the text object.
180              
181             =cut
182              
183             sub string {
184 89     89 1 1567 my $self = shift;
185              
186 89         155 my @s = map { split '', $_ } @$self; # escape special and ASCII non-printable
  90         756  
187 89         234 my $s = _decode_utf8( join '', map { $escape{$_} } @s );
  1004         1742  
188 89 100       1522 return $s =~ /[ \t\n\r\f(),;]|^$/ ? qq("$s") : $s; # quote special characters and empty string
189             }
190              
191              
192             =head2 unicode
193              
194             $string = $text->unicode;
195              
196             Conditionally quoted Unicode representation of the text object.
197              
198             =cut
199              
200             sub unicode {
201 915     915 1 1249 my $self = shift;
202              
203 915         1549 my @s = map { split '', $_ } @$self; # escape special and non-printable
  915         24036  
204 915         2457 my $s = _decode_utf8( join '', map { $escapeUTF8{$_} } @s );
  196552         303283  
205 915 100       30230 return $s =~ /[ \t\n\r\f();]|^$/ ? qq("$s") : $s; # quote special characters and empty string
206             }
207              
208              
209             ########################################
210              
211             # perlcc: address of encoding objects must be determined at runtime
212             my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law:
213             my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't.
214              
215              
216             sub _decode_utf8 { ## UTF-8 to perl internal encoding
217 1037     1037   2009 local $_ = shift;
218              
219             # partial transliteration for non-ASCII character encodings
220             tr
221 1037         1266 [\040-\176\000-\377]
222             [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII;
223              
224 1037         1586 my $z = length($_) - length($_); # pre-5.18 taint workaround
225 1037         5049 return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->decode($_), $z ) : $_;
226             }
227              
228              
229             sub _encode_utf8 { ## perl internal encoding to UTF-8
230 494     494   773 local $_ = shift;
231 494 100       1226 croak 'argument undefined' unless defined $_;
232              
233             # partial transliteration for non-ASCII character encodings
234             tr
235 492         637 [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~]
236             [\040-\176] unless ASCII;
237              
238 492         798 my $z = length($_) - length($_); # pre-5.18 taint workaround
239 492         2561 return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_;
240             }
241              
242              
243             %escape = eval { ## precalculated ASCII escape table
244             my %table = map { ( chr($_) => chr($_) ) } ( 0 .. 127 );
245              
246             foreach my $n ( 0 .. 31, 34, 92, 127 .. 255 ) { # numerical escape
247             my $codepoint = sprintf( '%03u', $n );
248              
249             # transliteration for non-ASCII character encodings
250             $codepoint =~ tr [0-9] [\060-\071];
251              
252             $table{chr($n)} = pack 'C a3', 92, $codepoint;
253             }
254              
255             return %table;
256             };
257              
258             %escapeUTF8 = eval { ## precalculated UTF-8 escape table
259             my @octet = UTF8 ? ( 128 .. 191, 194 .. 254 ) : ();
260             return ( %escape, map { ( chr($_) => chr($_) ) } @octet );
261             };
262              
263              
264             %unescape = eval { ## precalculated numeric escape table
265             my %table;
266              
267             foreach my $n ( 0 .. 255 ) {
268             my $key = sprintf( '%03u', $n );
269              
270             # transliteration for non-ASCII character encodings
271             $key =~ tr [0-9] [\060-\071];
272              
273             $table{$key} = pack 'C', $n;
274             }
275             $table{"\060\071\062"} = pack 'C2', 92, 92; # escaped escape
276              
277             return %table;
278             };
279              
280              
281             1;
282             __END__