File Coverage

blib/lib/Net/Lookup/DotTel.pm
Criterion Covered Total %
statement 96 113 84.9
branch 29 50 58.0
condition 14 54 25.9
subroutine 10 10 100.0
pod 6 6 100.0
total 155 233 66.5


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Net::Lookup::DotTel - Look up information related to a .tel domain name (or
4             possible another domain name having .tel-style TXT and NAPTR records).
5              
6             =head1 DESCRIPTION
7              
8             This module offers an easy way to access the contact information that is
9             stored in DNS through NAPTR and TXT records under the .tel TLD.
10              
11             =head1 SYNOPSIS
12              
13             use Net::Lookup::DotTel;
14             my $lookup = Net::Lookup::DotTel->new;
15              
16             if ( $lookup->lookup ( 'smallco.tel' )) {
17              
18             my $service = $lookup->get_services ( 'email' );
19              
20             if ( $service->{uri} =~ /^mailto:(.+)/ ) {
21             my $email = $1;
22             print "SmallCo's email address is $email\n";
23             }
24              
25             }
26              
27             =head1 METHODS
28              
29             =cut
30              
31             package Net::Lookup::DotTel;
32              
33 3     3   41322 use strict;
  3         11  
  3         91  
34 3     3   17 use warnings;
  3         7  
  3         135  
35              
36             our $VERSION = '0.04';
37              
38 3     3   21 use Carp;
  3         14  
  3         228  
39 3     3   1391 use Net::DNS;
  3         215653  
  3         3193  
40              
41             =head2 new
42              
43             $lookup = Net::Lookup::DotTel->new;
44             $lookup = Net::Lookup::DotTel->new ( resolver_config => $resolver_settings );
45              
46             Constructor. The following optional named parameters can be specified:
47              
48             =over
49              
50             =item * resolver_config
51              
52             A reference to an array containing information be passed to
53             Net::DNS::Resolver->new. E.g., to specify your own resolving nameservers,
54             you can do:
55              
56             $lookup = Net::Lookup::DotTel->new (
57             resolver_config => [
58             nameservers => [ '192.168.1.1', '192.168.2.1' ]
59             ]
60             );
61              
62             =back
63              
64             =cut
65              
66             sub new {
67              
68 3     3 1 214639 my $class = shift;
69 3         23 my %param = @_;
70              
71 3         62 my $self = {};
72 3 50       10 $self->{resolver} = Net::DNS::Resolver->new ( @{$param{resolver_config} || []} );
  3         65  
73              
74 3         967 bless $self, $class;
75              
76             }
77              
78             =head2 lookup
79              
80             $lookup->lookup ( 'smallco.tel' );
81              
82             Lookup the specified domain name. Returns 1 if the domain name exists or 0
83             otherwise. Note that the fact that a domain exists does not mean that it has
84             any meaningful TXT or NAPTR records associated with it.
85              
86             If the lookup was succesful, you can use the other methods to extract
87             information from this domain.
88              
89             =cut
90              
91             sub lookup {
92              
93 2     2 1 13 my $self = shift;
94 2         6 my ( $domain ) = @_;
95              
96 2 50       8 croak "No domain specified" unless ( $domain );
97              
98 2 100       21 if ( my $response = $self->{resolver}->query ( $domain, 'ANY' )) {
99 1         281422 $self->{current_domain} = ( $response->question )[0]->qname;
100 1         74 return 1;
101             }
102              
103 1         38870 return 0;
104              
105             }
106              
107             =head2 get_keywords
108              
109             @keywords = $lookup->get_keywords;
110             @keywords = $lookup->get_keywords ( 'pa' );
111              
112             Return the keywords that are associated with the domain. Keywords contain
113             additional information related to the domain name that cannot be specified
114             using NAPTR records. Keywords are stored in TXT records using a
115             .tel-specific format.
116              
117             Keywords are ordered into groups. The returned list will contain a reference
118             to a list (which can be interpolated to a hash) containing the keywords of a
119             single group. If you specify one or more parameters, only keyword groups
120             containing a value for the specified keywords will be returned.
121              
122             E.g., to return only keyword groups that specify a Postal Address (pa) that
123             contains at least a ZIP code (pc) and a city (tc), you specify:
124              
125             @keywords = $lookup->get_keywords ( 'pa', 'pc', 'tc' );
126              
127             If only a single keyword group matches, @keywords would contain a single
128             array reference looking something like:
129              
130             [ 'pa', '', 'a1', 'Somestreet 1', 'pc', '12094', 'tc', 'Some city', 'c', 'US' ]
131              
132             Which can be interpolated into a hash so you get:
133              
134             {
135             'pa' => '',
136             'a1' => 'Somestreet 1',
137             'pc' => '12094',
138             'tc' => 'Some city',
139             'c' => 'US'
140             }
141              
142             When interpolating, the order of the elements (which was originally
143             preserved) will be lost. This may be relevant as .tel users can explicitly
144             specify the order of the fields for presentation purposes.
145              
146             For a description of available keywords and their shortened forms, please
147             refer to the Telnic website, specifically Appendix B of the Developer's
148             Manual.
149              
150             For retrieving a list of (business) postal addresses associated with a
151             domain name, you can also use the get_postal_address method. That methods
152             translates the keywords to nicer ;) names.
153              
154             =cut
155              
156             sub get_keywords {
157              
158 3     3 1 7 my $self = shift;
159 3         11 my @must_contain = @_;
160              
161 3 50       11 unless ( $self->{current_domain} ) {
162 0         0 carp "Called get_text without succesful lookup";
163 0         0 return ();
164             }
165              
166 3         13 my @results = ();
167              
168 3 50       14 if ( my $response = $self->{resolver}->query ( $self->{current_domain}, 'TXT' )) {
169              
170 3         213612 RECORD: foreach my $t ( $response->answer ) {
171              
172 42 50       129 if ( $t->type eq 'TXT' ) {
173              
174 42         415 my @parts = $t->char_str_list;
175 42 100       3590 if ( $parts[0] eq '.tkw' ) {
176              
177             # Find out whether we have all the required keywords in this
178             # group.
179              
180 12         26 KEYWORD: foreach my $kw ( @must_contain ) {
181 10         27 for ( my $i = 2; $i <= $#parts; $i+= 2 ) {
182 21 100       61 next KEYWORD if ( $parts[$i] eq $kw );
183             }
184 7         20 next RECORD;
185             }
186              
187 5         22 push @results, [ @parts[2..$#parts] ];
188              
189             }
190             }
191             }
192             }
193              
194 3         83 return @results;
195              
196             }
197              
198             =head2 get_postal_address
199              
200             @postal_addresses = $lookup->get_postal_address;
201              
202             Return all postal addresses which are associated with the current domain. A
203             postal address is a keyword group containing at least one of the following
204             groups of keywords:
205              
206             =over
207              
208             =item * pa, a1, tc
209              
210             =item * bpa, a1, tc
211              
212             =back
213              
214             The returned list contains all addresses that could be found, ordered in the
215             following way:
216              
217             =over
218              
219             =item * addresses with more keyword (more complete addresses) before addresses with less keywords,
220              
221             =item * postal addresses (pa) before business postal addresses (bpa),
222              
223             =item * ordered by label alphabetically, listing addresses without a label before any other addresses,
224              
225             =item * ordered by keyword contents alphabetically.
226              
227             =back
228              
229             Note that the last of this order sequence does not make any particular
230             sense; it is used only to guarantee that the order in which the addresses
231             are returned stays the same if the data does not change.
232              
233             Every address in the list consists of a reference to a hash with the following keys:
234              
235             =over
236              
237             =item * order
238              
239             A reference to a list containing the field names in the order in which they
240             appeared in the original keyword group. The field names we use here are the
241             longer field names present in the rest of the hash.
242              
243             =item * label
244              
245             The label associated with this address.
246              
247             =item * type
248              
249             The type of address, either 'pa' or 'bpa'.
250              
251             =item * address1
252              
253             =item * address2
254              
255             =item * address3
256              
257             The street address, consisting of a maximum of three lines.
258              
259             =item * postcode
260              
261             =item * city
262              
263             =item * state
264              
265             =item * country
266              
267             These should speak for itself. Note that neither of these fields are in any
268             particular order; specifically, do not expect the country field to contain
269             an ISO country code.
270              
271             =back
272              
273             E.g., when a single address is returned with the current domain, the list
274             may contain the following result for a Dutch address:
275              
276             {
277             order => ['address1', 'postcode', 'city', 'country'],
278             address1 => 'Some street 1',
279             postcode => '1234 AB',
280             city => 'Amsterdam',
281             country => 'NL'
282             }
283              
284             In scalar context, returns only the first address (this is what you want to
285             do for a 'quick and dirty' .tel based address lookup).
286              
287             =cut
288              
289             sub get_postal_address {
290              
291 1     1 1 494 my $self = shift;
292              
293 1         5 my @keywords = $self->get_keywords ( 'pa', 'a1', 'tc' );
294 1         6 push @keywords, $self->get_keywords ( 'bpa', 'a1', 'tc' );
295              
296             # Sort the keywords
297             @keywords = sort {
298 1         4 ( @{$b} <=> @{$a} ) || # More descriptive before less descriptive.
  0         0  
  0         0  
299             (( $a->[2] eq 'pa' ) && ( $b->[2] eq 'bpa' ) && -1 ) || # PA before BPA
300             (( $b->[2] eq 'pa' ) && ( $a->[2] eq 'bpa' ) && 1 ) || # BPA after PA
301             ( $a->[3] cmp $b->[3] ) || # Alphabetically by label
302 0 0 0     0 ( join ( ' ', @{$a} ) cmp join ( ' ', @{$b} )) # Alphabetically by keywords.
  0   0     0  
  0   0     0  
      0        
      0        
      0        
      0        
303             } @keywords;
304              
305 1         3 my @results;
306 1         2 foreach my $kw ( @keywords ) {
307              
308 1         3 my %address;
309             my @order;
310              
311 1         2 while ( my $n = shift @{$kw} ) {
  6         17  
312              
313 5         7 my $v = shift @{$kw};
  5         9  
314              
315 5         29 foreach (
316             { name => 'a1', nice => 'address1' },
317             { name => 'a2', nice => 'address2' },
318             { name => 'a3', nice => 'address3' },
319             { name => 'pc', nice => 'postcode' },
320             { name => 'tc', nice => 'city' },
321             { name => 'sp', nice => 'state' },
322             { name => 'c', nice => 'country' }
323             ) {
324              
325 35 100       70 if ( $n eq $_->{name} ) {
326 4         8 $address{$_->{nice}} = $v;
327 4         8 push @order, $_->{nice};
328             }
329             }
330              
331 5 100       17 unless ( $address{type} ) {
332 1 50       6 if ( $n eq 'pa' ) {
    50          
333 0         0 $address{type} = 'pa';
334 0         0 $address{label} = $v;
335             } elsif ( $n eq 'bpa' ) {
336 1         3 $address{type} = 'bpa';
337 1         17 $address{label} = $v;
338             }
339             }
340             }
341              
342 1         4 $address{order} = \@order;
343              
344 1         5 push @results, \%address;
345              
346             }
347              
348 1 50       6 if ( wantarray ) {
349 1         8 return @results;
350             }
351              
352 0         0 return $results[0];
353              
354             }
355              
356             =head2 get_services
357              
358             @services = $lookup->get_services;
359             @services = $lookup->get_services ( 'email' );
360              
361             Return the services that are associated with the current domain. If an ENUM
362             service is specified, returns only services that match this service type.
363             The services are taken from the NAPTR records associated with the domain and
364             are ordered by the preference and order fields. The service can be specified
365             as specific as you want:
366              
367             =over
368              
369             =item * 'email' will return all email services,
370              
371             =item * 'email:mailto' will return only email services of subtype 'mailto',
372              
373             =item * 'x-lbl:Label' will return only services with label 'Label' (case insensitive).
374              
375             =back
376              
377             Every service in the list consists of a hash reference with the following keys:
378              
379             =over
380              
381             =item * services
382              
383             A reference to a list containing the ENUM services of this record.
384              
385             =item * uri
386              
387             The translated URI for the service, e.g. the email address as
388             'mailto:somebody@domain.invalid' or a phone number as 'tel:+12356890'.
389              
390             =item * label
391              
392             Contains the .tel label as specified by the non-standard ENUM service
393             'x-lbl'. This is a .tel-specific extension. If the x-lbl service is not
394             present then neither is this key.
395              
396             =item * order
397              
398             =item * preference
399              
400             =item * regexp
401              
402             =item * flags
403              
404             =item * replacement
405              
406             These keys contain the original values of the NAPTR record.
407              
408             =back
409              
410             For most uses, only 'label' and 'uri' will actually be interesting.
411              
412             If the method is called in a scalar context, only the first service found is
413             returned. For this service to always be the same we order the NAPTR records
414             not just on preference and order, but also alphabetically by services,
415             regexp, flags and replacement fields.
416              
417             The .tel registry supports a number of non-standard ENUM services, which are
418             described in the whitepaper 'NAPTR Records in .tel'.
419              
420             =cut
421              
422             sub get_services {
423              
424 1     1 1 2438 my $self = shift;
425 1         3 my ( $service ) = @_;
426              
427 1 50       4 unless ( $self->{current_domain} ) {
428 0         0 carp "Called get_text without succesful lookup";
429 0         0 return ();
430             }
431              
432 1         3 my @results;
433              
434 1 50       6 if ( my $response = $self->{resolver}->query ( $self->{current_domain}, 'NAPTR' )) {
435              
436 1         306463 foreach my $n ( $response->answer ) {
437              
438 8 50       584 if ( $n->type eq 'NAPTR' ) {
439              
440 8         83 my @services;
441 8         13 my $value = '';
442              
443 8 50       18 if ( $n->flags eq 'u' ) {
444              
445             # Terminal NAPTR
446              
447 8         157 @services = split ( /\+/, $n->service );
448 8 50 33     221 if ( (!$service) || (grep m/^$service(:.+)?$/, @services )) {
449              
450             # Service matches query. Determine the service URI.
451              
452 8         22 $value = $n->name;
453 8         284 my $regexp = $n->regexp;
454              
455             # Note that the following is not entirely correct; it does not
456             # allow for escaping the delim-char that is used.
457              
458 8         223 my ( $match, $replacement, $flags ) = split ( substr ( $regexp, 0, 1), substr ( $regexp, 1 ));
459 8         59 $value =~ s/$match/$replacement/e;
  8         26  
460 8   33     28 $value ||= $regexp; # For 'fixing' thoroughly broken regexps
461             }
462              
463             } # end Terminal NAPTR
464              
465 8   50     70 push @results, {
      50        
      50        
      50        
      50        
      50        
      50        
466             services => \@services,
467             uri => $value || '',
468             label => ( grep m/^x-lbl:(.+)$/, @services )[0] || '',
469             order => $n->order || 0,
470             preference => $n->preference || 0,
471             flags => $n->flags || '',
472             regexp => $n->regexp || '',
473             replacement => $n->replacement || ''
474             };
475             }
476             }
477             }
478              
479             @results = sort {
480 1         150 ( $a->{preference} <=> $b->{preference} ) || # By preference
481             ( $a->{order} <=> $b->{order} ) || # By order
482 0         0 ( join ( '+', @{$a->{services}} ) cmp join ( '+', @{$b->{services}} )) || # By service field
  0         0  
483             ( $a->{regexp} cmp $b->{regexp} ) || # By regexp
484             ( $a->{flags} cmp $b->{flags} ) || # By flags
485             ( $a->{replacement} cmp $b->{replacement} ) # By replacement
486 16 0 33     41 } @results;
      33        
      0        
      0        
487              
488 1 50       3 if ( wantarray ) {
489 1         27 return @results;
490             }
491              
492 0         0 return $results[0];
493              
494             }
495              
496             =head2 get_text
497              
498             @text = $lookup->get_text;
499              
500             Return the TXT records that are associated with the current domain that are
501             not .tel keywords or system messages. This will retrieve any TXT record
502             associated with the domain which does not start with ".tkw" or ".tsm". Note
503             that the records are not returned in any particular order.
504              
505             If the query was not succesful, an empty list is returned.
506              
507             Note that all texts in a single TXT field are simply concatenated; this is
508             due to the fact that plain .tel TXT fields usually contain a descriptive
509             text only.
510              
511             =cut
512              
513             sub get_text {
514              
515 1     1 1 2211 my $self = shift;
516              
517 1 50       5 unless ( $self->{current_domain} ) {
518 0         0 carp "Called get_text without succesful lookup";
519 0         0 return ();
520             }
521              
522 1         3 my @results;
523              
524 1 50       5 if ( my $response = $self->{resolver}->query ( $self->{current_domain}, 'TXT' )) {
525              
526 1         77166 foreach my $t ( $response->answer ) {
527              
528 14 50       48 if ( $t->type eq 'TXT' ) {
529              
530 14         161 my @parts = $t->char_str_list;
531 14 100 100     1455 unless (( $parts[0] eq '.tkw' ) || ( $parts[0] eq '.tsm' )) {
532              
533 8         31 push @results, join ( ' ', @parts );
534              
535             }
536             }
537             }
538             }
539              
540 1         40 return @results;
541              
542             }
543              
544             =head1 AUTHOR
545              
546             Sebastiaan Hoogeveen,
547              
548             =head1 SEE ALSO
549              
550             http://dev.telnic.org/pages/howtos.html for a link to the Developer's Manual
551             which, among others, contains a description of the .tel keywords.
552              
553             http://dev.telnic.org/pages/record_types.html for a link to the whitepaper
554             'NAPTR Records in .tel'.
555              
556             http://dev.telnic.org/pages/howtos.html for a description of keywords.
557              
558             If you are looking for a way to manipulate the DNS records in the Telnic
559             system take a look at WebService::Telnic.
560              
561             =head1 BUGS
562              
563             Since this is a very early release of what could become a pretty complex
564             module, there are probably several bugs in this code. Use at your own risk.
565             Bugs can be reported by email to the author.
566              
567             =head1 COPYRIGHT
568              
569             Copyright 2009 Sebastiaan Hoogeveen. All rights reserved. This program is
570             free software; you can redistribute it and/or modify it under the same terms
571             as Perl itself.
572              
573             See http://www.perl.com/perl/misc/Artistic.html
574              
575             =cut
576              
577             1;