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

package Net::Whois::Raw::Common;
$Net::Whois::Raw::Common::VERSION = '2.99034';
# ABSTRACT: Helper for Net::Whois::Raw.

use Encode;
use warnings;
use strict;
use Regexp::IPv6 qw($IPv6_re);
use Net::Whois::Raw::Data ();
use Net::Whois::Raw ();

use utf8;

# func prototype
sub untaint(\$);

# get whois from cache
sub get_from_cache {
    my ($query, $cache_dir, $cache_time) = @_;

    return undef unless $cache_dir;
    mkdir $cache_dir unless -d $cache_dir;

    my $now = time;
    # clear the cache
    foreach my $fn ( glob("$cache_dir/*") ) {
        my $mtime = ( stat($fn) )[9] or next;
        my $elapsed = $now - $mtime;
        untaint $fn; untaint $elapsed;
        unlink $fn if ( $elapsed / 60 >= $cache_time );
    }

    my $result;
    if ( -e "$cache_dir/$query.00" ) {
        my $level = 0;
        while ( open( my $cache_fh, '<', "$cache_dir/$query.".sprintf( "%02d", $level ) ) ) {
            $result->[$level]->{srv} = <$cache_fh>;
            chomp $result->[$level]->{srv};
            $result->[$level]->{text} = join "", <$cache_fh>;
            if ( !$result->[$level]->{text} and $Net::Whois::Raw::CHECK_FAIL ) {
                $result->[$level]->{text} = undef ;
            }
            else {
                $result->[$level]->{text} = decode_utf8( $result->[$level]->{text} );
            }
            $level++;
            close $cache_fh;
        }
    }

    return $result;
}

# write whois to cache
sub write_to_cache {
    my ($query, $result, $cache_dir) = @_;

    return unless $cache_dir && $result;
    mkdir $cache_dir unless -d $cache_dir;

    untaint $query; untaint $cache_dir;

    my $level = 0;
    foreach my $res ( @{$result} ) {
        local $res->{text} = $res->{whois} if not exists $res->{text};

        next if defined $res->{text} && !$res->{text} || !defined $res->{text};
        my $enc_text = $res->{text};
        utf8::encode( $enc_text );
        my $postfix = sprintf("%02d", $level);
        if ( open( my $cache_fh, '>', "$cache_dir/$query.$postfix" ) ) {
            print $cache_fh $res->{srv} ? $res->{srv} :
                ( $res->{server} ? $res->{server} : '')
                , "\n";

            print $cache_fh $enc_text ? $enc_text : '';

            close $cache_fh;
            chmod 0666, "$cache_dir/$query.$postfix";
        }
        $level++;
    }

}

# remove copyright messages, check for existance
sub process_whois {
    my ( $query, $server, $whois, $CHECK_FAIL, $OMIT_MSG, $CHECK_EXCEED ) = @_;

    $server = lc $server;
    my ( $name, $tld ) = split_domain( $query );

    # use string as is
    no utf8;

    if ( $CHECK_EXCEED ) {
        my $exceed = $Net::Whois::Raw::Data::exceed{ $server };

        if ( $exceed && $whois =~ /$exceed/s) {
            return $whois, 'Connection rate exceeded';
        }
    }

    $whois = _strip_trailer_lines( $whois )  if $OMIT_MSG;

    if ( $CHECK_FAIL || $OMIT_MSG ) {

        my $notfound = $Net::Whois::Raw::Data::notfound{ $server };
        my $strip = $Net::Whois::Raw::Data::strip{ $server };
        my @strip = $strip ? @$strip : ();
        my @lines;

        MAIN:
        for ( split /\n/, $whois ) {
            if ( $CHECK_FAIL && $notfound && /$notfound/ ) {
                return undef, "Not found";
            }

            if ( $OMIT_MSG ) {
                for my $re ( @strip ) {
                    next MAIN  if /$re/;
                }
            }

            push @lines, $_;
        }

        $whois = join "\n", @lines, '';

        if ( $OMIT_MSG ) {
            $whois =~ s/(?:\s*\n)+$/\n/s;
            $whois =~ s/^\n+//s;
            $whois =~ s|\n{3,}|\n\n|sg;
        }
    }

    if ( defined $Net::Whois::Raw::Data::postprocess{ $server } ) {
        $whois = $Net::Whois::Raw::Data::postprocess{ $server }->( $whois );
    }

    if ( defined $Net::Whois::Raw::POSTPROCESS{ $server } ) {
        $whois = $Net::Whois::Raw::POSTPROCESS{ $server }->( $whois );
    }

    if ( defined $Net::Whois::Raw::Data::codepages{ $server } ) {
        $whois = decode( $Net::Whois::Raw::Data::codepages{ $server }, $whois );
    }
    else {
        utf8::decode( $whois );
    }

    return $whois, undef;
}

# Tries to strip trailer lines of whois
sub _strip_trailer_lines {
    my ( $whois ) = @_;

    for my $re ( @Net::Whois::Raw::Data::strip_regexps ) {
        $whois =~ s/$re//;
    }

    return $whois;
}

# get whois-server for domain / tld
sub get_server {
    my ( $dom, $is_ns, $tld ) = @_;

    $tld ||= get_dom_tld( $dom );
    $tld = uc $tld;

    if ( grep { $_ eq $tld } @Net::Whois::Raw::Data::www_whois ) {
        return 'www_whois';
    }

    if ( $is_ns ) {
        return $Net::Whois::Raw::Data::servers{ $tld . '.NS' }
            || $Net::Whois::Raw::Data::servers{ 'NS' };
    }

    return lc( $Net::Whois::Raw::Data::servers{ $tld } || "whois.nic.$tld" );
}

sub get_real_whois_query{
    my ( $whoisquery, $srv, $is_ns ) = @_;

    $srv .= '.ns'  if $is_ns;

    if ( $srv eq 'whois.crsnic.net' && domain_level( $whoisquery ) == 2 ) {
        return "domain $whoisquery";
    }
    elsif ( $Net::Whois::Raw::Data::query_prefix{ $srv } ) {
        return $Net::Whois::Raw::Data::query_prefix{ $srv } . $whoisquery;
    }

    return $whoisquery;
}

# get domain TLD
sub get_dom_tld {
    my ($dom) = @_;

    my $tld;
    if ( is_ipaddr($dom) || is_ip6addr($dom) ) {
        $tld = "IP";
    }
    elsif ( domain_level($dom) == 1 ) {
        $tld = "NOTLD";
    }
    else {
        my @tokens = split( /\./, $dom );

        # try to get the longest known tld for this domain
        for my $i ( 1..$#tokens ) {
            my $tld_try = join '.', @tokens[$i..$#tokens];
            if ( exists $Net::Whois::Raw::Data::servers{ uc $tld_try } ) {
                $tld = $tld_try;
                last;
            }
        }

        $tld = $tokens[-1] unless $tld;
    }

    return $tld;
}

# get URL for query via HTTP
# %param: domain*
sub get_http_query_url {
    my ($domain) = @_;

    my ($name, $tld) = split_domain($domain);
    my @http_query_data;
    # my ($url, %form);

    if ($tld eq 'ru' || $tld eq 'su') {
        my $data = {
            url  => "http://www.nic.ru/whois/?domain=$name.$tld",
            form => '',
        };
        push @http_query_data, $data;
    }
    elsif ($tld eq 'ip') {
        my $data = {
            url  => "http://www.nic.ru/whois/?ip=$name",
            form => '',
        };
        push @http_query_data, $data;
    }
    elsif ($tld eq 'ws') {
        my $data = {
            url  => "http://worldsite.ws/utilities/lookup.dhtml?domain=$name&tld=$tld",
            form => '',
        };
        push @http_query_data, $data;
    }
    elsif ($tld eq 'kz') {
        my $data = {
            url  => "http://www.nic.kz/cgi-bin/whois?query=$name.$tld&x=0&y=0",
            form => '',
        };
        push @http_query_data, $data;
    }
    elsif ($tld eq 'vn') {
        # VN doesn't have web whois at the moment...
        my $data = {
            url  => "http://www.tenmien.vn/jsp/jsp/tracuudomain1.jsp",
            form => {
                cap2        => ".$tld",
                referer     => 'http://www.vnnic.vn/english/',
                domainname1 => $name,
            },
        };
        push @http_query_data, $data;
    }
    elsif ($tld eq 'ac') {
        my $data = {
            url  => "http://nic.ac/cgi-bin/whois?query=$name.$tld",
            form => '',
        };
        push @http_query_data, $data;
    }
    elsif ($tld eq 'bz') {
        my $data = {
            url  => "http://www.test.bz/Whois/index.php?query=$name&output=nice&dotname=.$tld&whois=Search",
        };
        push @http_query_data, $data;
    }
    elsif ($tld eq 'tj') {
        #my $data = {
        #    url  => "http://get.tj/whois/?lang=en&domain=$domain",
        #    from => '',
        #};
        #push @http_query_data, $data;

        # first level on nic.tj
        #$data = {
        #    url  => "http://www.nic.tj/cgi/lookup2?domain=$name",
        #    from => '',
        #};
        #push @http_query_data, $data;

        # second level on nic.tj
        my $data = {
            url  => "http://www.nic.tj/cgi/whois?domain=$name",
            from => '',
        };
        push @http_query_data, $data;

        #$data = {
        #    url  => "http://ns1.nic.tj/cgi/whois?domain=$name",
        #    from => '',
        #};
        #push @http_query_data, $data;

        #$data = {
        #    url  => "http://62.122.137.16/cgi/whois?domain=$name",
        #    from => '',
        #};
        #push @http_query_data, $data;
    }

    # return $url, %form;
    return \@http_query_data;
}

sub have_reserve_url {
    my ( $tld ) = @_;

    my %tld_list = (
        'tj' => 1,
    );

    return defined $tld_list{$tld};
}

# Parse content received from HTTP server
# %param: resp*, tld*
sub parse_www_content {
    my ($resp, $tld, $url, $CHECK_EXCEED) = @_;

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

    my $ishtml;

    if ( $tld eq 'ru' || $tld eq 'su' ) {

        $resp = decode( 'koi8-r', $resp );

        (undef, $resp) = split('.*?',$resp);
        ($resp) = split('