File Coverage

blib/lib/Net/Whois/Raw.pm

Criterion	Covered	Total	%
statement	139	253	54.9
branch	47	136	34.5
condition	31	92	33.7
subroutine	20	26	76.9
pod	3	11	27.2
total	240	518	46.3

package Net::Whois::Raw;
$Net::Whois::Raw::VERSION = '2.99043';
# ABSTRACT: Get Whois information of domains and IP addresses.

require 5.008_001;
use Net::Whois::Raw::Common ();
use Net::Whois::Raw::Data ();

use warnings;
use strict;

use Carp;
use IO::Socket::IP;
use Encode;
use utf8;

our @EXPORT = qw( whois get_whois );

our ($OMIT_MSG, $CHECK_FAIL, $CHECK_EXCEED, $CACHE_DIR, $TIMEOUT, $DEBUG) = (0) x 7;

our $CACHE_TIME = 60;
our $SET_CODEPAGE = '';
our $SILENT_MODE = 0;
our $QUERY_SUFFIX = '';

our (%notfound, %strip, @SRC_IPS, %POSTPROCESS);

# internal variable, used for save whois_server->ip relations
my $_IPS = {};

our $class = __PACKAGE__;

my $last_cache_clear_time;

sub whois_config {
    my ($par) = @_;
    my @parnames = qw(OMIT_MSG CHECK_FAIL CHECK_EXCEED CACHE_DIR CACHE_TIME TIMEOUT @SRC_IPS);
    foreach my $parname (@parnames) {
        if (exists($par->{$parname})) {
            no strict 'refs';
            ${$parname} = $par->{$parname};
        }
    }
}

sub whois_config_data {
    my $net_whois_raw_data = shift;

    no strict 'refs';

    foreach my $k (keys %$net_whois_raw_data) {
        %{'Net::Whois::Raw::Data::'.$k} = (
            %{'Net::Whois::Raw::Data::'.$k},
            %{ $net_whois_raw_data->{ $k } || {} },
        );
    }
}

# get cached whois
sub whois {
    my ($dom, $server, $which_whois) = @_;

    $which_whois ||= 'QRY_LAST';

    my $res = Net::Whois::Raw::Common::get_from_cache( "$dom-$which_whois", $CACHE_DIR, $CACHE_TIME );

    my ($res_text, $res_srv, $res_text2);

    if ($res) {
        if ($which_whois eq 'QRY_FIRST') {
            $res_text = $res->[0]->{text};
            $res_srv  = $res->[0]->{srv};
        } elsif ($which_whois eq 'QRY_LAST' || !defined($which_whois)) {
            $res_text = $res->[-1]->{text};
            $res_srv  = $res->[-1]->{srv};
        } elsif ($which_whois eq 'QRY_ALL') {
            return $res;
        }
    }
    else {
        ($res_text, $res_srv) = get_whois($dom, $server, $which_whois);
    }

    $res_srv = '' if $res_srv && $res_srv eq 'www_whois';

    if ( defined $res_text && $which_whois ne 'QRY_ALL' ) {
        utf8::decode( $res_text ); # Perl whyly loss utf8 flag

        $res_text = encode( $SET_CODEPAGE, $res_text ) if $SET_CODEPAGE;
    }

    return wantarray ? ($res_text, $res_srv) : $res_text;
}

# obtain whois
sub get_whois {
    my ($dom, $srv, $which_whois) = @_;
    $which_whois ||= 'QRY_LAST';

    my $whois = get_all_whois( $dom, $srv, $which_whois eq 'QRY_FIRST' )
        or return undef;

    Net::Whois::Raw::Common::write_to_cache( "$dom-$which_whois", $whois, $CACHE_DIR );

    if ($which_whois eq 'QRY_LAST') {
        my $thewhois = $whois->[-1];
        return wantarray ? ($thewhois->{text}, $thewhois->{srv}) : $thewhois->{text};
    }
    elsif ($which_whois eq 'QRY_FIRST') {
        my $thewhois = $whois->[0];
        return wantarray ? ($thewhois->{text}, $thewhois->{srv}) : $thewhois->{text};
    }
    else {
        return $whois;
    }
}

sub get_all_whois {
    my ($dom, $srv, $norecurse) = @_;

    my $is_ns = 0;
    $is_ns = 1  if $dom =~ s/[.]NS$//i;

    $srv ||= Net::Whois::Raw::Common::get_server( $dom, $is_ns );

    if ($srv eq 'www_whois') {
        my ($responce, $ishtml) = www_whois_query( $dom );
        return $responce ? [ { text => $responce, srv => $srv } ] : $responce;
    }

    my @whois = recursive_whois( $dom, $srv, [], $norecurse, $is_ns );

    my $whois_answers = process_whois_answers( \@whois, $dom );

    return $whois_answers;
}

sub process_whois_answers {
    my ( $raw_whois, $dom ) = @_;

    my @processed_whois;

    my $level = 0;
    for my $whois_rec ( @$raw_whois ) {
        $whois_rec->{level} = $level;
        my ( $text, $error ) = Net::Whois::Raw::Common::process_whois(
            $dom,
            $whois_rec->{srv},
            $whois_rec->{text},
            $CHECK_FAIL, $OMIT_MSG, $CHECK_EXCEED,
        );

        die $error  if $error && $error eq 'Connection rate exceeded'
            && ( $level == 0 || $CHECK_EXCEED == 2 );

        if ( $text || $level == 0 ) {
            $whois_rec->{text} = $text;
            push @processed_whois, $whois_rec;
        }
        $level++;
    }

    return \@processed_whois;
}

sub _referral_server {
    /ReferralServer:\s*r?whois:\/\/([-.\w]+(?:\:\d+)?)/
}

sub recursive_whois {
    my ( $dom, $srv, $was_srv, $norecurse, $is_ns ) = @_;

    my $lines = whois_query( $dom, $srv, $is_ns );
    my $whois = join '', @$lines;

    my ( $newsrv, $registrar );
    for ( @$lines ) {
        $registrar ||= /Registrar/ || /Registered through/;

        # Skip urls as recursive whois servers
        if ( $registrar && !$norecurse && /whois server:\s*(?:https?:\/\/)?([a-z0-9\-_\.]+)\b/i ) {
            $newsrv = lc $1;
        }
        elsif ( $whois =~ /To single out one record, look it up with \"xxx\",/s ) {
            return recursive_whois( "=$dom", $srv, $was_srv );
        }
        elsif ( !$norecurse && ( my ( $rs ) = _referral_server() ) ) {
            $newsrv = $rs;
            last;
        }
        elsif ( /Contact information can be found in the (\S+)\s+database/ ) {
            $newsrv = $Net::Whois::Raw::Data::ip_whois_servers{ $1 };
        }
        elsif ( ( /OrgID:\s+(\w+)/i || /descr:\s+(\w+)/ ) && Net::Whois::Raw::Common::is_ipaddr( $dom ) ) {
            my $val = $1;
            if ( $val =~ /^(?:RIPE|APNIC|KRNIC|LACNIC)$/ ) {
                $newsrv = $Net::Whois::Raw::Data::ip_whois_servers{ $val };
                last;
            }
        }
        elsif ( /^\s+Maintainer:\s+RIPE\b/ && Net::Whois::Raw::Common::is_ipaddr( $dom ) ) {
            $newsrv = $Net::Whois::Raw::Data::servers{RIPE};
        }
        elsif ( $is_ns && $srv ne $Net::Whois::Raw::Data::servers{NS} ) {
            $newsrv = $Net::Whois::Raw::Data::servers{NS};
        }
    }

    if (
        defined $newsrv && (
            # Bypass recursing to custom servers
            $Net::Whois::Raw::Data::whois_servers_no_recurse{ $newsrv }
            # Bypass recursing to WHOIS servers with no IDN support
            || $dom =~ /^xn--/i && $newsrv && $Net::Whois::Raw::Data::whois_servers_with_no_idn_support{ $newsrv }
        )
    ) {
        $newsrv = undef;
    }

    my @whois_recs = ( { text => $whois, srv => $srv } );
    if ( $newsrv && $newsrv ne $srv ) {
        warn "recurse to $newsrv\n" if $DEBUG;

        return () if grep { $_ eq $newsrv } @$was_srv;

        my @new_whois_recs = eval { recursive_whois( $dom, $newsrv, [ @$was_srv, $srv ], 0, $is_ns ) };
        my $new_whois = scalar @new_whois_recs ? $new_whois_recs[0]->{text} : '';
        my $notfound = $Net::Whois::Raw::Data::notfound{ $newsrv };

        if ( $new_whois && !$@ && not ( $notfound && $new_whois =~ /$notfound/im ) ) {
            if ( $is_ns ) {
                unshift @whois_recs, @new_whois_recs;
            }
            else {
                push @whois_recs, @new_whois_recs;
            }
        }
        else {
            warn "recursive query failed\n" if $DEBUG;
        }
    }

    return @whois_recs;
}

sub whois_query {
    my ($dom, $srv, $is_ns) = @_;

    # Prepare query
    my $whoisquery = Net::Whois::Raw::Common::get_real_whois_query($dom, $srv, $is_ns);

    # Prepare for query

    my (@sockparams, $sock);
    my (undef, $tld) = Net::Whois::Raw::Common::split_domain($dom);

    $tld = uc $tld;
    my $rotate_reference = undef;

    ### get server for query
    my $server4query = Net::Whois::Raw::Common::get_server($dom);

    if ( Net::Whois::Raw::Common::is_ip6addr( $srv ) ) {
        $srv = "[$srv]";
    }

    my $srv_and_port = $srv =~ /\:\d+$/ ? $srv : "$srv:43";
    if ($class->can('whois_query_sockparams')) {
        @sockparams = $class->whois_query_sockparams ($dom, $srv);
    }
    # hook for outside defined socket
    elsif ($class->can('whois_query_socket')) {
        $sock = $class->whois_query_socket ($dom, $srv);
    }
    elsif (my $ips_arrayref = get_ips_for_query($server4query)) {
        $rotate_reference = $ips_arrayref;
    }
    elsif (scalar(@SRC_IPS)) {
        $rotate_reference = \@SRC_IPS;
    }
    else {
        @sockparams = $srv_and_port;
    }


    if ($rotate_reference) {
        my $src_ip = $rotate_reference->[0];
        push @$rotate_reference, shift @$rotate_reference; # rotate ips
        @sockparams = (PeerAddr => $srv_and_port, LocalAddr => $src_ip);
    }

    print "QUERY: $whoisquery; SRV: $srv, ".
            "OMIT_MSG: $OMIT_MSG, CHECK_FAIL: $CHECK_FAIL, CACHE_DIR: $CACHE_DIR, ".
            "CACHE_TIME: $CACHE_TIME, TIMEOUT: $TIMEOUT\n" if $DEBUG >= 2;

    my $prev_alarm = undef;
    my $t0 = time();

    my @lines;

    # Make query

    {
        local $SIG{'ALRM'} = sub { die "Connection timeout to $srv" };
        eval {

            $prev_alarm = alarm $TIMEOUT if $TIMEOUT;

            unless ( $sock ) {
                $sock = eval {
                    IO::Socket::IP->new( @sockparams )
                }
                or do {
                    my $errstr = $IO::Socket::errstr || '';
                    die "$srv: $errstr: " . join( ', ', @sockparams );
                };
            }

            if ($class->can ('whois_socket_fixup')) {
                my $new_sock = $class->whois_socket_fixup ($sock);
                $sock = $new_sock if $new_sock;
            }

            if ($DEBUG > 2) {
                require Data::Dumper;
                print "Socket: ". Data::Dumper::Dumper($sock);
            }

            if ($QUERY_SUFFIX) {
                $whoisquery .= $QUERY_SUFFIX;
            }

            $sock->print( $whoisquery, "\r\n" );
            # TODO: $soc->read, parameters for read chunk size, max content length
            # Now you can redefine SOCK_CLASS::getline method as you want
            while (my $str = $sock->getline) {
                push @lines, $str;
            }
            $sock->close;
        };
        {
            local $@; # large code block below, so preserve previous exception.
            if (defined $prev_alarm) { # if we ever set new alarm
                if ($prev_alarm == 0) { # there was no alarm previously
                    alarm 0; # clear it
                } else { # there was an alarm previously
                    $prev_alarm -= (time()- $t0); # try best to substract time elapsed
                    $prev_alarm = 1 if $prev_alarm < 1; # we still need set it to something non-zero
                    alarm $prev_alarm; # set it
                }
            }
        }
        Carp::confess $@ if $@;
    }

    foreach (@lines) { s/\r//g; }

    print "Received ".scalar(@lines)." lines\n" if $DEBUG >= 2;

    return \@lines;
}

sub www_whois_query {
    my ($dom) = (lc shift);

    my ($resp, $url);
    my ($name, $tld) = Net::Whois::Raw::Common::split_domain( $dom );

    my $http_query_urls = Net::Whois::Raw::Common::get_http_query_url($dom);

    foreach my $qurl ( @{$http_query_urls} ) {

        # load-on-demand
        unless ($INC{'LWP/UserAgent.pm'}) {
            require LWP::UserAgent;
            require HTTP::Request;
            require HTTP::Headers;
            require URI::URL;
            import LWP::UserAgent;
            import HTTP::Request;
            import HTTP::Headers;
            import URI::URL;
        }

        my $referer = delete $qurl->{form}{referer} if $qurl->{form} && defined $qurl->{form}{referer};
        my $method = ( $qurl->{form} && scalar(keys %{$qurl->{form}}) ) ? 'POST' : 'GET';

    my $ua;

    # hook for outside defined lwp
    if ($class->can ('whois_query_ua')) {
        $ua = $class->whois_query_ua ($dom);
    }

    unless($ua){
        $ua = new LWP::UserAgent( parse_head => 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');
    }
        my $header = HTTP::Headers->new;
        $header->header('Referer' => $referer) if $referer;
        my $req = new HTTP::Request $method, $qurl->{url}, $header;

        if ($method eq 'POST') {
            require URI::URL;
            import URI::URL;

            my $curl = url("http:");
            $req->content_type('application/x-www-form-urlencoded');
            $curl->query_form( %{$qurl->{form}} );
            $req->content( $curl->equery );
        }

        $resp = eval {
            local $SIG{ALRM} = sub { die "www_whois connection timeout" };
            alarm 10;
            $ua->request($req)->content;
        };
        alarm 0;

        if ( !$resp || $@ || $resp =~ /www_whois connection timeout/ || $resp =~ /^500 Can\'t connect/ ) {
            undef $resp;
        }
        else {
            $url = $qurl->{url};
            last;
        }
    }

    return undef unless $resp;

    chomp $resp;
    $resp =~ s/\r//g;

    my $ishtml;

    $resp = Net::Whois::Raw::Common::parse_www_content($resp, $tld, $url, $CHECK_EXCEED);

    return wantarray ? ($resp, $ishtml) : $resp;
}


sub import {
    my $mypkg = shift;
    my $callpkg = caller;

    no strict 'refs';

    # export subs
    *{"$callpkg\::$_"} = \&{"$mypkg\::$_"} foreach ((@EXPORT, @_));
}


sub set_ips_for_server {
    my ($server, $ips) = @_;

    croak "Missing params" if (!$ips || !$server);

    $server = lc $server;
    $_IPS->{$server} = $ips;
}


sub get_ips_for_query {
    my ($server) = @_;

    $server = lc $server;
    if ($_IPS->{$server}) {
        return $_IPS->{$server};
    }
    return undef;
}


1;

__END__