#!/usr/bin/env perl

# PODNAME: pwhois
# ABSTRACT: Get Whois information of domains and IP addresses.

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 q{
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
};
    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 ) {
    if ( $^O eq 'MSWin32' ) {
        $Net::Whois::Raw::CACHE_DIR = $ENV{TEMP} || "C:\\temp";
    }
    else {
        $Net::Whois::Raw::CACHE_DIR = $ENV{TMPDIR} || '/tmp';
    }
}
else {
    $Net::Whois::Raw::CACHE_DIR = undef;
}

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

my ( $query, $server ) = @ARGV;

$query = decode_query( $query, $input_cp );

# Split domain name and optional part prepended by '?' character.
my ( $dname, $options ) = split /[?]/, $query;

unless ( validate_domain_name( $dname ) ) {
    print encode_output( "\nIncorrect dname:\n$dname\n", $output_cp );
    exit -1;
}

$query = to_punycode( $dname );

$query .= '?' . $options  if defined $options;

my ( $result, $result_server );
my $which_whois =
    $return_first ? 'QRY_FIRST' :
    $return_all   ? 'QRY_ALL'   : 'QRY_LAST';

eval {
    ( $result, $result_server ) = Net::Whois::Raw::get_whois( $query, $server, $which_whois );

    1;
} or do {
    my $err = $@;

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

if ( $result && 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";
}

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

    $result = encode_output( $result, $cp );

    print "[$server]\n", $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};

        if ( $cp ) {
            $cp =~ s/^[a-z]{2}_[A-Z]{2}[.]//;
        }
        else {
            $cp = 'utf-8';
        }

        $input_cp = $output_cp = lc $cp;
    }

    return $input_cp, $output_cp;
}

sub decode_query {
    my ( $query, $input_cp ) = @_;

    $query = decode( $input_cp, $query );

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

    return $query;
}

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

    return $dname  if $dname =~ /^[a-z0-9.\-]*$/;

    return join '.', 
           map { /^[a-z0-9.-]*$/ ? $_ : 'xn--' . Net::IDN::Punycode::encode_punycode( $_ ) }
           split /[.]/, $dname;
}

sub validate_domain_name {
    my ( $dname ) = @_;

    return 0  unless $dname;

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

    # query with tld only
    return 1  unless $name;

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

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

    return 1;
}

__END__

=pod

=encoding UTF-8

=head1 NAME

pwhois - Get Whois information of domains and IP addresses.

=head1 VERSION

version 2.99037

=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 NAME

pwhois   - Perl written whois client

=head1 AUTHORS

Ariel Brosh B<schop@cpan.org>
Walery Studennikov B<despair@cpan.org>

Current Maintainer: Alexander Nalobin B<nalobin@cpan.org>

=head1 SEE ALSO

L<Net::Whois::Raw>.

=head1 AUTHOR

Alexander Nalobin <alexander@nalobin.ru>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2002-2022 by Alexander Nalobin.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut