--- /dev/null
+package Net::Whois::Raw;
+
+require Net::Whois::Raw::Data;
+
+use strict;
+use vars qw($VERSION @ISA @EXPORT @EXPORT_OK $OMIT_MSG $CHECK_FAIL
+ %notfound %strip $CACHE_DIR $CACHE_TIME $USE_CNAMES
+ $TIMEOUT);
+use IO::Socket;
+
+require Exporter;
+
+@ISA = qw(Exporter);
+
+@EXPORT = qw( whois whois_config ); ### It's bad manners to export lots.
+@EXPORT_OK = qw( $OMIT_MSG $CHECK_FAIL $CACHE_DIR $CACHE_TIME $USE_CNAMES $TIMEOUT);
+
+$VERSION = '0.31';
+
+($OMIT_MSG, $CHECK_FAIL, $CACHE_DIR, $CACHE_TIME, $USE_CNAMES, $TIMEOUT) = (0) x 6;
+
+sub whois {
+ my ($dom, $srv) = @_;
+ my $res;
+ unless ($srv) {
+ ($res, $srv) = query($dom);
+ } else {
+ $res = _whois($dom, uc($srv));
+ }
+ finish($res, $srv);
+}
+
+sub whois_config {
+ my ($par) = @_;
+ my @parnames = qw(OMIT_MSG CHECK_FAIL CACHE_DIR CACHE_TIME USE_CNAMES TIMEOUT);
+ foreach my $parname (@parnames) {
+ if (exists($par->{$parname})) {
+ eval('$'.$parname.'='.int($par->{$parname}));
+ }
+ }
+}
+
+sub query {
+ my $dom = shift;
+ my $tld;
+ if ($dom =~ /\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}/) {
+ $tld = "IP";
+ } else {
+ my @alltlds = keys %Net::Whois::Raw::Data::servers;
+ @alltlds = sort { dlen($b) <=> dlen($a) } @alltlds;
+ foreach my $awailtld (@alltlds) {
+ $awailtld = lc $awailtld;
+ if ($dom =~ /(.+?)\.($awailtld)$/) {
+ $tld = uc $2;
+ last;
+ }
+ }
+ unless ($tld) {
+ my @tokens = split(/\./, $dom);
+ $tld = uc($tokens[-1]);
+ }
+ }
+
+
+ $dom =~ s/.NS$//i;
+ my $cname = "$tld.whois-servers.net";
+ my $srv = $Net::Whois::Raw::Data::servers{$tld} || $cname;
+ $srv = $cname if $USE_CNAMES && gethostbyname($cname);
+ my $flag = (
+ $srv eq 'whois.crsnic.net' ||
+ $srv eq 'whois.publicinterestregistry.net' ||
+ $srv eq 'whois.nic.cc' ||
+ $tld eq 'ARPA'
+ );
+ my $res = do_whois($dom, uc($srv), $flag, [], $tld);
+ wantarray ? ($res, $srv) : $res;
+}
+
+sub do_whois {
+ my ($dom) = @_; # receives 4 parameters, do NOT shift
+ return _whois(@_) unless $CACHE_DIR;
+ mkdir $CACHE_DIR, 0644;
+ if (-f "$CACHE_DIR/$dom") {
+ if (open(I, "$CACHE_DIR/$dom")) {
+ my $res = join("", <I>);
+ close(I);
+ return $res;
+ }
+ }
+ my $res = _whois(@_);
+ return $res unless $res;
+ return $res unless open(O, ">$CACHE_DIR/$dom");
+ print O $res;
+ close(O);
+
+
+ return $res unless $CACHE_TIME;
+
+ my $now = time;
+ foreach (glob("$CACHE_DIR/*.*")) {
+ my $atime = (stat($_))[8];
+ my $elapsed = $now - $atime;
+ unlink $_ if ($elapsed / 3600 > $CACHE_TIME);
+ }
+ $res;
+}
+
+sub finish {
+ my ($text, $srv) = @_;
+ return $text unless $CHECK_FAIL || $OMIT_MSG;
+ *notfound = \%Net::Whois::Raw::Data::notfound;
+ *strip = \%Net::Whois::Raw::Data::strip;
+
+ my $notfound = $notfound{lc($srv)};
+ my @strip = $strip{lc($srv)} ? @{$strip{lc($srv)}} : ();
+ my @lines;
+ MAIN: foreach (split(/\n/, $text)) {
+ return undef if $CHECK_FAIL && $notfound && /$notfound/;
+ if ($OMIT_MSG) {
+ foreach my $re (@strip) {
+ next MAIN if (/$re/);
+ }
+ }
+ push(@lines, $_);
+ }
+ local ($_) = join("\n", @lines, "");
+
+ if ($CHECK_FAIL > 1) {
+ return undef unless check_existance($_);
+ }
+
+ if ($OMIT_MSG > 1) {
+ s/The Data.+(policy|connection)\.\n//is;
+ s/% NOTE:.+prohibited\.//is;
+ s/Disclaimer:.+\*\*\*\n?//is;
+ s/NeuLevel,.+A DOMAIN NAME\.//is;
+ s/For information about.+page=spec//is;
+ s/NOTICE: Access to.+this policy.//is;
+ s/The previous information.+completeness\.//s;
+ s/NOTICE AND TERMS OF USE:.*modify these terms at any time\.//s;
+ s/TERMS OF USE:.*?modify these terms at any time\.//s;
+ s/NOTICE:.*expiration for this registration\.//s;
+
+ s/By submitting a WHOIS query.+?DOMAIN AVAILABILITY.\n?//s;
+ s/Registration and WHOIS.+?its accuracy.\n?//s;
+ s/Disclaimer:.+?\*\*\*\n?//s;
+ s/The .COOP Registration .+ Information\.//s;
+ s/Whois Server Version \d+\.\d+.//is;
+ s/NeuStar,.+www.whois.us\.//is;
+ s/\n?Domain names in the \.com, .+ detailed information.\n?//s;
+ s/\n?The Registry database .+?Registrars\.\n//s;
+ s/\n?>>> Last update of .+? <<<\n?//;
+ s/% .+?\n//gs;
+ }
+ $_;
+}
+
+sub _whois {
+ my ($dom, $srv, $flag, $ary, $tld) = @_;
+ my $state;
+
+ my $sock;
+ eval {
+ local $SIG{'ALRM'} = sub { die "Connection timeout to $srv" };
+ alarm $TIMEOUT if $TIMEOUT;
+ $sock = new IO::Socket::INET("$srv:43") || die "$srv: $!";
+ };
+ alarm 0;
+ die $@ if $@;
+ my $israce = $dom =~ /ra--/ || $dom =~ /bq--/;
+ my $whoisquery = $dom;
+ if ($srv eq 'WHOIS.MELBOURNEIT.COM' && $israce) {
+ $whoisquery .= ' race';
+ }
+ #warn "$srv: $whoisquery ($OMIT_MSG, $CHECK_FAIL, $CACHE_DIR, $CACHE_TIME, $USE_CNAMES, $TIMEOUT)\n";
+ print $sock "$whoisquery\r\n";
+ my @lines = <$sock>;
+ close($sock);
+ my $answer = join '', @lines;
+ if ($flag) {
+ foreach (@lines) {
+ $state ||= (/Registrar:/);
+ if ( $state && /Whois Server:\s*([A-Za-z0-9\-_\.]+)/ ) {
+ my $newsrv = uc("$1");
+ next if (($newsrv) eq uc($srv));
+ return undef if (grep {$_ eq $newsrv} @$ary);
+ my $whois = eval { _whois($dom, $newsrv, $flag, [@$ary, $srv]) };
+ if ($@ && !$whois || $whois && !check_existance($whois)) {
+ return $answer;
+ }
+ return $whois;
+ }
+ if (/^\s+Maintainer:\s+RIPE\b/ && $tld eq 'ARPA') {
+ my $newsrv = uc($Net::Whois::Raw::Data::servers{'RIPE'});
+ next if ($newsrv eq $srv);
+ return undef if (grep {$_ eq $newsrv} @$ary);
+ my $whois = eval { _whois($dom, $newsrv, $flag, [@$ary, $srv]) };
+ if ($@ && !$whois) {
+ return $answer;
+ }
+ return $whois;
+ }
+ }
+ }
+ my $whois = join("", @lines);
+
+ if ($whois =~ /To single out one record, look it up with \"xxx\",/s) {
+ my $newsrv = uc('whois.networksolutions.com');
+ return _whois($dom, $newsrv, $flag, [@{$ary||[]}, $srv]);
+ }
+
+ return $whois;
+}
+
+sub dlen {
+ my ($str) = @_;
+ my $dotcount = $str =~ tr/././;
+ return length($str) * (1 + $dotcount);
+}
+
+
+sub check_existance {
+ $_ = $_[0];
+
+ return undef if
+ /is unavailable/is ||
+ /No entries found for the selected source/is ||
+ /Not found:/s ||
+ /No match\./s ||
+ /is available/is ||
+ /Not found/is &&
+ !/ your query returns "NOT FOUND"/ &&
+ !/Domain not found locally/ ||
+ /No match for/is ||
+ /No Objects Found/s ||
+ /No domain records were found/s ||
+ /No such domain/s ||
+ /No entries found in the /s ||
+ /Unable to find any information for your query/s ||
+ /is not registered and may be available for registration/s;
+ return 1;
+}
+
+
+# Preloaded methods go here.
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+# Below is the stub of documentation for your module. You better edit it!
+
+=head1 NAME
+
+Net::Whois::Raw - Perl extension for unparsed raw whois information
+
+=head1 SYNOPSIS
+
+ use Net::Whois::Raw qw( whois );
+
+ $s = whois('perl.com');
+ $s = whois('funet.fi');
+ $s = whois('yahoo.co.uk');
+
+ ### if you do "use Net::Whois::Raw qw( whois $OMIT_MSG $CHECK_FAIL
+ ### $CACHE_DIR $CACHE_TIME $USE_CNAMES $TIMEOUT );
+ ### you can use these:
+
+ $OMIT_MSG = 1; # This will attempt to strip several known copyright
+ messages and disclaimers sorted by servers.
+ Default is to give the whole response.
+
+ $OMIT_MSG = 2; # This will try some additional stripping rules
+ if none are known for the spcific server.
+
+ $CHECK_FAIL = 1; # This will return undef if the response matches
+ one of the known patterns for a failed search,
+ sorted by servers.
+ Default is to give the textual response.
+
+ $CHECK_FAIL = 2; # This will match against several more rules
+ if none are known for the specific server.
+
+ $CACHE_DIR = "/var/spool/pwhois/"; # Whois information will be
+ cached in this directory. Default is no cache.
+
+ $CACHE_TIME = 24; # Cache files will be cleared after not accessed
+ for a specific number of hours. Documents will not be
+ cleared if they keep get requested for, independent
+ of disk space. Default is not to clear the cache.
+
+ $USE_CNAMES = 1; # Use whois-servers.net to get the whois server
+ name when possible. Default is to use the
+ hardcoded defaults.
+
+
+ $TIMEOUT = 10; # Cancel the request if connection is not made within
+ a specific number of seconds.
+
+ Note: as of version 0.21, extra data will be loaded only if the
+ OMIT_MSG or CHECK_FAIL flags were used, in order to reduce memory usage.
+
+=head1 DESCRIPTION
+
+Net::Whois::Raw queries NetworkSolutions and follows the Registrar: answer
+for ORG, EDU, COM and NET domains.
+For other TLDs it uses the whois-servers.net namespace.
+(B<$TLD>.whois-servers.net).
+
+Setting the variables $OMIT_MSG and $CHECK_FAIL will match the results
+against a set of known patterns. The first flag will try to omit the
+copyright message/disclaimer, the second will attempt to determine if
+the search failed and return undef in such a case.
+
+B<IMPORTANT>: these checks merely use pattern matching; they will work
+on several servers but certainly not on all of them.
+
+(This features were contributed by Walery Studennikov B<despair@sama.ru>)
+
+=head1 AUTHOR
+
+Original author Ariel Brosh, B<schop@cpan.org>,
+Inspired by jwhois.pl available on the net.
+
+Since Ariel has passed away in September 2002:
+
+Past maintainers Gabor Szabo, B<gabor@perl.org.il>,
+Corris Randall B<corris@cpan.org>
+
+Current Maintainer: Walery Studennikov B<despair@cpan.org>
+
+=head1 CREDITS
+
+Fixed regular expression to match hyphens. (Peter Chow,
+B<peter@interq.or.jp>)
+
+Added support for Tonga TLD. (.to) (Peter Chow, B<peter@interq.or.jp>)
+
+Added support for reverse lookup of IP addresses via the ARIN registry. (Alex Withers B<awithers@gonzaga.edu>)
+
+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>)
+
+Added the pattern matching switches, (Walery Studennikov B<despair@sama.ru>)
+
+Modified pattern matching, added cache. (Tony L. Svanstrom B<tony@svanstrom.org>)
+
+=head1 CHANGES
+
+See file "Changes" in the distribution
+
+
+=head1 CLARIFICATION
+
+As NetworkSolutions got most of the domains of InterNic as legacy, we
+start by querying their server, as this way one whois query would be
+sufficient for many domains. Starting at whois.internic.net or
+whois.crsnic.net will result in always two requests in any case.
+
+=head1 NOTE
+
+Some users complained that the B<die> statements in the module make their
+CGI scripts crash. Please consult the entries on B<eval> and
+B<die> on L<perlfunc> about exception handling in Perl.
+
+=head1 COPYRIGHT
+
+Copyright 2000-2002 Ariel Brosh.
+Copyright 2003-2003 Gabor Szabo.
+Copyright 2003-2003 Corris Randall.
+Copyright 2003-2003 Walery Studennikov.
+
+This package is free software. You may redistribute it or modify it under
+the same terms as Perl itself.
+
+I apologize for any misunderstandings caused by the lack of a clear
+licence in previous versions.
+
+=head1 COMMERCIAL SUPPORT
+
+Not available anymore.
+
+=head1 LEGAL
+
+Notice that registrars forbid querying their whois servers as a part of
+a search engine, or querying for a lot of domains by script.
+Also, omitting the copyright information (that was requested by users of this
+module) is forbidden by the registrars.
+
+=head1 SEE ALSO
+
+L<perl(1)>, L<Net::Whois>, L<whois>.
+
+=cut
projects / freeside.git / blobdiff