Source code of /package/bin/gwhois

Last modified: 2015-08-12 19:36:34

Download

#!/usr/bin/perl
#
#  generic Whois
#
#  (c) 1998-2010 by Juliane Holzt <debiankju.de>
#  Some early parts by Lutz Donnerhacke <Lutz.DonnerhackeJena.Thur.de>
#
#  Modifications (c) 2010-2015 by Daniel Marschall, ViaThinkSoft <infodaniel-marschall.de>
#
#  Distribution, usage etc. pp. regulated by the current version of GPL.
#
#
#
# History:
# 2015-05-06  mar   pattern.d/* will now be preferred.
#                   Last resort (.) is now built-in.
#                   Fixed UTF-8 query input.
# 2014-08-18  mar   UTF-8 output is now unified.
# 2014-04-02  mar   Accepting "refer:" which IANA sends.
# 2013-12-17  mar   Added native OID support. Output will now contain a BOM if whois server did return a UTF-8 string.
# 2013-05-05  mar   *.dpkg-dist wird nun auch ausgeschlossen.
# 2012-05-22  mar   "::::" (multiple+notice) is now not splitted by ":::" pattern
#                   multiple+notice can now be combined. "notice" will output "Additional information" then.
# 2012-05-22  mar   Output of "cgihttps" and "program" is now anti spam filtered, too
# 2012-04-26  mar   "--" is now recognized as command line argument seperator
# 2012-04-25  mar   E-Mail addresses are now anti-spam protected! (Can be disabled with the CLI argument flag -e)
#                   This allows to add "RIPE -B" as default for public services.
# 2012-04-13  mar   Changed all &foo() into foo() .
#                   See: https://www.socialtext.net/perl5/subroutines_called_with_the_ampersand
# 2012-04-01  mar   New pattern available for recognizing ASN number ranges
#                   e.g. *AS:123-456 will match AS123, AS124 ... AS456
# 2012-03-04  mar   Bugfix for IPv6 recognization
# 2012-02-26  mar   IPv6 is now handled with Net::IP::ip_expand_address()
# 2012-01-28  mar   rwhois is now accepted as ReferralServer
#                   GWhoIs::Core::redirectwhois can handle different port than 43
# 2012-01-17  mar   quotemeta() to avoid shell injections
#                        TODO: braucht man eigentlich nicht wegen der ursp. filterung
# 2012-01-10  mar   <pre> and <textarea> use now GWhoIs::Utils::htmlpre(). GWhoIs::Utils::render_html() optimized.
#                   Uses now STRICT perl code (used "my" everwhere and initialized variables)
#                   No warning at utf8 output, e.g. for cnnic.cn => UTF8 now possible.
# 2012-01-09  mar   Now recognizing "001.2.3.4" as "1.2.3.4" (IPv4 and IPv6)
# 2012-01-07  mar   Now supporting IPv6 subnetting / CIDR
# 2011-06-09  mar   Added "program" method which invokes a script.
#                   IPv4/6 detection: IPv6 needs at least one ":"
#                   -> e.g. "ac" can now be detected as TLD and not as IPv6 anymore.
#                   "To resolve one of the above handles" cannot be empty now.
# 2010-07-28  jule  Extend output from verisign-grs by last db update time
# 2010-05-15  jule  Add locale handling, use libidn for punycode
# 2008-10-19  jule  throw error on empty query string
# 2008-02-18  jule  added handling for .bi and .gh (never a shortage
#                   of nics wo need special handling)
# 2007-09-03  jule  made output from verisign-grs more verbose
# 2007-02-17  jule  added mechanism for modifying redirects (see readme.ripe)
# 2006-12-02  jule  new method multiple for doing multiple queries
# 2005-09-25  jule  replaced 'noipprefix' and 'ipprefix' by 'prefix'
# 2005-09-25  jule  query string is no longer forced lower case (Debian Bug#324669)
# 2005-01-15  jule  Added version output
# 2005-01-13  jule  Added "search" method 'notice' (for giving advice
#                   when no whois/lookup is available)
#                   Added "cgipostcurl" method which uses curl to
#                   fake a referer which is needed for the .nic.ar
#                   (i hate you!)
# 2005-01-06  jule  new routines for searching ipv4 addresses for more
#                   speed improvement
# 2005-01-03  jule  To get rid of the ERX tables which slow down everything,
#                   requery is now ok and will no longer send mails.
#                   (Debian Bug#243148)
#                   Added handling code for .pe (grr) (Debian Bug#264794)
# 2004-03-07  jule  Totally changed the ip address handling code, now uses
#                   CIDR blocks.
#                     Recognized 'ipas a.b.c.d' as a request to ask team
#                    cymru ip->as mapper whois
# 2004-03-03  jule  Integrated smaller fixes and changes done by lutz.
#                   Removed special code for publicinterestregistry, as
#                   transition is over, and referrers are nolonger used.
#                   Changed handling code for generic whois, can now take
#                   some parameters, removing need for special cases.
# 2003-07-29  jule  fixed publicinterestregistry which is now in transition
#                    phase integrating the whois data
# 2003-02-15  jule  fixed handling of dpkg-old pattern versions
# 2003-01-27  jule  whois.publicinterestregistry.net is now authorative for
#                   .org and needs another special treatment... :-(
#                   plus some minor fixes
# 2003-01-02  f2u   Add "+" for IP address queries to ARIN whois.
#                   Support multiple pattern files.
# 2002-11-01  cord  Small workaround for whois-servers that return ^M.
# 2002-01-17  jule  Reporting if query to upstream whois server failed
#                    (Debian Bug#122535)
# 2000-12-08  jule  Braindead answers from nsiregistry excluded (NSI again!)
# 2000-06-29  lutz  Multiple whois queries (jule)
# 2000-02-29  lutz  Removed obsolete cgibr.
#             lutz  Fixed bug in IP queries.
# 2000-02-08  lutz  Braindead answers from nsiregistry excluded
#                   Workaround for buginternic removed.
# 1999-12-01  jule  Support for new Internic two-step Whois
# 1999-08-04  lutz  Minor fixed
# 1999-07-01  lutz  Allowed spaces, commas and colons
# 1999-04-12  lutz  Hotfix for problems with LWP::Simple
# 1998-12-21  lutz  solving problems with ripe handles.
# 1998-12-18  lutz  Mirrors possible
#             jule  GWhoIs::Core::wwwsgrep with LWP::Simple
#             lutz  multiple options bug fixed
#             jule  whois access made with LWP::Simple
#             lutz  Cosmetic changes,
#                   Configurable,
#                   Dies without line numbers,
#                   Direct server access
#             jule  External Configuration File,
#                   Major rewrite
# 1998-12-17  lutz  Published due to jule
#


# todo
# * print whois parameters at "querying..."
# * lynx injection sicherheitslücke? => quotemeta()
# * regularly check https://bugs.debian.org/cgi-bin/pkgreport.cgi?src=gwhois

# TODO: "%" am Anfang jeder Meldung ausgeben

# TODO: lynx wird manchmal auch ausgeführt ohne -L ...
# TODO: Alle "!!" entfernen
# TODO: print -> $result .= ?

use warnings;
use strict;

use lib '/usr/share/gwhois/includes/';
use GWhoIs::Core;
use GWhoIs::Utils;
use GWhoIs::IPv4;
use GWhoIs::IPv6;
use GWhoIs::OID;

# install with "cpan Net::IP" or "aptitude install libnet-ip-perl"
use Net::IP;

use Net::LibIDN;
use Encode;
# use Encode::Detect::Detector; # requires Debian package libencode-detect-perl

#use encoding ':locale';

#use utf8;


# Examples for output of the different hosts:
# -------------------------------------------------------------
# Host                            Example    Output         BOM
# -------------------------------------------------------------
# whois.viathinksoft.de           oid:2.999  UTF-8          if required (existing BOMs will be removed)
# cnnic.cn                        cnnic.cn   UTF-8          no
# whois.ati.tn                    ati.tn     UTF-8          no
# whois.kr                        whois.kr   UTF-8          no
# whois.denic.de                  denic.de   ISO-8859-1     no
# oldwhois.kisa.or.kr (obsolete)  whois.kr   EUC-KR         no
# whois.nic.ch                    domian.ch  UTF-8          no
# (GWHOIS from ViaThinkSoft)                 UTF-8          yes (existing BOMs will be removed?)
# (old GWHOIS)                               (like server)  (like server)
# -------------------------------------------------------------


# TODO: for this diagram: check if existing BOMs will be removed, e.g. by LWP.
# TODO: how to stop LWP's auto-detect magic?
# TODO: only output bom if required? doesn't work, otherwise we would need to buffer stderr and stdout, and then their order is wrong again.


$ENV{'HOME'}='/var/home/whois' unless defined $ENV{'HOME'};

# Nicht nach GWhoIs::Core auslagern
# TODO: die $version auch von den .pm Modulen anzeigen?
my $version = '20100728+viathinksoft20150719';
my $fixwhoishost;
my $rawoutput = 0;

$| = 1; # buffer flushing = autoflush

if ( -f "/etc/default/gwhois" ) {
        require "/etc/default/gwhois";
}

while ($ARGV[0]) {
        if ($ARGV[0] eq '--help' || $ARGV[0] eq '-?') {
                print "gwhois - generic whois\n",
                "Version $version\n\n",
                "Usage: gwhois {options} [query]\n",
                " Try find information about the query (might be multiple words).\n",
                " If no query is given, use the first line from stdin\n\n",
                " Options:\n",
                "   -C dir                  Setting an alternate configuration directory\n",
                "                           default: $GWhoIs::Core::confdir\n",
                "   -h host                 Selecting a fixed whois server for this query\n",
                "   -m method:host mirror   Defining a mirror for a given method and host.\n",
                "   -L                      Use lynx -source instead of LWP::Simple\n",
                "   -e                      Do not protect eMail addresses\n",
                "   -c                      Do not try to convert to UTF-8. Output server's stream.\n",
                "   -v                      Output version of pattern table(s)\n",
                "   -?, --help              Printing this text\n\n";
                exit;
        } elsif ($ARGV[0] eq '-C') {
                shift;
                $GWhoIs::Core::confdir = shift;
        } elsif ($ARGV[0] eq '-c') {
                shift;
                $rawoutput = 1;
                $GWhoIs::Core::useLWP = 0; # TODO: geht irgendwie nicht anders
        } elsif ($ARGV[0] eq '-h') {
                shift;
                $fixwhoishost = shift;
        } elsif ($ARGV[0] eq '-L') {
                shift;
                $GWhoIs::Core::useLWP = 0;
        } elsif ($ARGV[0] eq '-m') {
                shift;
                $_ = shift;
                s/://;
                $GWhoIs::Core::mirror{$_} = shift;
        } elsif ($ARGV[0] eq '-e') {
                shift;
                $GWhoIs::Core::antispam = 0;
        } elsif ($ARGV[0] eq '-v') {
                print "gwhois - generic whois\n\n",
                "program version:  $version\n",
                "pattern tables:   ";
                foreach my $patternfile (GWhoIs::Core::getpatternfiles()) {
                        if (!open(PATTERN,"<$patternfile")) {
                                warn "Cannot open $patternfile. STOP.\n";
                                exit 1;
                        }

                        my $line = <PATTERN>;
                        close(PATTERN);

                        my $patternversion;
                        if (defined($line)) {
                                ($patternversion) = $line =~ /#:\s+version\s+(\S+)/;
                                $patternversion = 'unknown' if !defined($patternversion);
                        } else {
                                $patternversion = 'unknown';
                        }
                        print "$patternversion\t($patternfile)\n                  ";
                }
                print "\n";
                exit 0;
        } elsif ($ARGV[0] eq '--') {
                shift;
                last;
        } else {
                last;
        }
}

if ($rawoutput) {
        binmode(STDOUT, ":bytes");
        binmode(STDERR, ":bytes");
} else {
        binmode(STDOUT, ":utf8");
        binmode(STDERR, ":utf8");
}

if (defined $ARGV[0]) {
        $_ = join(' ', ARGV);
} else {
        # If no parameter is given, await an input from STDIN
        $_ = <>;
        chomp;
}

print "\x{FEFF}" if !$rawoutput; # BOM
exit main($_);

# -----------------------------------------------------------------------------------------

sub main {
        my $query = shift;

        $query = '' if !defined $query;

        if (GWhoIs::Utils::is_utf8($query)) {
                $query = Encode::decode('utf8', $query);
        }
        $query = GWhoIs::Utils::trim($query);

        if ($query eq '') {
                warn "Query is empty.\n";
                exit 2;
        }

        my ($method,$host,$additional);

        my $query_utf8 = GWhoIs::Utils::enforce_utf8($query);
        print "Process query: '$query_utf8'\n\n";

        if ( $fixwhoishost ) {
                # QUE: soll das immer gelten, oder nur, wenn ermittelt wurde, dass whois benötigt wird (nicht aber cgi, etc?)
                ($method,$host,$additional) = ('whois',$fixwhoishost,'');
        } else {
                # if ($query !~ /[^0-9\.]/) { # ipv4
                if ($query =~ /^[0-9\.]*$/) {
                        my ($a, $b, $c, $d, $e) = $query =~ /(\d+)\.(\d+)\.(\d+)\.(\d+)(.*)/;
                        $a = 256 if !defined $a;
                        $b = 256 if !defined $b;
                        $c = 256 if !defined $c;
                        $d = 256 if !defined $d;
                        $e = ''  if !defined $e;
                        if ($a > 255 || $b > 255 || $c > 255 || $d > 255 || $e ne '') {
                                warn "'$query' is no valid IP address, ASN, OID or domain name.\n";
                                exit 2;
                        }
                        print "Query recognized as IPv4.\n";

                        ($method,$host,$additional) = GWhoIs::IPv4::getmethodv4($a,$b,$c,$d);
                # } elsif ( lc($query) !~ /[^0-9a-f:]/i ) { # ipv6
                # } elsif ( $query !~ /[0-9a-f:]*/ ) {
                } elsif (($query =~ /:/ ) && ( Net::IP::ip_expand_address($query, 6) =~ /^[0-9a-f:]*:[0-9a-f:]*$/ )) { # at least one ":" so that e.g. "ac" is recognized as TLD and not as IPv6
                        # check and correct v6 address
                        if ( $query =~ /[0-9a-f]{5}/ || $query =~ /:::/ ) {
                                warn "'$query' is an invalid IPv6 address.\n";
                                exit 2;
                        }

                        my $orig_query = $query;
                        #$query =~ s/:?$/::/ if ( $query !~ /(.*:){7}/ && $query !~ /::/ );
                        $query = Net::IP::ip_expand_address($query, 6);

                        print "Query recognized as IPv6.\n";
                        print "Address expanded to '$query'.\n" if $orig_query ne $query;

                        ($method,$host,$additional) = GWhoIs::IPv6::getmethodv6($query);
                } elsif ($query =~ /^(urn:){0,1}oid:/i ) { # OID
                        print "Query recognized as OID.\n";

                        # preliminarily remove urn: and oid: from query
                        # we need a dot so that we can use "oid:." in our patternfile too
                        $query = GWhoIs::OID::normalize_oid($query);

                        my arcs = split(/\./, $query); # TODO: warum geht split('.',$oid) nicht?

                        ($method,$host,$additional) = GWhoIs::OID::getmethodoid(arcs);

                        # Whois OID query syntax definition by ViaThinkSoft (TODO: Apply for RFC):
                        # - urn:oid:2.999 or oid:2.999
                        # - Case insensitive
                        # - Leading dot should be tolerated (urn:oid:.2.999)
                        # - Leading zeros should be tolerated (urn:oid:.002.00999)
                        # Idea: Should "oid:" be optional? Since 2.999 cannot be an IP ... But 1.2.3.4 could be one ...

                        # There are many possibilities. We choose "oid:.2.999"
                        $query = 'oid:' . GWhoIs::OID::normalize_oid($query);
                } else {
                        # Last resort: Query is probably a TLD, domain or handle, but we are not sure!
                        # print "Query recognized as domain.\n";

                        # Dot exists?        Type?        Punycode?        Filtering?
                        # ------------------------------------------------
                        # Yes                Domain        Yes                Yes
                        # No                TLD        Yes                Yes
                        # No                Handle        No*                Maybe
                        # ------------------------------------------------
                        # * = but it is unlikely that a handle contains non-latin characters

                        # Filtering
                        $query =~ y/[\x{00A0}-\x{FFFF}]a-zA-Z0-9:.,+_ -//cd;
                        $query =~ s/\.$//;
                        my $query_utf8_filtered = GWhoIs::Utils::enforce_utf8($query);
                        if ( $query_utf8 ne $query_utf8_filtered ) {
                                # QUE: warn or print?
                                warn "Attention: Query was filtered to '$query_utf8_filtered'.\n\n";
                        }

                        # Punycode decoding
                        # my $ascii_query = Net::LibIDN::idn_to_ascii($query, 'utf-8')
                        # We separate between spaces, so that "tld <unicode>" can be processed
                        my query_split = split(' ', $query);
                        query_split = map { Net::LibIDN::idn_to_ascii($_, 'utf-8') || '' } query_split;
                        my $ascii_query = join(' ', query_split);

                        # Query valid?
                        if (!$ascii_query) { # e.g. $query = ".x"
                                warn "'$query_utf8' is an invalid domain name.\n";
                                return 2;
                        }

                        # Just information for the user
                        if (index($query, ".") != -1) {
                                print "Query recognized as domain.\n\n"; # TODO: aber wenn kein IDN?
                        } else {
                                print "Query is probably a handle or TLD.\n\n";
                        }

                        ($method,$host,$additional) = GWhoIs::Core::getmethodother($ascii_query);
                }
        }

        if ($method eq '') {
                warn "I don't know where to query that.\n";
                warn "If this is a valid domainname or handle, please file a bug report.\n";
                return 1;
        }

        # Wird in getmethod*() bereits ausgeführt.
        # Grund: Dann kann auch bei redirectwhois() dementsprechend in jedem Zwischenschritt gehandelt werden.
        # $host = $GWhoIs::Core::mirror{$method.$host} if defined $GWhoIs::Core::mirror{$method.$host};

        my ($result, $exitcode) = GWhoIs::Core::doquery($query,$method,$host,$additional);
        $result = '' if !defined $result; # should not happen!

        my $antispam_replacements = 0;
        if ($GWhoIs::Core::antispam) {
                # Protect email addresses (to allow e.g. "RIPE -B" for public services)
                # Note: eMail addresses have a much more complex structure, see http://code.google.com/p/isemail/
                # But this Regex should still prevent spammers from filtering eMail addresses,
                # even if e.g. the "wrong" (e.g. escaped) "" is protected.
                $antispam_replacements = $result =~ s/(\S+)(\S+)\.([^.\s]+)/$1 (at) $2 (dot) $3/g;
                # Alternative solution:
                # $antispam_replacements = $result =~ s/(\S+)(\S+)\.([^.\s]+)/$1&$2.$3/g;
        }

        # We try to get $result to wide-string. Functions like LWP::Simple automatically convert UTF-8 into Unicode
        # (even without BOM sent through the whois gopher channel!), while subprograms and other methods are providing
        # raw UTF-8 data.
        $result = Encode::decode('utf8', GWhoIs::Utils::trim($result), Encode::FB_CROAK) if !$rawoutput && GWhoIs::Utils::is_utf8($result);
        
        # Don't allow DOS format
        $result =~ s/(\012|\015\012?)/\n/g;

        # Output everything
        print GWhoIs::Utils::trim($result), "\n\n";

        if ($antispam_replacements > 0) {
                print "Note: The output has been modified by GWhoIs.\n";
                print "$antispam_replacements eMail addresses have been anti-spam protected.\n";
                print "(Disable protection with \"gwhois -e\")\n";
                print "\n";
        }

        # Footer
        print "--\n  To resolve one of the above handles:";

        if ($method =~ /whois/) {
                print "\n     whois -h $host";
                print ":$1" if ( $additional =~ /port=(\d+)/ );
                print " -- HANDLE\n";
        }
        elsif ($method eq "cgipost") {
                print "\n     POST $host\n";
                print "     $additional\n";
        }
        elsif ($method eq "cgi") {
                print "\n     $host\n";
        }
        elsif ($method eq "program") {
                print "\n     $host HANDLE\n";
        }
        # elsif ($method eq "wwwgrep") {
        else {
                # todo: add cgipostcurl etc
                print "\n     hmm. not sure (method = $method).\n";
        }

        print "  OTOH globally unique handles should be recognised directly by GWhoIs.\n";
        print "  Please report errors or misfits via the Debian bug tracking system.\n";

        return $exitcode;
}