File Coverage

blib/lib/Net/Whois/Raw.pm
Criterion Covered Total %
statement 138 250 55.2
branch 47 136 34.5
condition 31 90 34.4
subroutine 20 26 76.9
pod 3 11 27.2
total 239 513 46.5


line stmt bran cond sub pod time code
1             package Net::Whois::Raw;
2             $Net::Whois::Raw::VERSION = '2.99037';
3             # ABSTRACT: Get Whois information of domains and IP addresses.
4              
5             require 5.008_001;
6 4     4   2630 use Net::Whois::Raw::Common ();
  4         11  
  4         102  
7 4     4   27 use Net::Whois::Raw::Data ();
  4         8  
  4         63  
8              
9 4     4   17 use warnings;
  4         8  
  4         130  
10 4     4   20 use strict;
  4         7  
  4         82  
11              
12 4     4   19 use Carp;
  4         5  
  4         313  
13 4     4   2326 use IO::Socket::IP;
  4         125619  
  4         22  
14 4     4   1971 use Encode;
  4         8  
  4         288  
15 4     4   21 use utf8;
  4         8  
  4         26  
16              
17             our @EXPORT = qw( whois get_whois );
18              
19             our ($OMIT_MSG, $CHECK_FAIL, $CHECK_EXCEED, $CACHE_DIR, $TIMEOUT, $DEBUG) = (0) x 7;
20              
21             our $CACHE_TIME = 60;
22             our $SET_CODEPAGE = '';
23             our $SILENT_MODE = 0;
24             our $QUERY_SUFFIX = '';
25              
26             our (%notfound, %strip, @SRC_IPS, %POSTPROCESS);
27              
28             # internal variable, used for save whois_server->ip relations
29             my $_IPS = {};
30              
31             our $class = __PACKAGE__;
32              
33             my $last_cache_clear_time;
34              
35             sub whois_config {
36 0     0 0 0 my ($par) = @_;
37 0         0 my @parnames = qw(OMIT_MSG CHECK_FAIL CHECK_EXCEED CACHE_DIR CACHE_TIME TIMEOUT @SRC_IPS);
38 0         0 foreach my $parname (@parnames) {
39 0 0       0 if (exists($par->{$parname})) {
40 4     4   884 no strict 'refs';
  4         11  
  4         365  
41 0         0 ${$parname} = $par->{$parname};
  0         0  
42             }
43             }
44             }
45              
46             sub whois_config_data {
47 0     0 0 0 my $net_whois_raw_data = shift;
48              
49 4     4   23 no strict 'refs';
  4         8  
  4         10548  
50              
51 0         0 foreach my $k (keys %$net_whois_raw_data) {
52 0         0 %{'Net::Whois::Raw::Data::'.$k} = (
53 0         0 %{'Net::Whois::Raw::Data::'.$k},
54 0 0       0 %{ $net_whois_raw_data->{ $k } || {} },
  0         0  
55             );
56             }
57             }
58              
59             # get cached whois
60             sub whois {
61 2     2 1 864 my ($dom, $server, $which_whois) = @_;
62              
63 2   50     5 $which_whois ||= 'QRY_LAST';
64              
65 2         9 my $res = Net::Whois::Raw::Common::get_from_cache( "$dom-$which_whois", $CACHE_DIR, $CACHE_TIME );
66              
67 2         4 my ($res_text, $res_srv, $res_text2);
68              
69 2 100       7 if ($res) {
70 1 50 33     9 if ($which_whois eq 'QRY_FIRST') {
    50          
    50          
71 0         0 $res_text = $res->[0]->{text};
72 0         0 $res_srv = $res->[0]->{srv};
73             } elsif ($which_whois eq 'QRY_LAST' || !defined($which_whois)) {
74 0         0 $res_text = $res->[-1]->{text};
75 0         0 $res_srv = $res->[-1]->{srv};
76             } elsif ($which_whois eq 'QRY_ALL') {
77 1         4 return $res;
78             }
79             }
80             else {
81 1         3 ($res_text, $res_srv) = get_whois($dom, $server, $which_whois);
82             }
83              
84 1 50 33     5 $res_srv = '' if $res_srv && $res_srv eq 'www_whois';
85              
86 1 50 33     6 if ( defined $res_text && $which_whois ne 'QRY_ALL' ) {
87 0         0 utf8::decode( $res_text ); # Perl whyly loss utf8 flag
88              
89 0 0       0 $res_text = encode( $SET_CODEPAGE, $res_text ) if $SET_CODEPAGE;
90             }
91              
92 1 50       6 return wantarray ? ($res_text, $res_srv) : $res_text;
93             }
94              
95             # obtain whois
96             sub get_whois {
97 1     1 1 2 my ($dom, $srv, $which_whois) = @_;
98 1   50     3 $which_whois ||= 'QRY_LAST';
99              
100 1 50       2 my $whois = get_all_whois( $dom, $srv, $which_whois eq 'QRY_FIRST' )
101             or return undef;
102              
103 1         8 Net::Whois::Raw::Common::write_to_cache( "$dom-$which_whois", $whois, $CACHE_DIR );
104              
105 1 50       7 if ($which_whois eq 'QRY_LAST') {
    50          
106 0         0 my $thewhois = $whois->[-1];
107 0 0       0 return wantarray ? ($thewhois->{text}, $thewhois->{srv}) : $thewhois->{text};
108             }
109             elsif ($which_whois eq 'QRY_FIRST') {
110 0         0 my $thewhois = $whois->[0];
111 0 0       0 return wantarray ? ($thewhois->{text}, $thewhois->{srv}) : $thewhois->{text};
112             }
113             else {
114 1         5 return $whois;
115             }
116             }
117              
118             sub get_all_whois {
119 1     1 0 2 my ($dom, $srv, $norecurse) = @_;
120              
121 1         1 my $is_ns = 0;
122 1 50       6 $is_ns = 1 if $dom =~ s/[.]NS$//i;
123              
124 1   33     7 $srv ||= Net::Whois::Raw::Common::get_server( $dom, $is_ns );
125              
126 1 50       2 if ($srv eq 'www_whois') {
127 0         0 my ($responce, $ishtml) = www_whois_query( $dom );
128 0 0       0 return $responce ? [ { text => $responce, srv => $srv } ] : $responce;
129             }
130              
131 1         3 my @whois = recursive_whois( $dom, $srv, [], $norecurse, $is_ns );
132              
133 1         3 my $whois_answers = process_whois_answers( \@whois, $dom );
134              
135 1         5 return $whois_answers;
136             }
137              
138             sub process_whois_answers {
139 1     1 0 4 my ( $raw_whois, $dom ) = @_;
140              
141 1         2 my @processed_whois;
142              
143 1         3 my $level = 0;
144 1         3 for my $whois_rec ( @$raw_whois ) {
145 2         4 $whois_rec->{level} = $level;
146             my ( $text, $error ) = Net::Whois::Raw::Common::process_whois(
147             $dom,
148             $whois_rec->{srv},
149             $whois_rec->{text},
150 2         10 $CHECK_FAIL, $OMIT_MSG, $CHECK_EXCEED,
151             );
152              
153 2 0 33     17 die $error if $error && $error eq 'Connection rate exceeded'
      0        
      33        
154             && ( $level == 0 || $CHECK_EXCEED == 2 );
155              
156 2 50 33     6 if ( $text || $level == 0 ) {
157 2         5 $whois_rec->{text} = $text;
158 2         4 push @processed_whois, $whois_rec;
159             }
160 2         4 $level++;
161             }
162              
163 1         3 return \@processed_whois;
164             }
165              
166             sub _referral_server {
167 139     139   1460 /ReferralServer:\s*r?whois:\/\/([-.\w]+(?:\:\d+)?)/
168             }
169              
170             sub recursive_whois {
171 2     2 0 5 my ( $dom, $srv, $was_srv, $norecurse, $is_ns ) = @_;
172              
173 2         4 my $lines = whois_query( $dom, $srv, $is_ns );
174 2         23 my $whois = join '', @$lines;
175              
176 2         6 my ( $newsrv, $registrar );
177 2         6 for ( @$lines ) {
178 139   66     210 $registrar ||= /Registrar/ || /Registered through/;
      100        
179              
180             # Skip urls as recursive whois servers
181 139 100 66     597 if ( $registrar && !$norecurse && /whois server:\s*([a-z0-9\-_\.]+)\b/i ) {
    50 100        
    50 33        
    50 33        
    50 33        
    50 33        
    50 33        
182 2         9 $newsrv = lc $1;
183             }
184             elsif ( $whois =~ /To single out one record, look it up with \"xxx\",/s ) {
185 0         0 return recursive_whois( "=$dom", $srv, $was_srv );
186             }
187             elsif ( !$norecurse && ( my ( $rs ) = _referral_server() ) ) {
188 0         0 $newsrv = $rs;
189 0         0 last;
190             }
191             elsif ( /Contact information can be found in the (\S+)\s+database/ ) {
192 0         0 $newsrv = $Net::Whois::Raw::Data::ip_whois_servers{ $1 };
193             }
194             elsif ( ( /OrgID:\s+(\w+)/ || /descr:\s+(\w+)/ ) && Net::Whois::Raw::Common::is_ipaddr( $dom ) ) {
195 0         0 my $val = $1;
196 0 0       0 if ( $val =~ /^(?:RIPE|APNIC|KRNIC|LACNIC)$/ ) {
197 0         0 $newsrv = $Net::Whois::Raw::Data::ip_whois_servers{ $val };
198 0         0 last;
199             }
200             }
201             elsif ( /^\s+Maintainer:\s+RIPE\b/ && Net::Whois::Raw::Common::is_ipaddr( $dom ) ) {
202 0         0 $newsrv = $Net::Whois::Raw::Data::servers{RIPE};
203             }
204             elsif ( $is_ns && $srv ne $Net::Whois::Raw::Data::servers{NS} ) {
205 0         0 $newsrv = $Net::Whois::Raw::Data::servers{NS};
206             }
207             }
208              
209 2 0 33     17 if (
      33        
210             defined $newsrv && (
211             # Bypass recursing to custom servers
212             $Net::Whois::Raw::Data::whois_servers_no_recurse{ $newsrv }
213             # Bypass recursing to WHOIS servers with no IDN support
214             || $dom =~ /^xn--/i && $newsrv && $Net::Whois::Raw::Data::whois_servers_with_no_idn_support{ $newsrv }
215             )
216             ) {
217 0         0 $newsrv = undef;
218             }
219              
220 2         18 my @whois_recs = ( { text => $whois, srv => $srv } );
221 2 100 66     13 if ( $newsrv && $newsrv ne $srv ) {
222 1 50       3 warn "recurse to $newsrv\n" if $DEBUG;
223              
224 1 50       5 return () if grep { $_ eq $newsrv } @$was_srv;
  0         0  
225              
226 1         2 my @new_whois_recs = eval { recursive_whois( $dom, $newsrv, [ @$was_srv, $srv ], 0, $is_ns ) };
  1         9  
227 1 50       5 my $new_whois = scalar @new_whois_recs ? $new_whois_recs[0]->{text} : '';
228 1         4 my $notfound = $Net::Whois::Raw::Data::notfound{ $newsrv };
229              
230 1 50 33     44 if ( $new_whois && !$@ && not ( $notfound && $new_whois =~ /$notfound/im ) ) {
      33        
      33        
231 1 50       2 if ( $is_ns ) {
232 0         0 unshift @whois_recs, @new_whois_recs;
233             }
234             else {
235 1         3 push @whois_recs, @new_whois_recs;
236             }
237             }
238             else {
239 0 0       0 warn "recursive query failed\n" if $DEBUG;
240             }
241             }
242              
243 2         20 return @whois_recs;
244             }
245              
246             sub whois_query {
247 2     2 0 5 my ($dom, $srv, $is_ns) = @_;
248              
249             # Prepare query
250 2         7 my $whoisquery = Net::Whois::Raw::Common::get_real_whois_query($dom, $srv, $is_ns);
251              
252             # Prepare for query
253              
254 2         4 my (@sockparams, $sock);
255 2         5 my (undef, $tld) = Net::Whois::Raw::Common::split_domain($dom);
256              
257 2         4 $tld = uc $tld;
258 2         4 my $rotate_reference = undef;
259              
260             ### get server for query
261 2         9 my $server4query = Net::Whois::Raw::Common::get_server($dom);
262              
263 2 50       5 if ( Net::Whois::Raw::Common::is_ip6addr( $srv ) ) {
264 0         0 $srv = "[$srv]";
265             }
266              
267 2 50       9 my $srv_and_port = $srv =~ /\:\d+$/ ? $srv : "$srv:43";
268 2 50       25 if ($class->can('whois_query_sockparams')) {
    50          
    50          
    50          
269 0         0 @sockparams = $class->whois_query_sockparams ($dom, $srv);
270             }
271             # hook for outside defined socket
272             elsif ($class->can('whois_query_socket')) {
273 0         0 $sock = $class->whois_query_socket ($dom, $srv);
274             }
275             elsif (my $ips_arrayref = get_ips_for_query($server4query)) {
276 0         0 $rotate_reference = $ips_arrayref;
277             }
278             elsif (scalar(@SRC_IPS)) {
279 0         0 $rotate_reference = \@SRC_IPS;
280             }
281             else {
282 2         4 @sockparams = $srv_and_port;
283             }
284              
285              
286 2 50       6 if ($rotate_reference) {
287 0         0 my $src_ip = $rotate_reference->[0];
288 0         0 push @$rotate_reference, shift @$rotate_reference; # rotate ips
289 0         0 @sockparams = (PeerAddr => $srv_and_port, LocalAddr => $src_ip);
290             }
291              
292 2 50       13 print "QUERY: $whoisquery; SRV: $srv, ".
293             "OMIT_MSG: $OMIT_MSG, CHECK_FAIL: $CHECK_FAIL, CACHE_DIR: $CACHE_DIR, ".
294             "CACHE_TIME: $CACHE_TIME, TIMEOUT: $TIMEOUT\n" if $DEBUG >= 2;
295              
296 2         3 my $prev_alarm = undef;
297 2         4 my $t0 = time();
298              
299 2         2 my @lines;
300              
301             # Make query
302              
303             {
304 2     0   2 local $SIG{'ALRM'} = sub { die "Connection timeout to $srv" };
  2         43  
  0         0  
305 2         6 eval {
306              
307 2 50       6 $prev_alarm = alarm $TIMEOUT if $TIMEOUT;
308              
309 2 50       4 unless ( $sock ) {
310 2 50       13 $sock = IO::Socket::IP->new( @sockparams )
311             or die "$srv: $!: " . join( ', ', @sockparams );
312             }
313              
314 2 50       532332 if ($class->can ('whois_socket_fixup')) {
315 0         0 my $new_sock = $class->whois_socket_fixup ($sock);
316 0 0       0 $sock = $new_sock if $new_sock;
317             }
318              
319 2 50       9 if ($DEBUG > 2) {
320 0         0 require Data::Dumper;
321 0         0 print "Socket: ". Data::Dumper::Dumper($sock);
322             }
323              
324 2 50       7 if ($QUERY_SUFFIX) {
325 0         0 $whoisquery .= $QUERY_SUFFIX;
326             }
327              
328 2         31 $sock->print( $whoisquery, "\r\n" );
329             # TODO: $soc->read, parameters for read chunk size, max content length
330             # Now you can redefine SOCK_CLASS::getline method as you want
331 2         380 while (my $str = $sock->getline) {
332 139         324585 push @lines, $str;
333             }
334 2         81 $sock->close;
335             };
336             {
337 2         235 local $@; # large code block below, so preserve previous exception.
  2         5  
338 2 50       9 if (defined $prev_alarm) { # if we ever set new alarm
339 0 0       0 if ($prev_alarm == 0) { # there was no alarm previously
340 0         0 alarm 0; # clear it
341             } else { # there was an alarm previously
342 0         0 $prev_alarm -= (time()- $t0); # try best to substract time elapsed
343 0 0       0 $prev_alarm = 1 if $prev_alarm < 1; # we still need set it to something non-zero
344 0         0 alarm $prev_alarm; # set it
345             }
346             }
347             }
348 2 50       47 Carp::confess $@ if $@;
349             }
350              
351 2         8 foreach (@lines) { s/\r//g; }
  139         192  
352              
353 2 50       8 print "Received ".scalar(@lines)." lines\n" if $DEBUG >= 2;
354              
355 2         33 return \@lines;
356             }
357              
358             sub www_whois_query {
359 0     0 0 0 my ($dom) = (lc shift);
360              
361 0         0 my ($resp, $url);
362 0         0 my ($name, $tld) = Net::Whois::Raw::Common::split_domain( $dom );
363              
364 0         0 my $http_query_urls = Net::Whois::Raw::Common::get_http_query_url($dom);
365              
366 0         0 foreach my $qurl ( @{$http_query_urls} ) {
  0         0  
367              
368             # load-on-demand
369 0 0       0 unless ($INC{'LWP/UserAgent.pm'}) {
370 0         0 require LWP::UserAgent;
371 0         0 require HTTP::Request;
372 0         0 require HTTP::Headers;
373 0         0 require URI::URL;
374 0         0 import LWP::UserAgent;
375 0         0 import HTTP::Request;
376 0         0 import HTTP::Headers;
377 0         0 import URI::URL;
378             }
379              
380 0 0 0     0 my $referer = delete $qurl->{form}{referer} if $qurl->{form} && defined $qurl->{form}{referer};
381 0 0 0     0 my $method = ( $qurl->{form} && scalar(keys %{$qurl->{form}}) ) ? 'POST' : 'GET';
382              
383 0         0 my $ua;
384              
385             # hook for outside defined lwp
386 0 0       0 if ($class->can ('whois_query_ua')) {
387 0         0 $ua = $class->whois_query_ua ($dom);
388             }
389              
390 0 0       0 unless($ua){
391 0         0 $ua = new LWP::UserAgent( parse_head => 0 );
392 0         0 $ua->agent('Mozilla/5.0 (X11; U; Linux i686; ru; rv:1.9.0.5) Gecko/2008121622 Fedora/3.0.5-1.fc10 Firefox/3.0.5');
393             }
394 0         0 my $header = HTTP::Headers->new;
395 0 0       0 $header->header('Referer' => $referer) if $referer;
396 0         0 my $req = new HTTP::Request $method, $qurl->{url}, $header;
397              
398 0 0       0 if ($method eq 'POST') {
399 0         0 require URI::URL;
400 0         0 import URI::URL;
401              
402 0         0 my $curl = url("http:");
403 0         0 $req->content_type('application/x-www-form-urlencoded');
404 0         0 $curl->query_form( %{$qurl->{form}} );
  0         0  
405 0         0 $req->content( $curl->equery );
406             }
407              
408 0         0 $resp = eval {
409 0     0   0 local $SIG{ALRM} = sub { die "www_whois connection timeout" };
  0         0  
410 0         0 alarm 10;
411 0         0 $ua->request($req)->content;
412             };
413 0         0 alarm 0;
414              
415 0 0 0     0 if ( !$resp || $@ || $resp =~ /www_whois connection timeout/ || $resp =~ /^500 Can\'t connect/ ) {
      0        
      0        
416 0         0 undef $resp;
417             }
418             else {
419 0         0 $url = $qurl->{url};
420 0         0 last;
421             }
422             }
423              
424 0 0       0 return undef unless $resp;
425              
426 0         0 chomp $resp;
427 0         0 $resp =~ s/\r//g;
428              
429 0         0 my $ishtml;
430              
431 0         0 $resp = Net::Whois::Raw::Common::parse_www_content($resp, $tld, $url, $CHECK_EXCEED);
432              
433 0 0       0 return wantarray ? ($resp, $ishtml) : $resp;
434             }
435              
436              
437             sub import {
438 2     2   23 my $mypkg = shift;
439 2         5 my $callpkg = caller;
440              
441 4     4   57 no strict 'refs';
  4         6  
  4         880  
442              
443             # export subs
444 2         6 *{"$callpkg\::$_"} = \&{"$mypkg\::$_"} foreach ((@EXPORT, @_));
  4         38  
  4         16  
445             }
446              
447              
448             sub set_ips_for_server {
449 0     0 1 0 my ($server, $ips) = @_;
450              
451 0 0 0     0 croak "Missing params" if (!$ips || !$server);
452              
453 0         0 $server = lc $server;
454 0         0 $_IPS->{$server} = $ips;
455             }
456              
457              
458             sub get_ips_for_query {
459 2     2 0 5 my ($server) = @_;
460              
461 2         3 $server = lc $server;
462 2 50       6 if ($_IPS->{$server}) {
463 0         0 return $_IPS->{$server};
464             }
465 2         6 return undef;
466             }
467              
468              
469             1;
470              
471             __END__