install/5.005/Net-Whois-Raw/lib/Net/Whois/Raw.pm

   1 package Net::Whois::Raw;
   2
   3 require Net::Whois::Raw::Data;
   4
   5 use strict;
   6 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $OMIT_MSG $CHECK_FAIL
   7         %notfound %strip $CACHE_DIR $CACHE_TIME $USE_CNAMES
   8         $TIMEOUT);
   9 use IO::Socket;
  10
  11 require Exporter;
  12
  13 @ISA = qw(Exporter);
  14
  15 @EXPORT    = qw( whois whois_config ); ### It's bad manners to export lots.
  16 @EXPORT_OK = qw( $OMIT_MSG $CHECK_FAIL $CACHE_DIR $CACHE_TIME $USE_CNAMES $TIMEOUT);
  17
  18 $VERSION = '0.31';
  19
  20 ($OMIT_MSG, $CHECK_FAIL, $CACHE_DIR, $CACHE_TIME, $USE_CNAMES, $TIMEOUT) = (0) x 6;
  21
  22 sub whois {
  23     my ($dom, $srv) = @_;
  24     my $res;
  25     unless ($srv) {
  26         ($res, $srv) = query($dom);
  27     } else {
  28         $res = _whois($dom, uc($srv));
  29     }
  30     finish($res, $srv);
  31 }
  32
  33 sub whois_config {
  34     my ($par) = @_;
  35     my @parnames = qw(OMIT_MSG CHECK_FAIL CACHE_DIR CACHE_TIME USE_CNAMES TIMEOUT);
  36     foreach my $parname (@parnames) {
  37         if (exists($par->{$parname})) {
  38             eval('$'.$parname.'='.int($par->{$parname}));
  39         }
  40     }
  41 }
  42
  43 sub query {
  44     my $dom = shift;
  45     my $tld;
  46     if ($dom =~ /\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/) {
  47         $tld = "IP";
  48     } else {
  49         my @alltlds = keys %Net::Whois::Raw::Data::servers;
  50         @alltlds = sort { dlen($b) <=> dlen($a) } @alltlds;
  51         foreach my $awailtld (@alltlds) {
  52             $awailtld = lc $awailtld;
  53             if ($dom =~ /(.+?)\.($awailtld)$/) {
  54                 $tld = uc $2;
  55                 last;
  56             }
  57         }
  58         unless ($tld) {
  59             my @tokens = split(/\./, $dom);
  60             $tld = uc($tokens[-1]);
  61         }
  62     }
  63
  64
  65     $dom =~ s/.NS$//i;
  66     my $cname = "$tld.whois-servers.net";
  67     my $srv = $Net::Whois::Raw::Data::servers{$tld} || $cname;
  68     $srv = $cname if $USE_CNAMES && gethostbyname($cname);
  69     my $flag = (
  70         $srv eq 'whois.crsnic.net' ||
  71         $srv eq 'whois.publicinterestregistry.net' ||
  72         $srv eq 'whois.nic.cc' ||
  73         $tld eq 'ARPA'
  74     );
  75     my $res = do_whois($dom, uc($srv), $flag, [], $tld);
  76     wantarray ? ($res, $srv) : $res;
  77 }
  78
  79 sub do_whois {
  80     my ($dom) = @_; # receives 4 parameters, do NOT shift
  81     return _whois(@_) unless $CACHE_DIR;
  82     mkdir $CACHE_DIR, 0644;
  83     if (-f "$CACHE_DIR/$dom") {
  84         if (open(I, "$CACHE_DIR/$dom")) {
  85             my $res = join("", <I>);
  86             close(I);
  87             return $res;
  88         }
  89     }
  90     my $res = _whois(@_);
  91     return $res unless $res;
  92     return $res unless open(O, ">$CACHE_DIR/$dom");
  93     print O $res;
  94     close(O);
  95
  96
  97     return $res unless $CACHE_TIME;
  98
  99     my $now = time;
 100     foreach (glob("$CACHE_DIR/*.*")) {
 101         my $atime = (stat($_))[8];
 102         my $elapsed = $now - $atime;
 103         unlink $_ if ($elapsed / 3600 > $CACHE_TIME);
 104     }
 105     $res;
 106 }
 107
 108 sub finish {
 109     my ($text, $srv) = @_;
 110     return $text unless $CHECK_FAIL || $OMIT_MSG;
 111     *notfound = \%Net::Whois::Raw::Data::notfound;
 112     *strip = \%Net::Whois::Raw::Data::strip;
 113
 114     my $notfound = $notfound{lc($srv)};
 115     my @strip = $strip{lc($srv)} ? @{$strip{lc($srv)}} : ();
 116     my @lines;
 117     MAIN: foreach (split(/\n/, $text)) {
 118         return undef if $CHECK_FAIL && $notfound && /$notfound/;
 119         if ($OMIT_MSG) {
 120             foreach my $re (@strip) {
 121                 next MAIN if (/$re/);
 122             }
 123         }
 124         push(@lines, $_);
 125     }
 126     local ($_) = join("\n", @lines, "");
 127
 128     if ($CHECK_FAIL > 1) {
 129         return undef unless check_existance($_);
 130     }
 131
 132     if ($OMIT_MSG > 1) {
 133         s/The Data.+(policy|connection)\.\n//is;
 134         s/% NOTE:.+prohibited\.//is;
 135         s/Disclaimer:.+\*\*\*\n?//is;
 136         s/NeuLevel,.+A DOMAIN NAME\.//is;
 137         s/For information about.+page=spec//is;
 138         s/NOTICE: Access to.+this policy.//is;
 139         s/The previous information.+completeness\.//s;
 140         s/NOTICE AND TERMS OF USE:.*modify these terms at any time\.//s;
 141         s/TERMS OF USE:.*?modify these terms at any time\.//s;
 142         s/NOTICE:.*expiration for this registration\.//s;
 143
 144         s/By submitting a WHOIS query.+?DOMAIN AVAILABILITY.\n?//s;
 145         s/Registration and WHOIS.+?its accuracy.\n?//s;
 146         s/Disclaimer:.+?\*\*\*\n?//s;
 147         s/The .COOP Registration .+ Information\.//s;
 148         s/Whois Server Version \d+\.\d+.//is;
 149         s/NeuStar,.+www.whois.us\.//is;
 150         s/\n?Domain names in the \.com, .+ detailed information.\n?//s;
 151         s/\n?The Registry database .+?Registrars\.\n//s;
 152         s/\n?>>> Last update of .+? <<<\n?//;
 153         s/% .+?\n//gs;
 154     }
 155     $_;
 156 }
 157
 158 sub _whois {
 159     my ($dom, $srv, $flag, $ary, $tld) = @_;
 160     my $state;
 161
 162     my $sock;
 163     eval {
 164         local $SIG{'ALRM'} = sub { die "Connection timeout to $srv" };
 165         alarm $TIMEOUT if $TIMEOUT;
 166         $sock = new IO::Socket::INET("$srv:43") || die "$srv: $!";
 167     };
 168     alarm 0;
 169     die $@ if $@;
 170     my $israce = $dom =~ /ra--/ || $dom =~ /bq--/;
 171     my $whoisquery = $dom;
 172     if ($srv eq 'WHOIS.MELBOURNEIT.COM' && $israce) {
 173         $whoisquery .= ' race';
 174     }
 175     #warn "$srv: $whoisquery ($OMIT_MSG, $CHECK_FAIL, $CACHE_DIR, $CACHE_TIME, $USE_CNAMES, $TIMEOUT)\n";
 176     print $sock "$whoisquery\r\n";
 177     my @lines = <$sock>;
 178     close($sock);
 179     my $answer = join '', @lines;
 180     if ($flag) {
 181         foreach (@lines) {
 182             $state ||= (/Registrar:/);
 183             if ( $state && /Whois Server:\s*([A-Za-z0-9\-_\.]+)/ ) {
 184                 my $newsrv = uc("$1");
 185                 next if (($newsrv) eq uc($srv));
 186                 return undef if (grep {$_ eq $newsrv} @$ary);
 187                 my $whois = eval { _whois($dom, $newsrv, $flag, [@$ary, $srv]) };
 188                 if ($@ && !$whois || $whois && !check_existance($whois)) {
 189                     return $answer;
 190                 }
 191                 return $whois;
 192             }
 193             if (/^\s+Maintainer:\s+RIPE\b/ && $tld eq 'ARPA') {
 194                 my $newsrv = uc($Net::Whois::Raw::Data::servers{'RIPE'});
 195                 next if ($newsrv eq $srv);
 196                 return undef if (grep {$_ eq $newsrv} @$ary);
 197                 my $whois = eval { _whois($dom, $newsrv, $flag, [@$ary, $srv]) };
 198                 if ($@ && !$whois) {
 199                     return $answer;
 200                 }
 201                 return $whois;
 202             }
 203         }
 204     }
 205     my $whois = join("", @lines);
 206
 207     if ($whois =~ /To single out one record, look it up with \"xxx\",/s) {
 208         my $newsrv = uc('whois.networksolutions.com');
 209         return _whois($dom, $newsrv, $flag, [@{$ary||[]}, $srv]);
 210     }
 211
 212     return $whois;
 213 }
 214
 215 sub dlen {
 216     my ($str) = @_;
 217     my $dotcount = $str =~ tr/././;
 218     return length($str) * (1 + $dotcount);
 219 }
 220
 221
 222 sub check_existance {
 223     $_ = $_[0];
 224
 225     return undef if
 226         /is unavailable/is ||
 227         /No entries found for the selected source/is ||
 228         /Not found:/s ||
 229         /No match\./s ||
 230         /is available/is ||
 231         /Not found/is &&
 232             !/ your query returns "NOT FOUND"/ &&
 233             !/Domain not found locally/ ||
 234         /No match for/is ||
 235         /No Objects Found/s ||
 236         /No domain records were found/s ||
 237         /No such domain/s ||
 238         /No entries found in the /s ||
 239         /Unable to find any information for your query/s ||
 240         /is not registered and may be available for registration/s;
 241     return 1;
 242 }
 243
 244
 245 # Preloaded methods go here.
 246
 247 # Autoload methods go after =cut, and are processed by the autosplit program.
 248
 249 1;
 250 __END__
 251 # Below is the stub of documentation for your module. You better edit it!
 252
 253 =head1 NAME
 254
 255 Net::Whois::Raw - Perl extension for unparsed raw whois information
 256
 257 =head1 SYNOPSIS
 258
 259   use Net::Whois::Raw qw( whois );
 260
 261   $s = whois('perl.com');
 262   $s = whois('funet.fi');
 263   $s = whois('yahoo.co.uk');
 264
 265         ### if you do "use Net::Whois::Raw qw( whois $OMIT_MSG $CHECK_FAIL
 266         ###              $CACHE_DIR $CACHE_TIME $USE_CNAMES $TIMEOUT );
 267         ### you can use these:
 268
 269   $OMIT_MSG = 1; # This will attempt to strip several known copyright
 270                 messages and disclaimers sorted by servers.
 271                 Default is to give the whole response.
 272
 273   $OMIT_MSG = 2; # This will try some additional stripping rules
 274                 if none are known for the spcific server.
 275
 276   $CHECK_FAIL = 1; # This will return undef if the response matches
 277                 one of the known patterns for a failed search,
 278                 sorted by servers.
 279                 Default is to give the textual response.
 280
 281   $CHECK_FAIL = 2; # This will match against several more rules
 282                 if none are known for the specific server.
 283
 284   $CACHE_DIR = "/var/spool/pwhois/"; # Whois information will be
 285                 cached in this directory. Default is no cache.
 286
 287   $CACHE_TIME = 24; # Cache files will be cleared after not accessed
 288                 for a specific number of hours. Documents will not be
 289                 cleared if they keep get requested for, independent
 290                 of disk space. Default is not to clear the cache.
 291
 292   $USE_CNAMES = 1; # Use whois-servers.net to get the whois server
 293                 name when possible. Default is to use the
 294                 hardcoded defaults.
 295
 296
 297   $TIMEOUT = 10; # Cancel the request if connection is not made within
 298                 a specific number of seconds.
 299
 300   Note: as of version 0.21, extra data will be loaded only if the
 301   OMIT_MSG or CHECK_FAIL flags were used, in order to reduce memory usage.
 302
 303 =head1 DESCRIPTION
 304
 305 Net::Whois::Raw queries NetworkSolutions and follows the Registrar: answer
 306 for ORG, EDU, COM and NET domains.
 307 For other TLDs it uses the whois-servers.net namespace.
 308 (B<$TLD>.whois-servers.net).
 309
 310 Setting the variables $OMIT_MSG and $CHECK_FAIL will match the results
 311 against a set of known patterns. The first flag will try to omit the
 312 copyright message/disclaimer, the second will attempt to determine if
 313 the search failed and return undef in such a case.
 314
 315 B<IMPORTANT>: these checks merely use pattern matching; they will work
 316 on several servers but certainly not on all of them.
 317
 318 (This features were contributed by Walery Studennikov B<despair@sama.ru>)
 319
 320 =head1 AUTHOR
 321
 322 Original author Ariel Brosh, B<schop@cpan.org>,
 323 Inspired by jwhois.pl available on the net.
 324
 325 Since Ariel has passed away in September 2002:
 326
 327 Past maintainers Gabor Szabo, B<gabor@perl.org.il>,
 328 Corris Randall B<corris@cpan.org>
 329
 330 Current Maintainer: Walery Studennikov B<despair@cpan.org>
 331
 332 =head1 CREDITS
 333
 334 Fixed regular expression to match hyphens. (Peter Chow,
 335 B<peter@interq.or.jp>)
 336
 337 Added support for Tonga TLD. (.to) (Peter Chow, B<peter@interq.or.jp>)
 338
 339 Added support for reverse lookup of IP addresses via the ARIN registry. (Alex Withers B<awithers@gonzaga.edu>)
 340
 341 This will work now for RIPE addresses as well, according to a redirection from ARIN. (Philip Hands B<phil@uk.alcove.com>, Trevor Peirce B<trev@digitalcon.ca>)
 342
 343 Added the pattern matching switches, (Walery Studennikov B<despair@sama.ru>)
 344
 345 Modified pattern matching, added cache. (Tony L. Svanstrom B<tony@svanstrom.org>)
 346
 347 =head1 CHANGES
 348
 349 See file "Changes" in the distribution
 350
 351
 352 =head1 CLARIFICATION
 353
 354 As NetworkSolutions got most of the domains of InterNic as legacy, we
 355 start by querying their server, as this way one whois query would be
 356 sufficient for many domains. Starting at whois.internic.net or
 357 whois.crsnic.net will result in always two requests in any case.
 358
 359 =head1 NOTE
 360
 361 Some users complained that the B<die> statements in the module make their
 362 CGI scripts crash. Please consult the entries on B<eval> and
 363 B<die> on L<perlfunc> about exception handling in Perl.
 364
 365 =head1 COPYRIGHT
 366
 367 Copyright 2000-2002 Ariel Brosh.
 368 Copyright 2003-2003 Gabor Szabo.
 369 Copyright 2003-2003 Corris Randall.
 370 Copyright 2003-2003 Walery Studennikov.
 371
 372 This package is free software. You may redistribute it or modify it under
 373 the same terms as Perl itself.
 374
 375 I apologize for any misunderstandings caused by the lack of a clear
 376 licence in previous versions.
 377
 378 =head1 COMMERCIAL SUPPORT
 379
 380 Not available anymore.
 381
 382 =head1 LEGAL
 383
 384 Notice that registrars forbid querying their whois servers as a part of
 385 a search engine, or querying for a lot of domains by script.
 386 Also, omitting the copyright information (that was requested by users of this
 387 module) is forbidden by the registrars.
 388
 389 =head1 SEE ALSO
 390
 391 L<perl(1)>, L<Net::Whois>, L<whois>.
 392
 393 =cut