← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:13 2021

Filename/usr/local/lib/perl5/site_perl/Net/DNS/Domain.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sNet::DNS::Domain::::BEGIN@3Net::DNS::Domain::BEGIN@3
0000s0sNet::DNS::Domain::::BEGIN@38Net::DNS::Domain::BEGIN@38
0000s0sNet::DNS::Domain::::BEGIN@39Net::DNS::Domain::BEGIN@39
0000s0sNet::DNS::Domain::::BEGIN@4Net::DNS::Domain::BEGIN@4
0000s0sNet::DNS::Domain::::BEGIN@42Net::DNS::Domain::BEGIN@42
0000s0sNet::DNS::Domain::::BEGIN@47Net::DNS::Domain::BEGIN@47
0000s0sNet::DNS::Domain::::BEGIN@51Net::DNS::Domain::BEGIN@51
0000s0sNet::DNS::Domain::::BEGIN@52Net::DNS::Domain::BEGIN@52
0000s0sNet::DNS::Domain::::BEGIN@54Net::DNS::Domain::BEGIN@54
0000s0sNet::DNS::Domain::::CORE:packNet::DNS::Domain::CORE:pack (opcode)
0000s0sNet::DNS::Domain::::__ANON__[:264]Net::DNS::Domain::__ANON__[:264]
0000s0sNet::DNS::Domain::::__ANON__[:274]Net::DNS::Domain::__ANON__[:274]
0000s0sNet::DNS::Domain::::_decode_asciiNet::DNS::Domain::_decode_ascii
0000s0sNet::DNS::Domain::::_encode_utf8Net::DNS::Domain::_encode_utf8
0000s0sNet::DNS::Domain::::_wireNet::DNS::Domain::_wire
0000s0sNet::DNS::Domain::::fqdnNet::DNS::Domain::fqdn
0000s0sNet::DNS::Domain::::labelNet::DNS::Domain::label
0000s0sNet::DNS::Domain::::nameNet::DNS::Domain::name
0000s0sNet::DNS::Domain::::newNet::DNS::Domain::new
0000s0sNet::DNS::Domain::::originNet::DNS::Domain::origin
0000s0sNet::DNS::Domain::::stringNet::DNS::Domain::string
0000s0sNet::DNS::Domain::::xnameNet::DNS::Domain::xname
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package Net::DNS::Domain;
2
3use strict;
4use warnings;
5
6our $VERSION = (qw$Id: Domain.pm 1825 2020-11-18 13:15:01Z willem $)[2];
7
8
9=head1 NAME
10
11Net::DNS::Domain - DNS domains
12
13=head1 SYNOPSIS
14
15 use Net::DNS::Domain;
16
17 $domain = Net::DNS::Domain->new('example.com');
18 $name = $domain->name;
19
20=head1 DESCRIPTION
21
22The Net::DNS::Domain module implements a class of abstract DNS
23domain objects with associated class and instance methods.
24
25Each domain object instance represents a single DNS domain which
26has a fixed identity throughout its lifetime.
27
28Internally, the primary representation is a (possibly empty) list
29of ASCII domain name labels, and optional link to an origin domain
30object topologically closer to the DNS root.
31
32The computational expense of Unicode character-set conversion is
33partially mitigated by use of caches.
34
35=cut
36
37
38use integer;
39use Carp;
40
41
42use constant ASCII => ref eval {
43 require Encode;
44 Encode::find_encoding('ascii');
45};
46
47use constant UTF8 => scalar eval { ## not UTF-EBCDIC [see Unicode TR#16 3.6]
48 Encode::encode_utf8( chr(182) ) eq pack( 'H*', 'C2B6' );
49};
50
51use constant LIBIDN2 => defined eval { require Net::LibIDN2 };
52use constant LIBIDN => LIBIDN2 ? undef : defined eval { require Net::LibIDN };
53
54use constant IDN2FLAG => LIBIDN2 ? &Net::LibIDN2::IDN2_NFC_INPUT + &Net::LibIDN2::IDN2_NONTRANSITIONAL : 0;
55
56# perlcc: address of encoding objects must be determined at runtime
57my $ascii = ASCII ? Encode::find_encoding('ascii') : undef; # Osborn's Law:
58my $utf8 = UTF8 ? Encode::find_encoding('utf8') : undef; # Variables won't; constants aren't.
59
60
61=head1 METHODS
62
63=head2 new
64
65 $object = Net::DNS::Domain->new('example.com');
66
67Creates a domain object which represents the DNS domain specified
68by the character string argument. The argument consists of a
69sequence of labels delimited by dots.
70
71A character preceded by \ represents itself, without any special
72interpretation.
73
74Arbitrary 8-bit codes can be represented by \ followed by exactly
75three decimal digits.
76Character code points are ASCII, irrespective of the character
77coding scheme employed by the underlying platform.
78
79Argument string literals should be delimited by single quotes to
80avoid escape sequences being interpreted as octal character codes
81by the Perl compiler.
82
83The character string presentation format follows the conventions
84for zone files described in RFC1035.
85
86Users should be aware that non-ASCII domain names will be transcoded
87to NFC before encoding, which is an irreversible process.
88
89=cut
90
91my ( %escape, %unescape ); ## precalculated ASCII escape tables
92
93our $ORIGIN;
94my ( $cache1, $cache2, $limit ) = ( {}, {}, 100 );
95
96sub new {
97 my ( $class, $s ) = @_;
98 croak 'domain identifier undefined' unless defined $s;
99
100 my $k = join '', $s, $class, $ORIGIN || ''; # cache key
101 my $cache = $$cache1{$k} ||= $$cache2{$k}; # two layer cache
102 return $cache if defined $cache;
103
104 ( $cache1, $cache2, $limit ) = ( {}, $cache1, 500 ) unless $limit--; # recycle cache
105
106 my $self = bless {}, $class;
107
108 $s =~ s/\\\\/\\092/g; # disguise escaped escape
109 $s =~ s/\\\./\\046/g; # disguise escaped dot
110
111 my $label = $self->{label} = ( $s eq '@' ) ? [] : [split /\056/, _encode_utf8($s)];
112
113 foreach (@$label) {
114 croak qq(empty label in "$s") unless length;
115
116 if ( LIBIDN2 && UTF8 && /[^\000-\177]/ ) {
117 my $rc = 0;
118 $_ = Net::LibIDN2::idn2_to_ascii_8( $_, IDN2FLAG, $rc );
119 croak Net::LibIDN2::idn2_strerror($rc) unless $_;
120 }
121
122 if ( LIBIDN && UTF8 && /[^\000-\177]/ ) {
123 $_ = Net::LibIDN::idn_to_ascii( $_, 'utf-8' );
124 croak 'name contains disallowed character' unless $_;
125 }
126
127 s/\134([\060-\071]{3})/$unescape{$1}/eg; # restore numeric escapes
128 s/\134(.)/$1/g; # restore character escapes
129 croak qq(label too long in "$s") if length > 63;
130 }
131
132 $$cache1{$k} = $self; # cache object reference
133
134 return $self if $s =~ /\.$/; # fully qualified name
135 $self->{origin} = $ORIGIN || return $self; # dynamically scoped $ORIGIN
136 return $self;
137}
138
139
140=head2 name
141
142 $name = $domain->name;
143
144Returns the domain name as a character string corresponding to the
145"common interpretation" to which RFC1034, 3.1, paragraph 9 alludes.
146
147Character escape sequences are used to represent a dot inside a
148domain name label and the escape character itself.
149
150Any non-printable code point is represented using the appropriate
151numerical escape sequence.
152
153=cut
154
155sub name {
156 my ($self) = @_;
157
158 return $self->{name} if defined $self->{name};
159 return unless defined wantarray;
160
161 my @label = shift->_wire;
162 for (@label) {
163 s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg;
164 }
165
166 return $self->{name} = '.' unless scalar @label;
167 return $self->{name} = _decode_ascii( join chr(46), @label );
168}
169
170
171=head2 fqdn
172
173 @fqdn = $domain->fqdn;
174
175Returns a character string containing the fully qualified domain
176name, including the trailing dot.
177
178=cut
179
180sub fqdn {
181 my $name = &name;
182 return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot
183}
184
185
186=head2 xname
187
188 $xname = $domain->xname;
189
190Interprets an extended name containing Unicode domain name labels
191encoded as Punycode A-labels.
192
193If decoding is not possible, the ACE encoded name is returned.
194
195=cut
196
197sub xname {
198 my $name = &name;
199
200 if ( LIBIDN2 && UTF8 && $name =~ /xn--/i ) {
201 my $self = shift;
202 return $self->{xname} if defined $self->{xname};
203 my $u8 = Net::LibIDN2::idn2_to_unicode_88($name);
204 return $self->{xname} = $u8 ? $utf8->decode($u8) : $name;
205 }
206
207 if ( LIBIDN && UTF8 && $name =~ /xn--/i ) {
208 my $self = shift;
209 return $self->{xname} if defined $self->{xname};
210 return $self->{xname} = $utf8->decode( Net::LibIDN::idn_to_unicode $name, 'utf-8' );
211 }
212 return $name;
213}
214
215
216=head2 label
217
218 @label = $domain->label;
219
220Identifies the domain by means of a list of domain labels.
221
222=cut
223
224sub label {
225 my @label = shift->_wire;
226 for (@label) {
227 s/([^\055\101-\132\141-\172\060-\071])/$escape{$1}/eg;
228 _decode_ascii($_)
229 }
230 return @label;
231}
232
233
234=head2 string
235
236 $string = $object->string;
237
238Returns a character string containing the fully qualified domain
239name as it appears in a zone file.
240
241Characters which are recognised by RFC1035 zone file syntax are
242represented by the appropriate escape sequence.
243
244=cut
245
246sub string {
247 ( my $name = &name ) =~ s/(["();@])/\\$1/; # escape special char
248 return $name =~ /[.]$/ ? $name : $name . '.'; # append trailing dot
249}
250
251
252=head2 origin
253
254 $create = Net::DNS::Domain->origin( $ORIGIN );
255 $result = &$create( sub{ Net::DNS::RR->new( 'mx MX 10 a' ); } );
256 $expect = Net::DNS::RR->new( "mx.$ORIGIN. MX 10 a.$ORIGIN." );
257
258Class method which returns a reference to a subroutine wrapper
259which executes a given constructor in a dynamically scoped context
260where relative names become descendents of the specified $ORIGIN.
261
262=cut
263
264my $placebo = sub { my $constructor = shift; &$constructor; };
265
266sub origin {
267 my ( $class, $name ) = @_;
268 my $domain = defined $name ? Net::DNS::Domain->new($name) : return $placebo;
269
270 return sub { # closure w.r.t. $domain
271 my $constructor = shift;
272 local $ORIGIN = $domain; # dynamically scoped $ORIGIN
273 &$constructor;
274 }
275}
276
277
278########################################
279
280sub _decode_ascii { ## ASCII to perl internal encoding
281 local $_ = shift;
282
283 # partial transliteration for non-ASCII character encodings
284 tr
285 [\040-\176\000-\377]
286 [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~?] unless ASCII;
287
288 my $z = length($_) - length($_); # pre-5.18 taint workaround
289 return ASCII ? substr( $ascii->decode($_), $z ) : $_;
290}
291
292
293sub _encode_utf8 { ## perl internal encoding to UTF8
294 local $_ = shift;
295
296 # partial transliteration for non-ASCII character encodings
297 tr
298 [ !"#$%&'()*+,\-./0-9:;<=>?@A-Z\[\\\]^_`a-z{|}~\000-\377]
299 [\040-\176\077] unless ASCII;
300
301 my $z = length($_) - length($_); # pre-5.18 taint workaround
302 return ASCII ? substr( ( UTF8 ? $utf8 : $ascii )->encode($_), $z ) : $_;
303}
304
305
306sub _wire {
307 my $self = shift;
308
309 my $label = $self->{label};
310 my $origin = $self->{origin};
311 return ( @$label, $origin ? $origin->_wire : () );
312}
313
314
315%escape = eval { ## precalculated ASCII escape table
316 my %table = ( # ASCII printable, \. \\
317 ( map { ( $_ => $_ ) } map { pack( 'C', $_ ) } ( 33 .. 126 ) ),
318 ( map { pack( 'C', $_ ) => pack( 'C2', 92, $_ ) } ( 46, 92 ) ),
319 );
320
321 foreach my $n ( 0 .. 32, 127 .. 255 ) { # \ddd
322 my $codepoint = sprintf( '%03u', $n );
323
324 # transliteration for non-ASCII character encodings
325 $codepoint =~ tr [0-9] [\060-\071];
326
327 $table{pack( 'C', $n )} = pack 'C a3', 92, $codepoint;
328 }
329
330 return %table;
331};
332
333
334%unescape = eval { ## precalculated numeric escape table
335 my %table;
336
337 foreach my $n ( 0 .. 255 ) {
338 my $key = sprintf( '%03u', $n );
339
340 # transliteration for non-ASCII character encodings
341 $key =~ tr [0-9] [\060-\071];
342
343 $table{$key} = pack 'C', $n;
344 }
345 $table{"\060\071\062"} = pack 'C2', 92, 92; # escaped escape
346
347 return %table;
348};
349
350
3511;
352__END__