path: root/install/5.005/Net-Whois-Raw/lib/Net/Whois/Raw.pm

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