File Coverage

Whois.pm
Criterion Covered Total %
statement 69 147 46.9
branch 15 68 22.0
condition 3 6 50.0
subroutine 11 20 55.0
pod n/a
total 98 241 40.6


line stmt bran cond sub pod time code
1             # -*- mode:CPerl -*-
2             # N.B. revision control headers below reflect only recent work
3             # $Header
4             # $Id: Whois.pm,v 1.6 1999/12/01 14:00:51 dhudes Exp dhudes $
5             # $Log: Whois.pm,v $
6             #
7             # Revision 1.6 1999/08/31 11:57:12 dhudes
8             # Don't require 5.005, only 5.004 and don't do it in a BEGIN
9             # per CPAN tester pudge@pobox.comm
10             #
11             # Revision 1.5 1999/08/29 15:09:26 dhudes
12             # Fixes for new Network Solutions response when domain unregistered:
13             # 1. break out of the loop that scans through the leading boilerplate
14             # when the string "No match" is found as well as when "REGISTRANT" is found.
15             # 2. If no match, set the MATCH to 0 (if there is a match, MATCH is set to 1)
16             # and (very important) test this value before looking for the record fields
17             # If match is 0, skip to the end and bless the structure. Caller tests by invoking the method 'ok' 1 match 0 no match
18             #
19             # Revision 1.401 1999/08/13 22:11:39 dhudes
20             # Revised POD to reflect dual-maintainers
21             #
22             # Revision 1.4 1999/08/09 00:05:44 dhudes
23             # local /$ rather than undef /$
24             # Thanks to Chris Nandor for pointing this out
25             #
26             # Revision 1.3 1999/08/08 22:53:54 dhudes
27             # change \r and \n in network connection to \x0d\x0a for portability
28             #
29             # Revision 1.2 1999/07/25 03:01:04 dhudes
30             # 1. Fix to address changes by Network Solutions in response to WHOIS requests
31             # (strip out leading disclaimer)
32             # 2. fix record created and record created internal tags
33             # 3. Reformat POD portion
34             #
35             # Revision 1.1 1999/07/20 03:54:11 dhudes
36             # Initial revision
37             #
38              
39             package Net::Whois;
40             require 5.004;
41 1     1   760 use strict;
  1         1  
  1         33  
42 1     1   4 use Carp;
  1         2  
  1         77  
43              
44             =head1 NAME
45              
46             Net::Whois - Get and parse "whois" domain data from InterNIC
47              
48             =head1 SYNOPSIS
49              
50             Note that all fields except "name" and "tag" may be undef
51             because "whois" information is erratically filled in.
52              
53             use Net::Whois;
54             use Carp;
55              
56             my $w = new Net::Whois::Domain $dom
57             or die "Can't connect to Whois server\n;
58              
59             unless ($w->ok) { croak "No match for $dom";}
60              
61             print "Domain: ", $w->domain, "\n";
62             print "Name: ", $w->name, "\n";
63             print "Tag: ", $w->tag, "\n";
64             print "Address:\n", map { " $_\n" } $w->address;
65             print "Country: ", $w->country, "\n";
66             print "Name Servers:\n", map { " $$_[0] ($$_[1])\n" }
67             @{$w->servers};
68             my ($c, $t);
69             if ($c = $w->contacts) {
70             print "Contacts:\n";
71             for $t (sort keys %$c) {
72             print " $t:\n";
73             print map { "\t$_\n" } @{$$c{$t}};
74             }
75             }
76             print "Record created:", $w->record_created ;
77             print "Record updated:", $w->record_updated ;
78              
79             =head1 DESCRIPTION
80              
81             Net::Whois::Domain new() attempts to retrieve and parse the given
82             domain's "whois" information from the InterNIC (whois.internic.net).
83             If the server could not be contacted, is too busy, or otherwise does not process
84             the query then the constructor does not return a reference and your object is undefined.
85             If the constructor returns a reference, that reference can be used to access the various
86             attributes of the domains' whois entry assuming that there was a match.
87             The member function ok returns 1 if a match 0 if no match.
88              
89             Note that the Locale::Country module (part of the Locale-Codes
90             distribution) is used to recognize spelled-out country names; if that
91             module is not present, only two-letter country abbreviations will be
92             recognized.
93              
94             The server consulted is "whois.internic.net". You can only
95             get .org, .edu, .net, .com domains from Internic. Other whois servers
96             for other Top-Level-Domains (TLD) return information in a different syntax
97             and are not supported at this time. Also, only queries for domains are
98             valid. Querying for a network will fail utterly since those are not
99             kept in the whois.internic.net server (a future enhancement will
100             add a network lookup function). Querying for NIC handles won't work
101             since they have a different return syntax than a domain. Domains other
102             than those listed won't work they're not in the server. A future enhancment
103             planned will send the query to the appropriate server based on its TLD.
104              
105              
106             =head1 AUTHOR
107              
108             Originally written by Chip Salzenberg (chip@pobox.com)
109             in April of 1997 for Idle Communications, Inc.
110             In September of 1998 Dana Hudes (dhudes@hudes.org) found this
111             but it was broken and he needed it so he fixed it.
112             In August, 1999 Dana and Chip agreed to become co-maintainers of the module.
113             Dana released a new version of Net::Whois to CPAN and resumed active
114             development.
115              
116             =head1 COPYRIGHT
117              
118             This module is free software; you can redistribute it and/or modify
119             it under the same terms as Perl itself. If you make modifications,
120             the author would like to know so that they can be incorporated into
121             future releases.
122              
123             =cut
124              
125 1     1   687 use IO::Socket;
  1         25076  
  1         6  
126 1     1   1393 use IO::File;
  1         2347  
  1         137  
127 1     1   6 use Carp;
  1         1  
  1         68  
128 1     1   5 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  1         2  
  1         349  
129              
130              
131             $VERSION = '1.9';
132              
133             require Exporter;
134             @ISA = qw(Exporter);
135             @EXPORT = ();
136              
137             my $server_name = 'whois.internic.net';
138             my $server_addr;
139             my %TLDs = ( COM => 'whois.networksolutions.com', NET => 'whois.networksolutions.com', EDU => 'whois.networksolutions.com', ORG => 'whois.networksolutions.com', ARPA =>'whois.arin.net', MIL =>'whois.nic.mil');
140             my %US_State = (
141             AL => 'ALABAMA',
142             AK => 'ALASKA',
143             AZ => 'ARIZONA',
144             AR => 'ARKANSAS',
145             CA => 'CALIFORNIA',
146             CO => 'COLORADO',
147             CT => 'CONNECTICUT',
148             DE => 'DELAWARE',
149             DC => 'DISTRICT OF COLUMBIA',
150             FL => 'FLORIDA',
151             GA => 'GEORGIA',
152             GU => 'GUAM',
153             HI => 'HAWAII',
154             ID => 'IDAHO',
155             IL => 'ILLINOIS',
156             IN => 'INDIANA',
157             IA => 'IOWA',
158             KS => 'KANSAS',
159             KY => 'KENTUCKY',
160             LA => 'LOUISIANA',
161             ME => 'MAINE',
162             MH => 'MARSHALL ISLANDS',
163             MD => 'MARYLAND',
164             MA => 'MASSACHUSETTS',
165             MI => 'MICHIGAN',
166             MN => 'MINNESOTA',
167             MS => 'MISSISSIPPI',
168             MO => 'MISSOURI',
169             MT => 'MONTANA',
170             'NE' => 'NEBRASKA',
171             NV => 'NEVADA',
172             NH => 'NEW HAMPSHIRE',
173             NJ => 'NEW JERSEY',
174             NM => 'NEW MEXICO',
175             NY => 'NEW YORK',
176             NC => 'NORTH CAROLINA',
177             ND => 'NORTH DAKOTA',
178             MP => 'NORTHERN MARIANA ISLANDS',
179             OH => 'OHIO',
180             OK => 'OKLAHOMA',
181             OR => 'OREGON',
182             PA => 'PENNSYLVANIA',
183             PR => 'PUERTO RICO',
184             RI => 'RHODE ISLAND',
185             SC => 'SOUTH CAROLINA',
186             SD => 'SOUTH DAKOTA',
187             TN => 'TENNESSEE',
188             TX => 'TEXAS',
189             UT => 'UTAH',
190             VT => 'VERMONT',
191             VI => 'VIRGIN ISLANDS',
192             VA => 'VIRGINIA',
193             WA => 'WASHINGTON',
194             WV => 'WEST VIRGINIA',
195             WI => 'WISCONSIN',
196             WY => 'WYOMING',
197             );
198              
199             @US_State{values %US_State} = keys %US_State;
200              
201              
202             sub _connect {
203 1 50   1   2 unless ($server_addr) {
204 1         121503 my $a = gethostbyname $server_name;
205 1 50       31 $server_addr = inet_ntoa($a) if $a;
206             }
207 1 50       6 $server_addr or croak 'Net::Whois:: no server';
208            
209 1 50       20 my $sock = IO::Socket::INET->new(PeerAddr => $server_addr,
210             PeerPort => 'whois',
211             Proto => 'tcp')
212             or croak "Net::Whois: Can't connect to $server_name: $@";
213 1         95579 $sock->autoflush;
214 1         132 $sock;
215             }
216              
217             #----------------------------------------------------------------
218             # Net::Whois::Domain
219             #----------------------------------------------------------------
220              
221             package Net::Whois::Domain;
222 1     1   4 use Carp;
  1         1  
  1         1106  
223              
224             BEGIN {
225 1 50   1   2 if (eval { require Locale::Country }) {
  1         839  
226 1         40061 Locale::Country->import(qw(code2country country2code));
227             }else {
228 0 0       0 *code2country = sub { ($_[0] =~ /^[^\W\d_]{2}$/i) && $_[0] };
  0         0  
229 0         0 *country2code = sub { undef };
  0         0  
230             }
231             }
232              
233             sub new {
234 1 50   1   18 my $class = @_ ? shift : 'Net::Whois';
235 1 50       9 @_ == 1 or croak "usage: new $class DOMAIN";
236 1         2 my ($domain) = @_;
237 1         1 my $text;
238             my $retval;
239             # my $FH = new IO::File ">> whois.log" or croak "Could not open log";
240 0         0 my ($sock, $target_server);
241 0         0 my @fieldlist; # each element is one part of FQDN e.g. www.smartcard.com would be 3 entries 0-3 [0]=www [1]=smartcard [3]=com
242 0         0 my $tld;
243 0         0 my %info;
244              
245 1         5 @fieldlist = split /\./, $domain;
246 1         1 eval { # convert to one-entry/one-exit . replace individual out-of-path returns with die. eval will catch them.
247 1         2 $tld = $fieldlist[$#fieldlist];
248 1         2 $tld =~ tr /a-z/A-Z/; #uppercase key
249 1         2 $target_server = $TLDs {$tld};
250 1 50       3 $server_name = $target_server if defined $target_server;
251 1         3 $sock = Net::Whois::_connect();
252             # print $sock "dom $domain\x0d\x0a";
253 1         133 print $sock "$domain\x0d\x0a";
254             {
255 1         4 local $/; $text = <$sock>;
  1         6  
  1         107601  
256             }
257 1         7 undef $sock;
258 1 50       100 $text || die "No data returned from server";
259            
260 1 50       15 if ($text =~ /single out one record/) {
261 0 0       0 return unless $text =~ /\((.+?)\)[ \t]+\Q$domain\E\x0d?\x0a/i;
262 0         0 my $newdomain = $1;
263 0         0 $sock = Net::Whois::_connect();
264 0         0 print $sock "dom $newdomain\x0d\x0a";
265             {
266 0         0 local $/; $text = <$sock>;
  0         0  
  0         0  
267             }
268 0         0 undef $sock;
269 0 0       0 $text || die "No data from server";
270             }
271             # 7/21/99 Network Solutions now put a bunch of garbage text before the beginning of the actual record
272             # so we have to spin past it. ARIN records start with registrant name on the 2nd line. Both identify the whois server
273             # on the first line.
274 1         5 $text =~ s/^ +//gm;
275             # if (defined $FH) {
276             # print $FH $text;
277             # }
278              
279 1         21 my @text = split / *\x0d?\x0a/, $text;
280 1         6 for (@text) {s/^ +//}
  3         8  
281 1         3 my (@t, $t, $c);
282 1         3 my $flag = 1;
283 1         2 $t= shift @text;
284 1   33     17 until (!defined $t || $t =~ /Registrant/ || $t =~ /No match/)
      66        
285             {
286 2         19 $t = shift @text;
287             }
288 1         6 $t =~ s/^\s//; #trim whitespace
289 1 50       5 if ($t eq '') {
290 0         0 $t = shift @text;
291             }
292             #if domain exists next line up is "Registrant" which we don't want, we want the name and tag of registrant
293 1         26 $_ = $t;
294 1 50       12 if (/Registrant/) {
    50          
295 0         0 $t = shift @text;
296 0         0 $info{'MATCH'} = 1;
297             } elsif (/No match/) {
298 1         4 $info{'MATCH'} = 0;
299             }
300 1 50       9 if ($info{'MATCH'} ) {
301 0 0       0 @info{'NAME', 'TAG'} = ( $t =~ /^(.*)\s+\((\S+)\)$/)
302             or die "Registrant Name not found in returned information";
303            
304 0         0 @t = ();
305 0         0 push @t, shift @text while $text[0];
306 0         0 $t = $t[$#t];
307 0 0       0 if (! defined $t) {
    0          
    0          
    0          
    0          
308             # do nothing
309             } elsif ( $t =~ /^(?:usa|u\.\s*s\.\s*a\.)$/i) {
310 0         0 pop @t;
311 0         0 $t = 'US';
312             } elsif (code2country( $t)) {
313 0         0 pop @t;
314 0         0 $t = uc $t;
315             } elsif ( $c = country2code($t)) {
316 0         0 pop @t;
317 0         0 $t = uc $c;
318             } elsif ( $t =~ /,\s*([^,]+?)(?:\s+\d{5}(?:-\d{4})?)?$/) {
319 0 0       0 $t = $US_State{uc $1} ? 'US' : undef;
320             } else {
321 0         0 undef $t;
322             }
323 0         0 $info{ADDRESS} = [@t];
324 0         0 $info{COUNTRY} = $t;
325            
326 0         0 while (@text) {
327 0         0 $t = shift @text;
328 0 0       0 next if $t=~ /^$/; #discard blank line
329 0 0       0 if ( $t =~ s/^domain name:\s+(\S+)$//i) {
    0          
    0          
    0          
    0          
330 0         0 $info{DOMAIN} = $1;
331 0         0 $info{DOMAIN} =~ tr/A-Z/a-z/ ;
332             } elsif ( $t =~ /contact.*:$/i) {
333 0         0 my @ctypes = ( $t =~ /\b(\S+) contact/ig);
334 0         0 my @c;
335 0         0 while ( $text[0] ) {
336 0 0       0 last if $text[0] =~ /contact.*:$/i;
337 0         0 push @c, shift @text;
338             }
339 0         0 @{ $info{CONTACTS} } {map {uc} @ctypes} = (\@c) x @ctypes;
  0         0  
  0         0  
340             } elsif ( $t =~ /^Record created on (\S+)\.$/) {
341 0         0 $info{RECORD_CREATED} = $1;
342             } elsif ( $t =~ /^Record last updated on (\S+)\.$/) {
343 0         0 $info{RECORD_UPDATED} = $1;
344             } elsif ( $t =~ /^Domain servers/i) {
345 0         0 my @s;
346 0 0       0 shift @text unless $text[0];
347 0         0 while ( $t = shift @text) {
348             #translate to lower case to match useage in DNS
349 0         0 $t =~ tr/A-Z/a-z/;
350 0         0 push @s, [split /\s+/, $t];
351             }
352 0         0 $info{SERVERS} = \@s;
353             }
354             }
355             }
356             };
357            
358 1 50       3 if ($@) {
359 0         0 carp $@;
360 0         0 undef $retval;
361             }
362             else {
363 1         7 $retval = bless [\%info], $class;
364             }
365 1         8 return $retval;
366             }
367              
368             sub domain {
369 0     0   0 my $self = shift;
370 0         0 $self->[0]->{DOMAIN};
371             }
372              
373             sub name {
374 0     0   0 my $self = shift;
375 0         0 $self->[0]->{NAME};
376             }
377              
378             sub tag {
379 0     0   0 my $self = shift;
380 0         0 $self->[0]->{TAG};
381             }
382              
383             sub address {
384 0     0   0 my $self = shift;
385 0         0 my $addr = $self->[0]->{ADDRESS};
386 0 0       0 wantarray ? @ $addr : join "\n", @$addr;
387             }
388              
389             sub country {
390 0     0   0 my $self = shift;
391 0         0 $self->[0]->{COUNTRY};
392             }
393              
394             sub contacts {
395 0     0   0 my $self = shift;
396 0         0 $self->[0]->{CONTACTS};
397             }
398              
399             sub servers {
400 0     0   0 my $self = shift;
401 0         0 $self->[0]->{SERVERS};
402             }
403              
404             sub record_created {
405 0     0   0 my $self = shift;
406 0         0 $self->[0]->{RECORD_CREATED};
407             }
408              
409             sub record_updated {
410 0     0   0 my $self = shift;
411 0         0 $self->[0]->{RECORD_UPDATED};
412             }
413              
414             sub ok {
415 1     1   9 my $self = shift;
416 1         12 $self->[0]->{MATCH};
417             }
418             ;
419              
420              
421              
422              
423              
424              
425              
426              
427