File Coverage

blib/lib/Net/Whois/Raw/Common.pm
Criterion Covered Total %
statement 145 269 53.9
branch 52 140 37.1
condition 18 72 25.0
subroutine 22 25 88.0
pod 0 15 0.0
total 237 521 45.4


line stmt bran cond sub pod time code
1             package Net::Whois::Raw::Common;
2             $Net::Whois::Raw::Common::VERSION = '2.99037';
3             # ABSTRACT: Helper for Net::Whois::Raw.
4              
5 4     4   123366 use Encode;
  4         53553  
  4         353  
6 4     4   30 use warnings;
  4         8  
  4         100  
7 4     4   19 use strict;
  4         8  
  4         87  
8 4     4   1601 use Regexp::IPv6 qw($IPv6_re);
  4         3149  
  4         469  
9 4     4   3828 use Net::Whois::Raw::Data ();
  4         121  
  4         200  
10 4     4   1116 use Net::Whois::Raw ();
  4         11  
  4         82  
11              
12 4     4   17 use utf8;
  4         7  
  4         39  
13              
14             # func prototype
15             sub untaint(\$);
16              
17             # get whois from cache
18             sub get_from_cache {
19 3     3 0 11 my ($query, $cache_dir, $cache_time) = @_;
20              
21 3 50       10 return undef unless $cache_dir;
22 3 100       173 mkdir $cache_dir unless -d $cache_dir;
23              
24 3         10 my $now = time;
25             # clear the cache
26 3         242 foreach my $fn ( glob("$cache_dir/*") ) {
27 5 50       63 my $mtime = ( stat($fn) )[9] or next;
28 5         14 my $elapsed = $now - $mtime;
29 5         13 untaint $fn; untaint $elapsed;
  5         14  
30 5 50       20 unlink $fn if ( $elapsed / 60 >= $cache_time );
31             }
32              
33 3         8 my $result;
34 3 100       40 if ( -e "$cache_dir/$query.00" ) {
35 2         6 my $level = 0;
36 2         68 while ( open( my $cache_fh, '<', "$cache_dir/$query.".sprintf( "%02d", $level ) ) ) {
37 5         81 $result->[$level]->{srv} = <$cache_fh>;
38 5         20 chomp $result->[$level]->{srv};
39 5         146 $result->[$level]->{text} = join "", <$cache_fh>;
40 5 50 33     28 if ( !$result->[$level]->{text} and $Net::Whois::Raw::CHECK_FAIL ) {
41 0         0 $result->[$level]->{text} = undef ;
42             }
43             else {
44 5         73 $result->[$level]->{text} = decode_utf8( $result->[$level]->{text} );
45             }
46 5         66 $level++;
47 5         174 close $cache_fh;
48             }
49             }
50              
51 3         13 return $result;
52             }
53              
54             # write whois to cache
55             sub write_to_cache {
56 2     2 0 711 my ($query, $result, $cache_dir) = @_;
57              
58 2 50 33     16 return unless $cache_dir && $result;
59 2 50       43 mkdir $cache_dir unless -d $cache_dir;
60              
61 2         11 untaint $query; untaint $cache_dir;
  2         7  
62              
63 2         7 my $level = 0;
64 2         4 foreach my $res ( @{$result} ) {
  2         6  
65 5 50       17 local $res->{text} = $res->{whois} if not exists $res->{text};
66              
67 5 50 33     32 next if defined $res->{text} && !$res->{text} || !defined $res->{text};
      33        
68 5         12 my $enc_text = $res->{text};
69 5         18 utf8::encode( $enc_text );
70 5         21 my $postfix = sprintf("%02d", $level);
71 5 50       332 if ( open( my $cache_fh, '>', "$cache_dir/$query.$postfix" ) ) {
72             print $cache_fh $res->{srv} ? $res->{srv} :
73 5 50       71 ( $res->{server} ? $res->{server} : '')
    100          
74             , "\n";
75              
76 5 50       19 print $cache_fh $enc_text ? $enc_text : '';
77              
78 5         163 close $cache_fh;
79 5         86 chmod 0666, "$cache_dir/$query.$postfix";
80             }
81 5         30 $level++;
82             }
83              
84             }
85              
86             # remove copyright messages, check for existance
87             sub process_whois {
88 2     2 0 6 my ( $query, $server, $whois, $CHECK_FAIL, $OMIT_MSG, $CHECK_EXCEED ) = @_;
89              
90 2         5 $server = lc $server;
91 2         5 my ( $name, $tld ) = split_domain( $query );
92              
93             # use string as is
94 4     4   2344 no utf8;
  4         8  
  4         23  
95              
96 2 50       6 if ( $CHECK_EXCEED ) {
97 0         0 my $exceed = $Net::Whois::Raw::Data::exceed{ $server };
98              
99 0 0 0     0 if ( $exceed && $whois =~ /$exceed/s) {
100 0         0 return $whois, 'Connection rate exceeded';
101             }
102             }
103              
104 2 50       6 $whois = _strip_trailer_lines( $whois ) if $OMIT_MSG;
105              
106 2 50 33     8 if ( $CHECK_FAIL || $OMIT_MSG ) {
107              
108 0         0 my $notfound = $Net::Whois::Raw::Data::notfound{ $server };
109 0         0 my $strip = $Net::Whois::Raw::Data::strip{ $server };
110 0 0       0 my @strip = $strip ? @$strip : ();
111 0         0 my @lines;
112              
113             MAIN:
114 0         0 for ( split /\n/, $whois ) {
115 0 0 0     0 if ( $CHECK_FAIL && $notfound && /$notfound/ ) {
      0        
116 0         0 return undef, "Not found";
117             }
118              
119 0 0       0 if ( $OMIT_MSG ) {
120 0         0 for my $re ( @strip ) {
121 0 0       0 next MAIN if /$re/;
122             }
123             }
124              
125 0         0 push @lines, $_;
126             }
127              
128 0         0 $whois = join "\n", @lines, '';
129              
130 0 0       0 if ( $OMIT_MSG ) {
131 0         0 $whois =~ s/(?:\s*\n)+$/\n/s;
132 0         0 $whois =~ s/^\n+//s;
133 0         0 $whois =~ s|\n{3,}|\n\n|sg;
134             }
135             }
136              
137 2 50       6 if ( defined $Net::Whois::Raw::Data::postprocess{ $server } ) {
138 0         0 $whois = $Net::Whois::Raw::Data::postprocess{ $server }->( $whois );
139             }
140              
141 2 50       6 if ( defined $Net::Whois::Raw::POSTPROCESS{ $server } ) {
142 0         0 $whois = $Net::Whois::Raw::POSTPROCESS{ $server }->( $whois );
143             }
144              
145 2 50       7 if ( defined $Net::Whois::Raw::Data::codepages{ $server } ) {
146 0         0 $whois = decode( $Net::Whois::Raw::Data::codepages{ $server }, $whois );
147             }
148             else {
149 2         25 utf8::decode( $whois );
150             }
151              
152 2         6 return $whois, undef;
153             }
154              
155             # Tries to strip trailer lines of whois
156             sub _strip_trailer_lines {
157 3     3   444 my ( $whois ) = @_;
158              
159 3         9 for my $re ( @Net::Whois::Raw::Data::strip_regexps ) {
160 3         31 $whois =~ s/$re//;
161             }
162              
163 3         17 return $whois;
164             }
165              
166             # get whois-server for domain / tld
167             sub get_server {
168 6     6 0 17 my ( $dom, $is_ns, $tld ) = @_;
169              
170 6   66     33 $tld ||= get_dom_tld( $dom );
171 6         10 $tld = uc $tld;
172              
173 6 100       18 if ( grep { $_ eq $tld } @Net::Whois::Raw::Data::www_whois ) {
  12         32  
174 1         5 return 'www_whois';
175             }
176              
177 5 50       12 if ( $is_ns ) {
178             return $Net::Whois::Raw::Data::servers{ $tld . '.NS' }
179 0   0     0 || $Net::Whois::Raw::Data::servers{ 'NS' };
180             }
181              
182 5   33     33 return lc( $Net::Whois::Raw::Data::servers{ $tld } || "whois.nic.$tld" );
183             }
184              
185             sub get_real_whois_query{
186 6     6 0 15 my ( $whoisquery, $srv, $is_ns ) = @_;
187              
188 6 50       17 $srv .= '.ns' if $is_ns;
189              
190 6 100 66     33 if ( $srv eq 'whois.crsnic.net' && domain_level( $whoisquery ) == 2 ) {
    100          
191 2         10 return "domain $whoisquery";
192             }
193             elsif ( $Net::Whois::Raw::Data::query_prefix{ $srv } ) {
194 2         12 return $Net::Whois::Raw::Data::query_prefix{ $srv } . $whoisquery;
195             }
196              
197 2         7 return $whoisquery;
198             }
199              
200             # get domain TLD
201             sub get_dom_tld {
202 16     16 0 34 my ($dom) = @_;
203              
204 16         18 my $tld;
205 16 100 66     32 if ( is_ipaddr($dom) || is_ip6addr($dom) ) {
    100          
206 1         4 $tld = "IP";
207             }
208             elsif ( domain_level($dom) == 1 ) {
209 1         3 $tld = "NOTLD";
210             }
211             else {
212 14         46 my @tokens = split( /\./, $dom );
213            
214             # try to get the longest known tld for this domain
215 14         42 for my $i ( 1..$#tokens ) {
216 14         46 my $tld_try = join '.', @tokens[$i..$#tokens];
217 14 100       106 if ( exists $Net::Whois::Raw::Data::servers{ uc $tld_try } ) {
218 13         22 $tld = $tld_try;
219 13         21 last;
220             }
221             }
222            
223 14 100       31 $tld = $tokens[-1] unless $tld;
224             }
225              
226 16         71 return $tld;
227             }
228              
229             # get URL for query via HTTP
230             # %param: domain*
231             sub get_http_query_url {
232 0     0 0 0 my ($domain) = @_;
233              
234 0         0 my ($name, $tld) = split_domain($domain);
235 0         0 my @http_query_data;
236             # my ($url, %form);
237              
238 0 0 0     0 if ($tld eq 'ru' || $tld eq 'su') {
    0          
    0          
    0          
    0          
    0          
    0          
    0          
239 0         0 my $data = {
240             url => "http://www.nic.ru/whois/?domain=$name.$tld",
241             form => '',
242             };
243 0         0 push @http_query_data, $data;
244             }
245             elsif ($tld eq 'ip') {
246 0         0 my $data = {
247             url => "http://www.nic.ru/whois/?ip=$name",
248             form => '',
249             };
250 0         0 push @http_query_data, $data;
251             }
252             elsif ($tld eq 'ws') {
253 0         0 my $data = {
254             url => "http://worldsite.ws/utilities/lookup.dhtml?domain=$name&tld=$tld",
255             form => '',
256             };
257 0         0 push @http_query_data, $data;
258             }
259             elsif ($tld eq 'kz') {
260 0         0 my $data = {
261             url => "http://www.nic.kz/cgi-bin/whois?query=$name.$tld&x=0&y=0",
262             form => '',
263             };
264 0         0 push @http_query_data, $data;
265             }
266             elsif ($tld eq 'vn') {
267             # VN doesn't have web whois at the moment...
268 0         0 my $data = {
269             url => "http://www.tenmien.vn/jsp/jsp/tracuudomain1.jsp",
270             form => {
271             cap2 => ".$tld",
272             referer => 'http://www.vnnic.vn/english/',
273             domainname1 => $name,
274             },
275             };
276 0         0 push @http_query_data, $data;
277             }
278             elsif ($tld eq 'ac') {
279 0         0 my $data = {
280             url => "http://nic.ac/cgi-bin/whois?query=$name.$tld",
281             form => '',
282             };
283 0         0 push @http_query_data, $data;
284             }
285             elsif ($tld eq 'bz') {
286 0         0 my $data = {
287             url => "http://www.test.bz/Whois/index.php?query=$name&output=nice&dotname=.$tld&whois=Search",
288             };
289 0         0 push @http_query_data, $data;
290             }
291             elsif ($tld eq 'tj') {
292             #my $data = {
293             # url => "http://get.tj/whois/?lang=en&domain=$domain",
294             # from => '',
295             #};
296             #push @http_query_data, $data;
297              
298             # first level on nic.tj
299             #$data = {
300             # url => "http://www.nic.tj/cgi/lookup2?domain=$name",
301             # from => '',
302             #};
303             #push @http_query_data, $data;
304              
305             # second level on nic.tj
306 0         0 my $data = {
307             url => "http://www.nic.tj/cgi/whois?domain=$name",
308             from => '',
309             };
310 0         0 push @http_query_data, $data;
311              
312             #$data = {
313             # url => "http://ns1.nic.tj/cgi/whois?domain=$name",
314             # from => '',
315             #};
316             #push @http_query_data, $data;
317              
318             #$data = {
319             # url => "http://62.122.137.16/cgi/whois?domain=$name",
320             # from => '',
321             #};
322             #push @http_query_data, $data;
323             }
324              
325             # return $url, %form;
326 0         0 return \@http_query_data;
327             }
328              
329             sub have_reserve_url {
330 0     0 0 0 my ( $tld ) = @_;
331              
332 0         0 my %tld_list = (
333             'tj' => 1,
334             );
335              
336 0         0 return defined $tld_list{$tld};
337             }
338              
339             # Parse content received from HTTP server
340             # %param: resp*, tld*
341             sub parse_www_content {
342 1     1 0 723 my ($resp, $tld, $url, $CHECK_EXCEED) = @_;
343              
344 1         5 chomp $resp;
345 1         5 $resp =~ s/\r//g;
346              
347 1         3 my $ishtml;
348              
349 1 50 33     38 if ( $tld eq 'ru' || $tld eq 'su' ) {
    50 33        
    50 33        
    50 33        
    50 33        
    50          
    50          
    50          
    50          
    50          
350              
351 0         0 $resp = decode( 'koi8-r', $resp );
352              
353 0         0 (undef, $resp) = split('',$resp);
354 0         0 ($resp) = split('
', $resp); 355 0         0 $resp =~ s/ / /gi; 356 0         0 $resp =~ s/<([^>]|\n)*>//gi; 357               358 4 0   4   5228 return 0 if $resp=~ m/Доменное имя .*? не зарегистрировано/i;   4         10     4         54     0         0   359               360 0 0 0     0 $resp = 'ERROR' if $resp =~ m/Error:/i || $resp !~ m/Информация о домене .+? \(по данным WHOIS.RIPN.NET\):/; 361             #TODO: errors 362               363             } 364             elsif ($tld eq 'ip') { 365               366 0         0 $resp = decode_utf8( $resp ); 367               368 0 0       0 return 0 unless $resp =~ m|

(.+?)

|s; 369               370 0         0 $resp = $1; 371               372 0         0 $resp =~ s|||g; 373 0         0 $resp =~ s|||g; 374 0         0 $resp =~ s|
||g; 375 0         0 $resp =~ s| | |g; 376               377             } 378             elsif ($tld eq 'ws') { 379               380 0         0 $resp = decode_utf8( $resp ); 381               382 0 0       0 if ($resp =~ /Whois information for .+?:(.+?)/s) { \s*\s*(.*?)\s*\s*\s*(.*?)\s*\s*|$1 $2\n|isg; \s*\s*(.*?)\s*\s*|$1 $2\n|isg;
383 0         0 $resp = $1;
384 0         0 $resp =~ s|||isg;
385 0         0 $resp =~ s|||isg;
386              
387 0         0 $ishtml = 1;
388             }
389             else {
390 0         0 return 0;
391             }
392              
393             }
394             elsif ($tld eq 'kz') {
395              
396 0         0 $resp = decode_utf8( $resp );
397              
398 0 0 0     0 if ($resp =~ /Domain Name\.{10}/s && $resp =~ /
(.+?)<\/pre>/s) { 
399 0         0 $resp = $1;
400             }
401             else {
402 0         0 return 0;
403             }
404             }
405             elsif ($tld eq 'vn') {
406              
407 0         0 $resp = decode_utf8( $resp );
408              
409 0 0       0 if ($resp =~ /\(\s*?(Domain .+?:\s*registered)\s*?\)/i ) {
410 0         0 $resp = $1;
411             }
412             else {
413 0         0 return 0;
414             }
415              
416             #
417             # if ($resp =~/#ENGLISH.*?<\/tr>(.+?)<\/table>/si) {
418             # $resp = $1;
419             # $resp =~ s|||ig;
420             # $resp =~ s| ||ig;
421             # $resp =~ s|
|\n|ig;
422             # $resp =~ s|
423             # $resp =~ s|^\s*||mg;
424             #
425             }
426             elsif ($tld eq 'ac') {
427              
428 0         0 $resp = decode_utf8( $resp );
429              
430 0 0 0     0 if ($CHECK_EXCEED && $resp =~ /too many requests/is) {
    0          
431 0         0 die "Connection rate exceeded";
432             }
433             elsif ($resp =~ /(.+?)/is) {
434 0         0 $resp = $1;
435 0         0 $resp =~ s|||ig;
436 0         0 $resp =~ s|||ig;
437 0         0 $resp =~ s|||ig;
438 0         0 $resp =~ s|\s*\s*(.*?)\s*
439 0         0 $resp =~ s|||ig;
440 0         0 $resp =~ s|||ig;
441 0         0 $resp =~ s|^\s*||mg;
442             }
443             else {
444 0         0 return 0;
445             }
446              
447             }
448             elsif ($tld eq 'bz') {
449              
450 0         0 $resp = decode_utf8( $resp );
451              
452 0 0       0 if ( $resp =~ m{
453            
454             (.+)
455            
456             }xms )
457             {
458 0         0 $resp = $1;
459 0 0 0     0 if ( $resp =~ /NOT\s+FOUND/ || $resp =~ /No\s+Domain/ ) {
460             # Whois info not found
461 0         0 return 0;
462             }
463              
464 0         0 $resp =~ s|<[^<>]+>||ig;
465             }
466             else {
467 0         0 return 0;
468             }
469             }
470             elsif ( $tld eq 'tj' && $url =~ m|^http\://get\.tj| ) {
471 0         0 $resp = decode_utf8( $resp );
472              
473 0 0       0 if ($resp =~ m|\n(.+?)|s ) {
474 0         0 $resp = $1;
475 0         0 $resp =~ s|<[^<>]+>||ig;
476 0         0 $resp =~ s|Whois\n|\n|s;
477              
478 0 0       0 return 0 if $resp =~ m|Domain \S+ is free|s;
479              
480 0         0 $resp =~ s|Domain \S+ is already taken\.\n|\n|s;
481 0         0 $resp =~ s| | |ig;
482 0         0 $resp =~ s|«|"|ig;
483 0         0 $resp =~ s|»|"|ig;
484 0         0 $resp =~ s|\n\s+|\n|sg;
485 0         0 $resp =~ s|\s+\n|\n|sg;
486 0         0 $resp =~ s|\n\n|\n|sg;
487             }
488             else {
489 0         0 return 0;
490             }
491              
492             }
493             elsif ( $tld eq 'tj' && $url =~ m|\.nic\.tj/cgi/lookup| ) {
494              
495 0         0 $resp = decode_utf8( $resp );
496              
497 0 0       0 if ($resp =~ m|\n?(.+?)\n?|s) {
498 0         0 $resp = $1;
499              
500 0 0       0 return 0 if $resp =~ m|may be available|s;
501              
502 0         0 $resp =~ s|\n\s+|\n|sg;
503 0         0 $resp =~ s|\s+\n|\n|sg;
504 0         0 $resp =~ s|\n\n|\n|sg;
505 0         0 $resp =~ s|
506             }
507             else {
508 0         0 return 0;
509             }
510              
511             }
512             elsif ( $tld eq 'tj' && $url =~ m|\.nic\.tj/cgi/whois| || $url =~ m|62\.122\.137\.16| ) {
513 1         34 $resp = decode_utf8( $resp );
514              
515 1 50       83 if ( $resp =~ m{ ]*? > (.+) (:?
) }sxmi ) {
516 1         6 $resp = $1;
517 1         99 $resp =~ s|||ig;
518 1         151 $resp =~ s|| |ig;
519 1         102 $resp =~ s|||ig;
520 1         22 $resp =~ s|||ig;
521 1         73 $resp =~ s|«|"|ig;
522 1         72 $resp =~ s|»|"|ig;
523 1         75 $resp =~ s| | |ig;
524 1         34 $resp =~ s|\n\s+|\n|sg;
525 1         36 $resp =~ s|\s+\n|\n|sg;
526 1         10 $resp =~ s|\n\n|\n|sg;
527             }
528             else {
529 0         0 return 0;
530             }
531              
532             }
533             else {
534 0         0 return 0;
535             }
536              
537 1         4 return $resp;
538             }
539              
540             # check, if it's IP-address?
541             sub is_ipaddr {
542 18     18 0 329 $_[0] =~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/;
543             }
544              
545             # check, if it's IPv6-address?
546             sub is_ip6addr {
547 20     20 0 37 my ( $ip ) = @_;
548              
549 20 50       38 return 0 unless defined $ip;
550              
551 20         1132 return $ip =~ /^$IPv6_re$/;
552             }
553              
554             # get domain level
555             sub domain_level {
556 19     19 0 1074 my ($str) = @_;
557              
558 19         43 my $dotcount = $str =~ tr/././;
559              
560 19         103 return $dotcount + 1;
561             }
562              
563             # split domain on name and TLD
564             sub split_domain {
565 7     7 0 578 my ($dom) = @_;
566              
567 7         19 my $tld = get_dom_tld( $dom );
568              
569 7         34 my $name;
570 7 50 33     47 if (uc $tld eq 'IP' || $tld eq 'NOTLD') {
571 0         0 $name = $dom;
572             }
573             else {
574 7         22 $name = substr( $dom, 0, length($dom) - length($tld) - 1 );
575             }
576              
577 7         25 return ($name, $tld);
578             }
579              
580             #
581             sub dlen {
582 0     0 0 0 my ($str) = @_;
583              
584 0         0 return length($str) * domain_level($str);
585             }
586              
587             # clear the data's taintedness
588             sub untaint (\$) {
589 14     14 0 20 my ($str) = @_;
590              
591 14         48 $$str =~ m/^(.*)$/;
592 14         30 $$str = $1;
593             }
594              
595             1;
596              
597             __END__