#!/usr/bin/perl -w

use strict;
use warnings;
use Net::Whois::Raw;
use Getopt::Long;
use Encode;
use Net::IDN::Punycode qw( :all );
use utf8;

my $help;
my $do_strip;
my $do_strip_more;
my $do_checkfail;
my $do_checkfail_more;
my $debug = 0;
my $timeout = 10;
my $enable_caching;
my @source_addresses;
my $return_first;
my $return_last;
my $return_all;

Getopt::Long::Configure( 'bundling', 'no_ignore_case' );

GetOptions(
    'help|h'           => \$help,
    'strip|s'          => \$do_strip,
    'checkfail|c'      => \$do_checkfail,
    'debug|d+'         => \$debug,
    'timeout|T=i'      => \$timeout,
    'enable_caching|t' => \$enable_caching,
    'src_addr|a=s@'    => \@source_addresses,
    'return_first|F'   => \$return_first,
    'return_last|L'    => \$return_last,
    'return_all|A'     => \$return_all,
) or die;

if ($help || !@ARGV) {
    print <<EOM;
Usage:	$0 [ -s ] [ -c ] [ -d ] [ -T <timeout> ] [ -a <src_ip> ] [ -t ] [ -F | -L | -A ] <domain> [ <server> ]

Switches:
-s	attempt to strip the copyright message or disclaimer.
-c	attempts to return an empty answer for failed searches.
-T	set timeout for connection attempts
-t	enables caching.
-a	specify an ip address that should be used as source address
-d	enables debugging messages.
-F	returns results of the first query of recursive whois requests
-L	returns results of the last query of recursive whois requests (the default)
-A	returns results of the all queries of recursive whois requests
EOM
    exit; 
}

$Net::Whois::Raw::DEBUG      = $debug;
$Net::Whois::Raw::OMIT_MSG   = $do_strip     ? 1 : 0;
$Net::Whois::Raw::CHECK_FAIL = $do_checkfail ? 1 : 0;
$Net::Whois::Raw::TIMEOUT    = $timeout;
@Net::Whois::Raw::SRC_IPS    = @source_addresses if @source_addresses;

if ($enable_caching) {
    $Net::Whois::Raw::CACHE_DIR = $ENV{TEMP} || ($^O =~ /Win/ ? "C:\\temp" : '/tmp' );
}
else {
    $Net::Whois::Raw::CACHE_DIR = undef;
}

my ( $input_cp, $output_cp ) = detect_encodings();

my $dom = $ARGV[0];
my $server = $ARGV[1];

$dom = prepare_domain($dom, $input_cp);

unless (validate_domain($dom)) {
    print encode_output("\nIncorrect domain name:\n$dom\n", $output_cp);
    exit -1;
}

$dom = to_punycode($dom);

eval {
    my ($result, $result_server);
    my $which_whois = 
        $return_first ? 'QRY_FIRST' :
        $return_all   ? 'QRY_ALL'   : 'QRY_LAST';
                        
    ($result, $result_server) = 
        Net::Whois::Raw::get_whois( $dom, $server, $which_whois );

    if ($result and ref $result eq 'ARRAY') {
        make_output($_->{text}, $_->{srv}, $output_cp) for @{$result};
    }
    elsif ($result) {
        make_output($result, $result_server, $output_cp);
    }
    else {
        print STDERR "Failed.\n";
    }
};

if ($@) {
    my $err = $@;

    $err =~ s/\s+at \S+ line \d+\.$//;
    print "\nWhois information could not be fetched:\n$err\n";
    exit -1;
}	

# Prepare and print output
sub make_output {
    my ($result, $server, $cp) = @_;

    $result = encode_output( $result, $cp );
    
    print "[$server]\n";
    print $result, "\n";
}

# Encode output
sub encode_output {
    my ( $output, $cp ) = @_;

    if ( $cp =~ /utf\-?8/ ) {
        $output = encode_utf8( $output );
    }
    else {
        $output = encode( $cp, $output );
    }

    return $output;
}

# Detect terminal input and output encodings 
sub detect_encodings {
    my ( $input_cp, $output_cp );

    if ( $^O =~ /Win/ ) {
        # Read encoding from registry
        require Win32API::Registry;
        Win32API::Registry->import( qw( :ALL ) );
    
        my ( $key, $type, $data );
        RegOpenKeyEx( HKEY_LOCAL_MACHINE(), 'SYSTEM\\CurrentControlSet\\Control\\Nls\\CodePage', 0, KEY_READ(), $key )
            or die "Can't read system encodings from registry: ".regLastError();
        RegQueryValueEx( $key, 'ACP', [], $type, $data, [] )
            or die "Can't read system encodings from registry: ".regLastError();
        $input_cp = 'cp'.$data;
        RegQueryValueEx( $key, 'OEMCP', [], $type, $data, [] )
            or die "Can't read system encodings from registry: ".regLastError();
        $output_cp = 'cp'.$data;
    } else {
        # Read encoding from environment
        (my $cp = $ENV{LANG}) =~ s/^[a-z]{2}_[A-Z]{2}\.//;
        $input_cp = $output_cp = lc $cp;
    }

    return ($input_cp, $output_cp);
}

# Prepare domain name
sub prepare_domain {
    my ($dom, $input_cp) = @_;

    # Decode command-line input
    $dom = decode($input_cp, $dom);

    # Lowercase latin and cyrillic characters
    $dom =~ tr/A-ZА-ЯЁ\xAA\xA5\xB2\xAF/a-zа-яё\xBA\xB4\xB3\xBF/;

    return $dom;
}

# Decode domain name to punycode if needed
sub to_punycode {
    my ($dom) = @_;

    unless ($dom =~ /^[a-z0-9.\-]*$/) {
        # Convert to Punycode
        my @parts;
        foreach my $part (split /\./, $dom) {
            $part = 'xn--'.Net::IDN::Punycode::encode_punycode( $part )
                unless $part =~ /^[a-z0-9.-]*$/;
            push @parts, $part;
        }
        $dom = join('.', @parts);
    }

    return $dom;
}

# Validate domain name
sub validate_domain {
    my ($dom) = @_;

    return 0 unless $dom;

    $dom =~ /(.+?)\.([^.]+)$/;
    my ($name, $tld) = ($1, $2);

    return 0 if $name =~ /^-/;
    return 0 if $name =~ /-$/;
    return 0 if $name =~ /^..--/ && $dom !~ /^xn--/;

    # Only latin and cyrillic characters allowed now
    return 0 if $dom =~ m/[^-a-z0-9\.ёа-я\xAA\xBA\xB4\xB2\xB3\xAF\xBF\xA1\xA2]/;

    return 1;
}

__END__

=head1 NAME

pwhois   - Perl written whois client

=head1 SYNOPSIS

	pwhois perl.com
	pwhois gnu.org
	pwhois -s police.co.il
	pwhois -c there.is.no.tld.called.foobar
	pwhois yahoo.com whois.networksolutions.com
	pwhois -T 10 funet.fi

etc etc.....

=head1 DESCRIPTION

Just invoke with a domain name, optionally with a whois server name.
Switches:
    B<-s> attempt to strip the copyright message or disclaimer.
    B<-c> attempts to return an empty answer for failed searches.
    B<-e> forces die if connection rate to server have been exceeded.
    B<-T> set timeout for connection attempts
    B<-t> enables caching.
    B<-a> specify an ip address that should be used as source address
    B<-d> enables debugging messages.
    B<-F> returns results of the first query of recursive whois requests
    B<-L> returns results of the last query of recursive whois requests (the default)
    B<-A> returns results of the all queries of recursive whois requests
 
=head1 AUTHORS

Ariel Brosh B<schop@cpan.org>

Current Maintainer: Walery Studennikov B<despair@cpan.org>

=head1 SEE ALSO

L<Net::Whois::Raw>.