#!/usr/bin/perl
# 
# hinfo -- look up info on a host
#	Version 1.02	asn.routeviews.org code
#			minor cleanup of timeout messages
#	Version 1.01	ignore port specfiication in url
#			whois hack for .jp 133/8 block 
#			Do name based DNSBLs even if no IP address
#			Minor tweeks to paralellize code
#			Minor cleanup of messages
#			use strict
#			add MX processing code (-m)
#	Version 1.0	man page done
#	Version 0.94	Fix bug in explain_txt for name based lists
#			Elimiante -a option since abuse.net now has DNS
#	Version 0.93	Eliminate unused alarm code
#			Make most timeout messages conditional on $verbose
#	Version 0.92	Fix error in whois connect error code
#       Version 0.91    Improve quote handling in config files
#	Version 0.90	Fix /etc/hinfo.conf name (oops)
#			add --timeout command-line option
#			add --version
#	Version 0.89	fourth public beta
#			major rewrite, incompatable configuration
#
# Copywrite 2002-2004 Blars Blarson <blarson@blars.org>
#
## This program is free software; you can redistribute it and/or modify
## it under the terms of the version 2 of the GNU General Public License 
## as published by the Free Software Foundation.  The license should
## be included in the file COPYING distributed with the source.
##

use strict;
use IO::Socket;
use IO::Select;
use Net::DNS;

my $version = "hinfo version 1.02 06 Nov 2004";

# where to look for configuration info
my @rcfiles = (
	$ENV{"HOME"}."/.hinforc", 
	"/etc/hinfo.conf",
	"/usr/local/etc/hinfo.conf",
);

$| = 1;		# autoflush output
my $nl = "\n";	# newline (changed for html)
my $debug = 0;

# default values, may be overriden in configuraiton file or command line
my %var = (
    '$html'		=> 0,			# html output mode
    '$pager'		=> $ENV{"PAGER"},	# pager
    '$verbose'		=> 0,			# verbosity    
    '$no_abuse'		=> 0,			# (obsolete) abuse.net whois lookups
    '$no_asn'		=> 0,
    '$no_blackhole'	=> 0,
    '$no_whois'		=> 0,
    '$no_domain'	=> 0,
    '$whoistrash'	=> '^.^',
    '$whoismltrash'	=> '^.^',
    '$exclude'		=> '^.^',
    '$expand_handles'	=> 0,
    '$timeout'		=> 25,
    '$whoistimeout'	=> 20,
    '$nameserver'	=> '',
    '$mx'		=> 0,
    '@bhlists'		=> [],
    '@domainbased'	=> [],
    '@version'		=> [],
    '%registrys'	=> {},
    '%refer'		=> {},
);

my %explainsubs = (
    "explain_bitmask"	=> \&explain_bitmask,
    "explain_iterate"	=> \&explain_iterate,
    "explain_txt"	=> \&explain_txt,
    "explain_iterate_txt" => \&explain_iterate_txt,
);

# read config file
if ($ARGV[0] =~ /^-(?:f|-config-?file$)/) {
    my $o = shift @ARGV;
    my $f = shift @ARGV;
    if (!process_rc($f)) {
	die "Could not process $f";
    }
    if ($o =~ /^-f(.+)$/) {
	unshift @ARGV, '-'.$1;
    }
} else {
    foreach (@rcfiles) {
	if (&process_rc($_)) {
	    last;
	}
    }
}


while (($ARGV[0] =~ /^([-+])/)) {	# process options
    my $pref = $1;	
    my $p = $pref eq '-';
    $_ = shift @ARGV;
    if (/^-(?:h|-help$)/) {
        print   "Usage: $0 [options] [ ip | hostname | URL ]...\n".
		"  options:\n".
#		"     -a or --no-abuse      Do not use whois.abuse.net\n".
		"     -b or --no-blackhole  Do not use blackhole lists\n".
		"     -d or --no-domain     Do not use domain based queries\n".
		"     -e or --expand-handles\n".
		"                           Expand (all) NIC handles\n".
		"     -f or --config-file <FILE>\n".
                "                           Read configuration options from <FILE>\n".
                "                           (instead of .hinforc if first option)\n".
	 	"     -h or --help          Print this text\n".
		"     -m or --mx            Process mx records\n".
	 	"     -n or --no-pager      Do not use pager on output\n".
	 	"     -p or --pager <PAGER>\n".
	      	"                           Use <PAGER> rather than \$PAGER\n".
		"     -r or --no-asn        Do not lookup ASN information\n",
		"     -s or --nameserver <SERVER>\n".
		"                           Use DNS server <SERVER>\n".
	 	"     -u or --html          Format output as html\n".
		"     -t or --timeout <SECONDS>\n".
		"                           Set timeout value\n".
		"     -v or --verbose       Increase verbosity\n".
		"     --version             Display versions and exit\n".
		"     -w or --no-whois      Do not do IP block lookup\n".
		"\n".
		"Most options can be preceded by + rather than - to reverse their meaning.\n".
		"\n";
	exit 0;
    } elsif (/^[-+](?:u|-html$)/) {
        $var{'$html'} = $p;
    } elsif (/^[-+](?:n|-no-?pager$)/) {
        if ($p) {
            $var{'$pager'} = "";
	} else {
	    $var{'$pager'} = $ENV{"PAGER"};
	}    
    } elsif (/^[-+](?:p|-pager$)/) {
        if ($p) {
            $var{'$pager'} = shift @ARGV;
	} else {
	    $var{'$pager'} = "";
	}    
    } elsif (/^[-+](?:a|-no-?abuse$)/) {
        $var{'$no_abuse'} = $p;
    } elsif (/^[-+](?:r|-no-?asn$)/) {
	$var{'$no_asn'} = $p;    
    } elsif (/^[-+](?:b|-no-?blackhole$)/) {
        $var{'$no_blackhole'} = $p;
    } elsif (/^[-+](?:w|-no-?whois$)/) {
    	$var{'$no_whois'} = $p;
    } elsif (/^[-+](?:d|-no-?domain$)/) {
        $var{'$no_domain'} = $p;
    } elsif (/^[-+](?:v|-verbose$)/) {
	if ($p) {
	    $var{'$verbose'}++;
	} else {
	    $var{'$verbose'}--;
	}
    } elsif (/^-(?:f|-config-?file$)/) {
	my $f = shift @ARGV;
	if (!process_rc($f)) {
	    die "Could not process $f";
	}
    } elsif (/^[-+](?:e|-expand-?handles?$)/) {
	if ($p) {
	    $var{'$expand_handles'}++;
	} else {
	    $var{'$expand_handles'}--;
	}
    } elsif (/^-(?:s|-nameserver$)/) {
	$var{'$nameserver'} = shift @ARGV;
    } elsif (/^--version$/) {
	print "$version\n".join("\n",@{$var{'@version'}})."\n";
	exit 0;
    } elsif (/^-(?:t|-timeout$)/) {
	$var{'$timeout'} = shift @ARGV;
	die "Bad timeout value on command line: ".$var{'$timeout'}
	    if ($var{'$timeout'} !~ /^\d+$/);
    } elsif (/^[-+](?:m|-mx$)/) {
	if ($p) {
	    $var{'$mx'}++;
	} else {
	    $var{'$mx'}--;
	}
    } elsif ($_ eq "--") {
    	last;
    } else {
        die "Unknown option \"$_\", use --help for help";
    }
    if (/^[-+][a-z]([a-z]+)$/i) {
        unshift @ARGV, $pref.$1;
    }
}
my $html = $var{'$html'};
if ($html) {
    $nl = "<br>\n";
    $| = 0;
    $var{'$pager'} = "";
    print "<html><body>\n";
}
if ($var{'$pager'}) {
    open(STDOUT, "|".$var{'$pager'}) || die "Cannout open pager $!";
}
my $verbose = $var{'$verbose'};
my $whoistrash = $var{'$whoistrash'};	# used in zaptrash
my $whoismltrash = $var{'$whoismltrash'};	# used in zaptrash
my $exclude = $var{'$exclude'};
my @bhlists = grep ${$_}[0] !~ /$exclude/ixo, @{$var{'@bhlists'}};
my @domainbased = grep ${$_}[0] !~ /$exclude/ixo, @{$var{'@domainbased'}};

my %seenip = ();
my %seenname = ();
my %bg = ();
my %bgw = ();
my %bge = ();
my %nsa = ();
my $sel = IO::Select->new();
my $selw = IO::Select->new();
my $sele = IO::Select->new();
my $outtail = [];
my $outhead = $outtail;
my $res = Net::DNS::Resolver->new;
if ($var{'$nameserver'}) {
    $res->nameservers($var{'$nameserver'});
}
my $inpready = 0;
my $host;

host: foreach $host (@ARGV) {
    my $h = $host;
    $h =~ s/[\%\=]([0-9a-fA-F]{2})/chr hex $1/ge;
    $h =~ s/\&\#(\d{1,3})\;/chr $1/ge;
    # extract host from URL, email address, or other garbage
    if ($h =~ /^(?:[a-z]+:[\/\\]{0,2}|[^a-z\d]*)(?:[^@\/\\]*@\[?|)	# leading garbage
	    ([a-z\d\.\-]+)					 	# host
	    (?:\:\d+)?(?:[^a-z\d]*|[\/\\\?].*)$/ix ) {			# trailing garbage
    	$h = $1;
    }
    my @ia;
    if ($h =~ /^((\d+|0x[\da-f]+)\.){3}([\d]+|0x[\da-f]+)$/i) { # dotted quad
    	@ia = split(/\./,$h);
    	foreach (@ia) {
            if (/^0/) {
	        $_ = oct($_);
	    }
	    if ($_ > 255) {
	        $_ = $_ % 256;
	    }
        }
    } elsif ($h =~ /^(\d+|0x[\da-f]+)$/i) {			# numeric
        if ($h =~ /^0/) {
            $h = oct($h);
        }
        @ia = unpack('C4',pack('N',$h));
    } else {							# hostname
	my $bgsock = $res->bgsend($h, 'A');
	my $x = insh(\$outtail);
	my $ni = insh(\$outtail);
	$bg{$bgsock} = [\&nameproc, $x, insh(\$outtail), $bgsock, $h, $host];
	$sel->add($bgsock);
$debug && printf STDERR "ADDED q1 %s ref %s\n", $h, $bgsock;
	nameinfo($h, $ni);
	pready(0);
	if ($var{'$mx'} > 0) {
	    my $bgsock = $res->bgsend($h, 'MX');
	    $bg{$bgsock} = [\&mxproc, insh(\$outtail), $bgsock, $h, $host];
	    $sel->add($bgsock);
	}
	next host; 
    }

    my $ia = join('.',@ia);		
    if ($html) {
        insh(\$outtail)->[1] = "<h1>Processing $host ($ia)</h1>\n";
    } else {
        insh(\$outtail)->[1] = "Processing $host ($ia)\n";
    }
    &process($ia, insh(\$outtail));
    pready(0);
}

if ($html) {
    insh(\$outtail)->[1] = "</body></html>\n";
}
pout();
pready($var{'$timeout'});
while ($outhead ne $outtail) {
    print "ERROR missing responce goes here\n";
    $outhead = $outhead->[0];
    pout();
}

close STDOUT;	# needed for pager

exit 0;

sub insh {
    my $hr = $_[0];
    my $x = $$hr;
    $$hr = [$x->[0]];
    $x->[0] = $$hr;
    return $x;
}

sub pready {
# process any ready IO
    my $timeout = $_[0];

    if ($inpready) {
	$debug && print STDERR "ATTEMPTED RECURSIVE PREADY\n";
	return;
    }
    $inpready = 1;

    while ($sel->count() || $selw->count()) {
$debug && printf STDERR "WAITING for %s read %s write %s error\n", $sel->count, $selw->count, $sele->count;
	my ($ready, $readyw, $readye) = IO::Select->select($sel,$selw,$sele,
		$timeout);
$debug && printf STDERR "READY %s read %s write %s error\n", scalar(@$ready), scalar(@$readyw), scalar(@$readye);
        last unless (defined(@$ready) || defined(@$readyw) || defined(@$readye));
	foreach my $r (@$readye) {
	    my $b = $bge{$r};
	    $debug && print STDERR "ERROR fd $r\n";
	    $sele->remove($r);
	    delete $bge{$r};
	    &{$b->[0]}($b);
	}
        foreach my $w (@$readyw) {
	    my $b = $bgw{$w};
	    $debug && print STDERR "WRITING fd $w\n";
	    $selw->remove($w);
	    delete $bgw{$w};
	    &{$b->[0]}($b);
    	}
	foreach my $r (@$ready) {
	    my $b = $bg{$r};
	    $debug && print STDERR "READING fd $r\n";
	    $sel->remove($r);
	    delete $bg{$r};
	    &{$b->[0]}($b);
	}
	pout();
    }
    if ($timeout && ($sel->count() || $selw->count())) {
$debug && printf STDERR "TIMEOUT left %s read %s write %s error\n", $sel->count(), $selw->count(), $sele->count();
	foreach my $h ($sel->handles()) {
	    my $b = $bg{$h};
	    $sel->remove($h);
	    delete $bg{$h};
	    my $r = $b->[0];
	    if ($r eq \&nameproc) {
		$b->[1]->[1] = "timeout looking up ".$b->[4]."\n";
		$b->[2]->[1] = "\n";
	    } elsif ($verbose >= 0) {
		if ($r eq \&bhcheck) {
		    $b->[1]->[1] = "timeout looking up ".$b->[4]." in ".$b->[3]->[1]."\n";
		} elsif ($r eq \&checkrev) {
		    $b->[1]->[1] = "timeout looking up ".$b->[3]."\n";
		} elsif ($r eq \&checkfwrev) {
		    $b->[1]->[1] = "timeout looking up ".$b->[4]."\n";
		} elsif ($r eq \&dbhcheck) {
		    $b->[1]->[1] = "timeout looking up ".$b->[4].$b->[3]->[0]."\n";
		} elsif ($r eq \&whonic) {
		    $b->[1]->[1] = "timeout looking up ".$b->[4]."\n\n";
		} elsif ($r eq \&whoread) {
		    $b->[1]->[1] = "timeout waiting for ".$b->[4]." to respond\n\n";
		} elsif ($r eq \&etxt) {
		    $b->[1]->[1] = "timeout looking up TXT ".$b->[3]."\n";
		} elsif ($r eq \&mxproc) {
		    $b->[1]->[1] = "timeout looking up MX ".$b->[3]."\n\n";
		} elsif ($r eq \&asnshow) {
		    $b->[1]->[1] = "timeout looking up ASN ".$b->[3]."\n";
		} else {
		    $b->[1]->[1] = "timeout waiting for unknown\n";
		}
	    }
	}
	foreach my $h ($selw->handles()) {
	    my $b = $bgw{$h};
	    $sel->remove($h);
	    delete $bgw{$h};
	    if ($verbose >= 0) {
		my $r = $b->[0];
		if ($r eq \&whoquery) {
		    $b->[1]->[1] = "timeout waiting to write to ".$b->[1]->[4]."\n";
		} else {
		    $b->[1]->[1] = "timeout waiting for unknown write\n";
		}
	    }
	}
	pout();
    }
    $inpready = 0;
}

sub pout {
# print the ready strings
    while(defined $outhead->[1]) {
	print $outhead->[1];
	$outhead = $outhead->[0];
    }
}

sub nameproc {
    my (undef, $x, $here, $bgsock, $h, $host) = @{$_[0]};
    my @a;

    foreach ($res->bgread($bgsock)->answer) {
	if ($_->type eq 'A') {
	    push @a, $_->address;
	}
    }
    $bgsock->close;
    if (@a) {
	$x->[1] = "Processing $host (".join(', ',@a).")\n";
	if ($html) {
	    $x->[1] = "<h1>".$x->[1]."</h1>\n";
        }
	foreach (@a) {
	    process($_, insh(\$here));
	}
	$here->[1] = '';
    } else {
        $x->[1] = "Processing $host (No address: $h)\n";
        if ($html) {
	    $x->[1] = "<h1>".$x->[1]."</h1>\n";
        }
	$here->[1] = $nl;
    }
}

sub mxproc {
    my (undef, $here, $bgsock, $h, $host) = @{$_[0]};
    my %mxp;

    foreach ($res->bgread($bgsock)->answer) {
	if ($_->type eq 'MX') {
	    $mxp{$_->exchange} = $_->preference;
	}
    }
    $bgsock->close;
    foreach my $t (sort {$mxp{$a} <=> $mxp{$b}} keys %mxp) {
	my $bgsock = $res->bgsend($t, 'A');
	my $x = insh(\$here);
	my $ni = insh(\$here);
	$bg{$bgsock} = [\&nameproc, $x, insh(\$here), $bgsock,
			$t, "$host MX $mxp{$t} $t"];
	$sel->add($bgsock);
	nameinfo($t, $ni);
    }
    $here->[1] = $nl;
}

sub process {
    my ($ia, $here) = @_;		# $ia	is dotted quad
    my @ia = split(/\./,$ia);		# @ia	is quad in array
    my $ra = join('.',reverse(@ia));	# $ra	is reverse order dotted quad

    if(exists $seenip{$ia}) {
	if ($verbose >= 2) {
	    $here->[1] = "$ia already seen\n\n";
	} else {
	    $here->[1] = "\n";
	}
	return;
    }
    $seenip{$ia} = 1;

    my $bgsock = $res->bgsend("$ra.in-addr.arpa", 'PTR');
    $bg{$bgsock} = [\&checkrev, insh(\$here), $bgsock, $ia];
    $sel->add($bgsock);
$debug && printf STDERR "ADDED q2 %s ref %s\n", "$ra.in-addr.arpa", $bgsock;

    if(!$var{'$no_blackhole'}) {
	foreach my $bh (@bhlists) {
	    my ($la,$ln,$url,$expsub,$exp) = @$bh;
	    my $bgsock = $res->bgsend("$ra.$la.", 'A');
	    $bg{$bgsock} = [\&bhcheck, insh(\$here), $bgsock, $bh, $ia];
	    $sel->add($bgsock);	
$debug && printf STDERR "ADDED q3 %s ref %s\n", "$ra.$la.", $bgsock;
	    pready(0) unless($inpready);
	}
    }

    unless ($var{'$no_asn'}) {
        $bgsock = $res->bgsend("$ra.asn.routeviews.org", 'TXT');
        $bg{$bgsock} = [\&asnshow, insh(\$here), $bgsock, $ia];
        $sel->add($bgsock);
$debug && printf STDERR "ADDED q3.5 %s ref %s\n", "$ra.asn.routeivews.org", $bgsock;
        pready(0) unless($inpready);
    }

    if (!$var{'$no_whois'}) {
        my $x = insh(\$here);
	$x->[1] = "\n";
	IPCheck(insh(\$here), $ia);
    }

    $here->[1] = "\n";
}

sub checkrev {
    my (undef, $here, $bgsock, $ia) = @{$_[0]};
    
    foreach ($res->bgread($bgsock)->answer) {
	if ($_->type eq 'PTR') {
	    my $h = $_->rdatastr;
	    my $bgsock = $res->bgsend($h, 'A');
	    $bg{$bgsock} = [\&checkfwrev, insh(\$here), $bgsock, $ia, $h];
	    $sel->add($bgsock);
$debug && printf STDERR "ADDED q4 %s ref %s\n", $h, $bgsock;
	}
    }
    $here->[1] = '';
    $bgsock->close;
}

sub checkfwrev {
    my (undef, $here, $bgsock, $ia, $h) = @{$_[0]};
    my $found = 0;
    my $any = 0;

    foreach ($res->bgread($bgsock)->answer) {
	if ($_->type eq 'A') {
	    $any++;
	    if ($_->address eq $ia) {
		$found++;
		last;
	    }
	}
    }
    if ($found) {
	my $x = insh(\$here);
	$x->[1] = "$ia is $h$nl";
	nameinfo($h, $here);
    } elsif ($any) {
	$here->[1] = "$ia is falsely claiming to be $h$nl";
    } else {
	$here->[1] = "$ia is claiming to be nonexistant host $h$nl";
    }
    $bgsock->close;
}

sub bhcheck {
    my (undef, $here, $bgsock, $bh, $ia) = @{$_[0]};
    my ($la,$ln,$url,$expsub, $exp) = @$bh;

    foreach ($res->bgread($bgsock)->answer) {
        if ($_->type eq 'A') {
	    my $n = $_->address;
	    my $x = insh(\$here);
	    if ($html) {
    	        $x->[1] = "$ia is in <a href=\"http://$url\">$ln</a> as $n<br>\n";
	    } else {
    	        $x->[1] = "$ia is in $ln as $n\n";
	    }
	    if ($expsub && $verbose >= 0) {
	        &$expsub($n, $exp, insh(\$here), $bh, $ia);
	    }
        } elsif ($verbose > 1 && $_->type ne 'CNAME') {
	    my $x = insh(\$here);
	    $x->[1] = "$ln returned unexpected data type ".$_->type.$nl;
        }
    }
    $here->[1] = '';
    $bgsock->close;
}

my ($rc, $rcfile);

sub singleval {
# $debug && print length($rc)."\t".pos($rc)."\n";
    # quoted string
    if ($rc =~ /\G\s*([\"\'])([^\\\"\']*)/sgc) {
	my $q = $1;
	my $s = $2;
	while (substr($rc,pos($rc),1) ne $q) {
	    if ($rc =~ /\G$/sgc) {
		die "Unmatched quote $q in $rcfile";
	    }
	    if ($rc =~ /\G\\(.)/sgc) {
		my $x = $1;
		if ($x =~ /[\\\'\"]/) {
		    $s .= $x;
		} elsif ($q eq '\'') {
		    $s .= '\\' . $x;
		} else {
		    $x =~ tr/ntr/\n\t\r/;
		    $s .= $x;
		}
	    } elsif ($rc =~ /\G(.[^\\\'\"]*)/sgc) {
		$s .= $1;
	    }
	}
	pos($rc)++;
#	$debug && print pos($rc)."\tquoted string \"$s\"\n";
        return $s;
    }
    # number
    if ($rc =~/\G\s*(-?\d+)\s*/sgc) {
#	$debug && print pos($rc)."\tnumber $1\n";
        return $1;
    }
    # list
    if ($rc =~/\G\s*\[\s*/sgc) {
#	$debug && print pos($rc)."\tarray reference [\n";
	my $v = [];
        my $x;
	for (;;) {
	    if (defined($x = &singleval())) {
		my $qq = push @$v, $x;
#		$debug && print "\t$qq elements\n";
	    } elsif ($rc =~ /\G(\@\w+)\s*/sgc) {
		my $qq = push @$v, @{$var{$1}};
#		$debug && print "\t$qq elements\n";
	    }
	    if ($rc !~ /\G\,\s*/sgc) {
	        last;
	    }
	}
# $debug && print pos($rc)."\n";
	if ($rc =~ /\G\s*\]\s*/sgc) {
#	    $debug && print pos($rc)."\t]\n";
	    return $v;
	}
	die "Mismatched [ in $rcfile near ".substr($rc,pos($rc),20);
    }
    # subroutine reference
    if ($rc =~ /\G\s*\\\&(\w+)\s*/sgc) {
# $debug && print pos($rc)."\tsubroutine reference \\\&$1\n";
	if (exists $explainsubs{$1}) {
	    return $explainsubs{$1};
	}
	die "Unknown subroutine \\&$1 in $rcfile";
    }
    # hash
    if ($rc =~ /\G\s*\{\s*/sgc) {
#	$debug && print pos($rc)."\thash reference {\n";
	my $v = {};
	my $x;
	while (defined($x = &singleval())) {
	    if ($rc !~ /\G\s*\=\>\s*/sgc) {
		die "hash value incomplete in $rcfile near ".substr($rc,pos($rc),20);
	    }
	    my $y;
	    if (!defined($y = &singleval())) {
		die "hash value incomplete in $rcfile near ".substr($rc,pos($rc),20);
	    }
	    ${$v}{$x} = $y;
	    if ($rc !~ /\G\s*\,\s*/sgc) {
	        last;
	    }
        }
        if ($rc !~ /\G\s*\}\s*/sgc) {
	    die "hash reference missing closing brace in $rcfile near ".substr($rc,pos($rc),20);
	}
#        $debug && print pos($rc)."\t}";
        return $v;
    }
    if ($rc =~ /\G\s*(\$\w+)\s*/sgc) {
	if (exists $var{$1}) {
	    return $var{$1};
	}
	die "Undefined variable $1 referenced in $rcfile near ".substr($rc,pos($rc),20);
    }
    # unknown
#    $debug && print pos($rc)."\tno value\n";
    return undef;
}

sub nameinfo {
    my ($hn, $here) = @_;

    $hn =~ tr/A-Z/a-z/;
    if ($hn !~ /\.$/) {
	$hn .= '.';
    }
    if (exists $seenname{$hn}) {
	if ($verbose >= 2) {
	    $here->[1] = "$hn already seen\n";
	} else {
	    $here->[1] = '';
	}
	return;
    }
    $seenname{$hn} = 1;

#    if(!$var{'$no_abuse'}) {
#	Whois(\&abusenet, insh(\$here), "whois.abuse.net", $hn, 43);
#    }

    if(!$var{'$no_domain'}) {
        foreach my $bh (@domainbased) {
	    my ($la,$ln,$url,$expsub, $exp) = @$bh;
	    my $bgsock = $res->bgsend("$hn$la.", "A");
	    $bg{$bgsock} = [\&dbhcheck, insh(\$here), $bgsock, $bh, $hn];
	    $sel->add($bgsock);
$debug && printf STDERR "ADDED q5 %s ref %s\n", "$hn$la.", $bgsock;
	    pready(0) unless($inpready);
	}
    }
    $here->[1] = '';
}

sub asnshow {
    my (undef, $here, $bgsock, $ia) = @{$_[0]};

    foreach ($res->bgread($bgsock)->answer) {
	if ($_->type eq 'TXT') {
	    my @txt = $_->char_str_list;
	    $here->[1] = "$ia in ASN$txt[0] $txt[1]/$txt[2]\n";
	    return;
	}
    }
    $here->[1] = '';
}

#sub abusenet {
#    my ($here, $NicServ, $hn, $abusenet) = @_;
#    if ($abusenet) {
#	$abusenet =~ s/\n{2,}/\n/g;
#	if($html) {
#	    $abusenet =~ s/^(.*)$/<li><a href=\"mailto:$1\">$1<\/a>\n/mg;
#	    $here->[1] = "<a href=\"http://www.abuse.net/\">abuse.net</a>".
#		" <a href=\"mailto:$hn\@abuse.net\">addresses:</a><ul>\n".
#		"$abusenet</ul>\n";
#	} else {
#	    $abusenet =~ s/^/\t/mg;
#	    $here->[1] = "abuse.net addresses:\n$abusenet";
#	}
#    } else {
#	$here->[1] = '';
#    }
#}

sub dbhcheck {
    my (undef, $here, $bgsock, $bh, $hn) = @{$_[0]};
    my ($la,$ln,$url,$expsub, $exp) = @$bh;

    foreach ($res->bgread($bgsock)->answer) {
	if ($_->type eq 'A') {
	    my $n = $_->address;
	    my $x = insh(\$here);
	    if ($html) {
	        $x->[1] = "$hn is in <a href=\"http://$url\">$ln</a> as $n<br>\n";
	    } else {
	        $x->[1] = "$hn is in $ln as $n\n";
	    }
	    if ($expsub && $verbose >= 0) {
	        $expsub->($n, $exp, insh(\$here), $bh, $hn);
	    }
        } elsif ($verbose > 1 && $_->type ne 'CNAME') {
	    insh(\$here)->[1] = "$ln returned unexpected data type ".$_->type.$nl;
	}
    }
    $here->[1] = '';
}

sub explain_bitmask {
    my ($n,$exp,$here,$bh,$ia) = @_;
    my $s = '';

    $s .= "<ul>\n" if ($html);
    my @res = reverse(split(//,unpack('B32',pack('C4',split(/\./,$n)))));
    for (my $i=0; $i<=$#$exp; $i++) {
        if ($res[$i] && $exp->[$i] ne '') {
            $s .= "<li>" if ($html); 
    	    $s .= "\t" . $exp->[$i] . "\n";
            $s .= "</li>" if ($html); 
	}
    }
    $s .= "</ul>\n" if ($html);
    $here->[1] = $s;
}

sub explain_iterate {
    my ($ip,$exp,$here,$bh,$ia) = @_;
    my @n = split(/\./,$ip);
    my $n = $n[3];
    if ($exp->[$n]) {
        $here->[1] = "\t".$exp->[$n]."\n";
	$here->[1] = "<li>".$here->[1]."</li>\n" if ($html);
    } else {
	$here->[1] = '';
    }
}

sub explain_txt {
    my ($ip,$exp,$here,$bh,$ia) = @_;
    my ($la,$ln,$url,$expsub, $expx) = @$bh;
    my $q;
    if ($ia =~ /^(?:\d+\.){3}\d+$/) {
        $q = (join('.',reverse(split(/\./,$ia))) . '.' . $la);
    } else {
	$q = "$ia$la";
    }
    my $bgsock = $res->bgsend($q, 'TXT');
    $bg{$bgsock} = [\&etxt, $here, $bgsock, $q];
    $sel->add($bgsock);
$debug && printf STDERR "ADDED q10 %s ref %s\n", $q, $bgsock;
}

sub explain_iterate_txt {
    my ($ip,$exp,$here,$bh,$ia) = @_;
    explain_iterate($ip,$exp,insh(\$here),$bh,$ia);
    explain_txt($ip,$exp,$here,$bh,$ia);
}

sub etxt {
    my (undef, $here, $bgsock, $q) = @{$_[0]};
    if ($html) {
	my $x = insh(\$here);
	$x->[1] = "<ul>\n";
    }
    foreach ($res->bgread($bgsock)->answer) {
	if ($_->type eq 'TXT') {
	    my $x = insh(\$here);
	    if ($html) {
	        $x->[1] = "<li>".$_->rdatastr."</li>\n";
	    } else {
	    	$x->[1] = "\t".$_->rdatastr."\n";
	    }
	}
    }
    if ($html) {
	$here->[1] = "</ul>\n";
    } else {
	$here->[1] = '';
    }
    $bgsock->close;
}

sub process_rc {
    $rcfile = $_[0];
    open RCFILE, "<$rcfile" or return undef();
    $rc = "";
    pos($rc) = 0;
    while ($_ = <RCFILE>) {
	# skip comments and blank lines
	if (! /^\s*[\#\n]/) {
	    $rc .= $_;
	}
    }
    close RCFILE;
    while ($rc !~ /\G$/sgc) {
	if ($rc =~ /\G\s+/sgc) {
	    next;
	}
	# list
	if ($rc =~ /\G(\@\w+)\s*\=\s*\(\s*/sgc) {
	    my $varname = $1;
#	    $debug && print pos($rc)."\t$varname = (\n";
	    my $v = [];
	    my $x;
	    for (;;) {
		if (defined($x = &singleval())) {
		    my $qq = push @$v, $x;
#		    $debug && print "\t$qq elements total\n";
		} elsif ($rc =~ /\G(\@\w+)\s*/sgc) {
		    print "Warning: undefined array $1 referenced in $rcfile\n"
			if ((! exists $var{$1}) && ($verbose >= 0));
		    my $qq = push @$v, @{$var{$1}};
#		    $debug && print "\t$qq elements total\n";
		}
		if ($rc !~ /\G\,\s*/sgc) {
		    last;
		}
	    }
# $debug && print pos($rc)."\tchecking for );\n";
   	    if ($rc !~ /\G\)\s*\;\s*/sgc) {
		die "Mismatched ( for $varname in $rcfile near "
		    .substr($rc,pos($rc),20);
	    }
#	    $debug && print pos($rc)."\t);\t@$v\n";
	    if (! exists $var{$varname} && $verbose >= 0) {
		print STDERR "Warning: Unknown variable $varname set in $rcfile\n";
	    }
	    $var{$varname} = $v;
	    next;
	}
	# simple var
	if ($rc =~ /\G(\$\w+)\s*\=\s*/sgc) {
	    my $varname = $1;
	    my $x;
#	    $debug && print pos($rc)."\t$varname = \n";
	    if (defined($x = &singleval())) {
		if (! exists $var{$varname} && $verbose >= 0) {
		    print STDERR "Warning: Unknown variable $varname set in $rcfile\n";
		}
		$var{$varname} = $x;
		if ($rc =~ /\G\;\s*/sgc) {
		    next;
		}
		die "Missing ; after assignment to '$varname' in $rcfile near "
		    .substr($rc,pos($rc),20);
	    }
	    die "Missing value to assign to '$varname' in $rcfile near "
		.substr($rc,pos($rc),20);
	}
	# hash
	if ($rc =~ /\G(\%\w+)\s*\=\s*\(\s*/sgc) {
	    my $varname = $1;
#	    $debug && print pos($rc)."\t$varname = {\n";
	    my $v = {};
	    my $x;
	    while (defined($x = &singleval())) {
		if ($rc =~ /\G\s*\=\>\s*/sgc) {
		    my $y;
		    if (defined($y = &singleval())) {
			${$v}{$x} = $y;
	            } else {
			die "no value for hash in $rcfile near "
			    .substr($rc,pos($rc),20);
		    }
	        } else {
		    die "no value for hash in $rcfile near "
			.substr($rc,pos($rc),20);
		}
	        if ($rc !~ /\G\,\s*/sgc) {
		    last;
		}
	    }
# $debug && print pos($rc)."\tchecking for };\n";
    	    if ($rc !~ /\G\)\s*\;\s*/sgc) {
		die "Mismatched ( for $varname in $rcfile near "
		    .substr($rc,pos($rc),20);
	    }
#	    $debug && print pos($rc)."\t);\t@$v\n";
	    if (! exists $var{$varname} && $verbose >= 0) {
		print STDERR "Warning: Unknown variable $varname set in $rcfile\n";
	    }
	    $var{$varname} = $v;
	    next;
        }
        # use
        if ($rc =~ /\G\s*use\s+/sgc) {
	    my $x = &singleval();
	    if ($rc !~ /\G\s*\;\s*/sgc) {
		die "Bad use in $rcfile near ".substr($rc,pos($rc),20);
	    }
	    my @save = ($rcfile, $rc, pos($rc));
	    if (! &process_rc($x)) {
		die "Could not use $x in $save[0]";
	    }
	    my $prc;
	    ($rcfile, $rc, $prc) = @save;
	    pos($rc) = $prc;
	    next;
	}
        die "unknown syntax in $rcfile near ".substr($rc,pos($rc),20);
    }
    return 1;
}

# The following subroutines are higly modified versions of the
# GeekTools whois proxy server, version 3.1.1.
# See www.geektools.com if you want the original
#

##
## Package:   GeekTools Whois Proxy 3.1.1
## File:      proxy.pl (inetd)
## Author:    Robb Ballard <robb@centergate.com>
## Comments:  Part of the GeekTools Whois Proxy package.  See
##            the file README for more information.
##
## Copyright: CenterGate Research Group, LLC - 2001 All Rights Reserved
##
## This program is free software; you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation; either version 2 of the License, or
## (at your option) any later version.
##
## If you use this program to provide publicly available output, please
## give us some sort of credit in the results.  If you don't like the way
## the script does something, rewrite it and send us a diff instead of
## complaining.

sub IPCheck {
    my ($here, $IPQuery) = @_;
    my $Referer = "";
    my $NicServ;
    my $NicHand;
# find the whois server for this /8
    my @f = split(/\./, $IPQuery);
    if($NicServ = ${$var{'%registrys'}}{$f[0]}) {
        if ( $NicServ !~ /\./) {
	    $NicServ = "whois.$NicServ.net";
	} elsif ($NicServ eq 'whois.nic.ad.jp') {
	    $IPQuery .= '/e';
	}
    } else {
	$NicServ = 'whois.arin.net';
    }
    if ($verbose >= 0) {
	my $x = insh(\$here);
	$x->[1] = "IPQuery: $IPQuery Server: $NicServ$nl";
    }
    Whois(\&ipqr, $here, $NicServ, $IPQuery, 43);
}

sub ipqr {
    my ($here, $NicServ, $IPQuery, $Result) = @_;
    if (my $refa = ${$var{'%refer'}}{$NicServ}) {
	foreach my $rf (@$refa) {
	    my $p = ${$rf}[0];
	    if ($Result =~ /$p/s) {
		$NicServ = ${$rf}[1];
		if ($NicServ !~ /\./) {
		    $NicServ = "whois.$NicServ.net";
		}
		my $q;
		if ($#$rf > 2) {
		    $q = ${$rf}[2].$IPQuery.${$rf}[3];
		} else {
		    $q = $IPQuery;
		}
		if ($verbose >= -1) {
		    my $x = insh(\$here);
		    $x->[1] = "Referering Data:$nl" . ZapTrash($Result) .
			"\nNext Server:$nl";
		    if ($verbose >= 0) {
		        my $x = insh(\$here);
		        $x->[1] = "IPQuery: $q Server: $NicServ$nl";
		    }
		}
    		Whois(\&ipqr, $here, $NicServ, $q, 43);
		return;
	    }
        }
    }
## rwhois servers are taken care of here.
    if ($Result =~ /[\s\*](rwhois\.[a-z0-9\-\.]+\.(?:net|com|org|edu|gov|mil|int|[a-z]{2}))\s/is) {
	my $q = $1;
	if ($verbose >= -1) {
	    my $x = insh(\$here);
	    $x->[1] = "Referring data:$nl" . &ZapTrash($Result) .
		"\nRwhois server data:$nl";
	    if ($verbose > 0) {
		my $x = insh(\$here);
		$x->[1] = "IPQuery: $IPQuery Server: $1:4321$nl";
	    }
	}
	&Whois(\&ipqp, $here, $q, $IPQuery, 4321);
	return;
    }
# if there are multiple NET or NETBLK nic handles, look up the first or all
    if ($var{'$expand_handles'} >= 0) {
	my @nichands = ($Result =~ /\((NET[A-Z0-9\-]+)\)/sg);
	if (scalar (@nichands) > 1) {
	    foreach my $e (($var{'$expand_handles'}>0) ? @nichands
    			: $nichands[0]) {
		if ($verbose >= -1) {
		    my $x = insh(\$here);
		    $x->[1] = "Refering data:$nl" . &ZapTrash($Result) .
    		        "\nNic Handle Info:$nl";
		    if ($verbose > 0) {
			my $x = insh(\$here);
		        $x->[1] = "IPQuery: !$e Server: $NicServ$nl";
		    }
	        }
	        Whois(\&ipqp, insh(\$here), $NicServ, "!$e", 43);
	    }
        }
        $here->[1] = &ZapTrash($Result);
    }
}

sub ipqp {
    my ($here, $NicServ, $IPQuery, $Result) = @_;
    $here->[1] = ZapTrash($Result);
}

sub Whois {
    my ($action, $here, $NicServ, $MyQuery, $Port) = @_;

    if (exists $nsa{$NicServ}) {
        openwhosock($action, $here, $nsa{$NicServ}, $NicServ, $MyQuery, $Port);
    } else {
	my $bgsock = $res->bgsend($NicServ, 'A');
	$bg{$bgsock} = [\&whonic, $here, $bgsock, $action, $NicServ, $MyQuery, $Port];
	$sel->add($bgsock);
$debug && printf STDERR "ADDED q6 %s ref %s\n", $NicServ, $bgsock;
    }
}

sub whonic {
    my (undef, $here, $bgsock, $action, $NicServ, $MyQuery, $Port) = @{$_[0]};
    my $found = 0;
    foreach ($res->bgread($bgsock)->answer) {
        if ($_->type eq 'A') {
	    my $ns = $_->address;
	    $nsa{$NicServ} = $ns;
	    openwhosock($action, $here, $ns, $NicServ, $MyQuery, $Port);
	    $found = 1;
	    last;
	}
    }
    if (! $found) {
	$here->[1] = "Could not find address of $NicServ\n";
    }
    $bgsock->close;
}

sub openwhosock {
    my ($action, $here, $ns, $NicServ, $MyQuery, $Port) = @_;
    my $Remote;

    $Remote = IO::Socket::INET->new(
		Proto           => 'tcp',
                PeerAddr        => $ns,
                PeerPort        => $Port,
                Timeout         => $var{'$whoistimeout'},
		Blocking	=> 0,
                );

    if (!$Remote) {
	$here->[1] = "Unable to connect to the specified registry $NicServ.";
	return;
    }
    $Remote->autoflush();
    $bge{$Remote} = [\&whoerr, $here, $Remote, $NicServ];
    $sele->add($Remote);
$debug && printf STDERR "ADDED q7e %s ref %s\n", $MyQuery, $Remote;
    $bgw{$Remote} = [\&whoquery, $here, $Remote, $action, $NicServ, $MyQuery, ''];
    $selw->add($Remote);
$debug && printf STDERR "ADDED q7w %s ref %s\n", $MyQuery, $Remote;
}

sub whoerr {
    my (undef, $here, $Remote, $NicServ) = @{$_[0]};
    $here->[1] = "Error from registry $NicServ";
    if (exists $bgw{$Remote}) {
	$selw->remove($Remote);
	delete $bgw{$Remote};
    }
    if (exists $bg{$Remote}) {
	$sel->remove($Remote);
	delete $bg{$Remote};
    }
    close $Remote;
}

sub whoquery {
    my $qref = $_[0];
    my $Remote = $qref->[2];
    my $MyQuery = $qref->[5];
    print $Remote "$MyQuery\r\n";
    $qref->[0] = \&whoread;
    $bg{$Remote} = $qref;
    $sel->add($Remote);
$debug && printf STDERR "ADDED q8 %s ref %s\n", $MyQuery, $Remote;
}

sub whoread {
    my $qref = $_[0];
    my $Remote = $qref->[2];
    my $eof = 0;
    if (eof $Remote) {
	$eof = 1;
    } else {
        my $r;
        read $Remote, $r, 65536;
        $qref->[6] .= $r;
    }
    if ($eof || eof $Remote) {
        my (undef, $here, $Remote, $action, $NicServ, $MyQuery, $r) = @$qref;
	$sele->remove($Remote);
	delete $bge{$Remote};
    	close $Remote;
    	$r =~ s/\r//g;
    	$action->($here, $NicServ, $MyQuery, $r);
    } else {
	$bg{$Remote} = $qref;
	$sel->add($Remote);
$debug && printf STDERR "ADDED q9 %s ref %s\n", $qref->[5], $Remote;
    }
}

sub ZapTrash {
    ## Gets rid of the very annoying banners and other stuff.
    my $answer = $_[0];
    $answer =~ s/$whoismltrash//xiosg;
    $answer =~ s/$whoistrash//xiomg;
    $answer =~ s/\n{3,}/\n\n/sg;
    $answer =~ s/^\n+//s;
    $answer =~ s/\n{2,}$/\n/s;
    if ($html) {
	$answer =~ s/&/&amp;/sg;
	$answer =~ s/</&lt;/sg;
	$answer =~ s/>/&gt;/sg;
	$answer = "<pre>\n" . $answer . "</pre>\n";
    }
    return $answer;
}
