#!/usr/bin/perl -Tw
#
# BW whois
#
# Copyright (c) 1999-2006 William E. Weinman
# http://whois.bw.org/
#
# Designed to work with the new-mangled whois system introduced 1 Dec 1999.
#
# Under the new domain-name regime the whois system is now distributed 
# amongst the various domain-police^H^H^H^H^H^H^H^H^H^H registrars, thereby 
# requiring that we make at least two separate requests (to two separate 
# servers) for each whois record. 
#
# This program will first go to the "root" whois server and ask for a record. 
# If found, the root server will tell us where to go get the actual record, and 
# then we go get it. 
#
# This program is free software. You may modify and distribute it under 
# the same terms as perl itself. 
#
# See HISTORY file. 
# Documentation in (man format) whois.1 and (plaintext format) whois.txt
#

require 5.006_00;   # must use a modern perl
use strict;
use IO::File;
use IO::Socket;
use Getopt::Long;
use Fcntl ':flock';

our $VERSION = "5.0";

# the location (full path) for various optional files
our $whois_conf_default = "/etc/bw-whois/whois.conf";
our $tld_conf           = "/etc/bw-whois/tld.conf";
our $sd_conf            = "/etc/bw-whois/sd.conf";

# where to find bwInclude.pm if you need it
# use lib "/path/to/directory";

### no need to modify anything below here ### 

use subs qw{ _print error message TRUE FALSE };

sub TRUE { 1 } sub FALSE { '' }

# check for modules at runtime
# think of this as a conditional "use ..."
BEGIN {
  $E::errno_okay = 0;
  if(eval "require Errno") {
    Errno->import();
    $E::errno_okay = 1;
    }
  $E::dbi_okay = 0;
  if(eval "require DBI") {
    $E::dbi_okay = 1;
    }
  $E::cgi_okay = 0;
  if(eval "require CGI") {
    $E::cgi_okay = 1;
    }
  $E::bwInclude_okay = 0;
  if(eval "require bwInclude") {
    $E::bwInclude_okay = 1;
    }
  }

our $cgimode = $ENV{REQUEST_URI} || $ENV{SCRIPT_NAME} || FALSE;
$cgimode = FALSE if(grep { $_ eq '--nocgi' } @ARGV);
$cgimode =~ s/\?.*// if $cgimode;  # lose any query part

our $version = $VERSION;
our $_c = $cgimode ? '&copy;' : 'Copyright';
our $copyright = "$_c 1999-2006 William E. Weinman";
our $progname = $cgimode ? '<a href="http://whois.bw.org/">BW whois</a>' : 'BW whois' ;
our $byline = $cgimode ? '<a href="http://whois.bw.org/">Bill Weinman</a>' : 'Bill Weinman (http://whois.bw.org/)';
our $banner = $cgimode ? "$progname $version by $byline\n$copyright\n\n" 
  : "$progname $version by $byline\n$copyright\n";

our $RWHOIS_PORT = 4321;
our $WHOIS_PORT = 43;
our $http_header_sent = FALSE;
our $default_timeout = 60;
our $newline = "\x0d\x0a";

our $default_host = 'whois.crsnic.net';      # more reliable than whois.internic.net
our $netblk_host  = 'whois.arin.net';        # default host for netblocks
our $portname = FALSE;
our $protoname = 'tcp';

# the text to test against for the end of a header with -s
our $headerstop = q{agree to (abide|these terms)};

our $g = {};
our $q = '';
our $cgi;

++ $|;

init();  # initialize variables etc.

# need the config option here, get the rest of them later
Getopt::Long::Configure('pass_through');
GetOptions( "config=s" => \$g->{whois_conf_switch} ); 
parse_conf();

if($g->{cgimode}) { 
  error("CGI.pm is required for CGI mode.") unless $E::cgi_okay;
  $q = CGI::Vars();
  do_cgi();
  exit 0;
  }

else {
  Getopt::Long::Configure('no_pass_through');
  GetOptions(
    "host=s" => \$g->{phost}, 
    "h=s" => \$g->{phost}, 
    "default_host=s" => \$default_host, 
    "port=s" => \$portname, 
    "tld=s" => \$tld_conf,
    "stripdisclaimer!" => \$g->{stripdisclaimer}, 
    "makehtml!" => \$g->{makehtml}, 
    "q|quiet!" => \$g->{quiet},
    "v|verbose!" => \$g->{verbose},
    "r|refresh!" => \$g->{refresh_cache},
    "html!" => \$g->{htmlmode},
    "help!" => \$g->{help},
    "jpokay!" => \$g->{jpokay},
    "version!" => \$g->{versionflag},
    "timeout=i" => \$g->{timeout},
    "cgi!" => \$g->{cgimode}
    ) or usage();

  $g->{cgimode} = FALSE if $g->{cgimode};
  do_commandline(@ARGV);
  exit 0;
  }


# necessary initializations for reentrant code
# (e.g. mod_perl)
sub init
{
$q = '';
$g = {};
$cgi = new CGI if $E::cgi_okay;
$g = { 
  whois_conf => $whois_conf_default,
  cgimode => $cgimode,
  SELF => $cgimode,
  outstr => '',
  session_class => 'session',
  ip_class => 'ip_control',
  timeout => $default_timeout,
  cache_expire => 432000,  # five days of seconds
  cookie_expire => 3600,   # cookies last one hour
  ip_expire => 86400,      # IPs last one day
  re_notfound => 'not?(thing)?\s.*(match|entr(ies|y)|found)',
  error_docs => { }
  };
}

sub do_cgi
{
my $domain = $q->{domain} || $q->{keywords} || '';
my $h = '';
my $_ct = 'text/html';
$g->{link_host} = '';

if($g->{control_table}) {
  error "Cannot use control_table without database\n" unless $g->{database};
  init_dbi();
  }

if($g->{cookie_name}) {
  error "Cannot use cookie_name without control_table\n" unless $g->{control_table};
  clean_cookie();  # expire old cookies
  new_cookie(); # always create a new cookie;
  }

if($g->{ip_control}) {
  error "Cannot use ip_control without control_table\n" unless $g->{control_table};
  clean_ip();   # expire old IPs
  }

if($domain) { 
  loggit("cgi domain: $domain", 1);
  $g->{rc_referer} = check_referer();
  $g->{rc_cookie} = check_cookie() if $g->{cookie_name};
  $g->{rc_ip} = check_ip() if $g->{ip_control};
  $g->{control_okay} = FALSE;

  loggit("session in: $g->{cookie_in}", 5) if $g->{cookie_in};
  loggit("session out: $g->{cookie_out}", 5) if $g->{cookie_out};

  # check no_referer condition
  if($g->{direct_link} and $g->{rc_referer} =~ /^(no|allowed)_referer$/) {

    # condition: been here but interval okay
    if($g->{ip_interval} and ($g->{ip_interval} > $g->{direct_link})) {
      $g->{control_okay} = TRUE;
      }

    # IP not in our database of recent visitors
    elsif(!defined($g->{ip_interval})) { 
      $g->{control_okay} = TRUE;
      }

    # no referer and no exception
    else {
      loggit("refused: no referer", 1);
      debug_message('no or bad referer and no exception');
      error('Forbidden', 403, 'Forbidden'); 
      }
    }

  # check for allowable referer
  elsif(!$g->{control_okay} and $g->{rc_referer} and $g->{rc_referer} =~ /^(no|bad)_referer$/) {
    loggit("refused: $1 referer", 1);
    debug_message("rc_referer: $g->{rc_referer}");
    error('Forbidden', 403, 'Forbidden')
    }

  # check for overused IP address
  elsif(!$g->{control_okay} and $g->{rc_ip} and $g->{rc_ip} ne 'okay') {
    loggit("refused: $g->{rc_ip}", 1);
    debug_message("rc_ip: $g->{rc_ip}");
    error('Forbidden', 403, 'Forbidden')
    }

  # check for expired cookie
  elsif(!$g->{control_okay} and $g->{rc_cookie} and $g->{rc_cookie} ne 'okay') {
    if($g->{rc_cookie} eq 'no_cookie') {
      loggit("refused: no session cookie", 1);
      debug_message("rc_cookie: $g->{rc_cookie}");
      error('Forbidden', 403, 'Forbidden') 
      }
    else { 
      loggit("refused: expired session", 1);
      debug_message("rc_cookie: $g->{rc_cookie}");
      error('Session Expired', 408, 'Session Expired'); 
      }
    }

  # get the data
  whois($domain)
  };

$g->{outstr} = $banner . $g->{outstr}; 

if($domain) {
  if($g->{htmlnotfound} and $g->{outstr} =~ /$g->{re_notfound}/ig) {
    $g->{dispfile} = $g->{htmlnotfound};
    }
  else {
    $g->{dispfile} = $g->{htmlfound} || $g->{htmlfile};
    }
  }
else {
  $g->{dispfile} = $g->{htmlfirst} || $g->{htmlfile};
  }

if($g->{dispfile}) {
  error "$g->{dispfile}: $!" unless -f $g->{dispfile};
  if ($E::bwInclude_okay) {
    # create the appropriate variables in the bwInclude namespace
    bwInclude->var('SELF', $g->{SELF});
    bwInclude->var('DOMAIN', $domain);
    bwInclude->var('RESULT', $g->{outstr});

    $h .= bwInclude->spf($g->{dispfile});
    }
  else {
    my $hh = new IO::File "< $g->{dispfile}";
    error "cannot open $g->{dispfile}: $!\n" unless defined $hh;
    while(<$hh>) { $h .= $_ }
    $hh->close;

    # replace the variables
    $h =~ s/\$SELF\$/$g->{SELF}/gs;
    $h =~ s/\$DOMAIN\$/$domain/gs;
    $h =~ s/\$RESULT\$/$g->{outstr}/gs;
    }
  }
else { 
  $h = defaulthtml();
  $h =~ s/\$SELF\$/$g->{SELF}/gs;
  $h =~ s/\$DOMAIN\$/$domain/gs;
  $h =~ s/\$RESULT\$/$g->{outstr}/gs;
  }

cgi_header($_ct);
print $h;
}

sub do_commandline
{
usage() if $g->{help};
version() if $g->{versionflag};

if($g->{makehtml}) { 
  print defaulthtml();
  exit;
  }

usage() unless @_;

# signon
_print $banner unless $g->{quiet};

message "timeout is $g->{timeout}\n" if ($g->{timeout} != $default_timeout);

while(my $domain = shift) { 
  loggit("commandline domain: $domain", 1);
  whois($domain);
  }
}

sub cgi_header
{
return if $http_header_sent;
my $ct = shift || 'text/html';
my $status_code = shift || '';
my $status_text = shift || '';
$status_code .= " $status_text" if $status_code and $status_text;
my $nl = "\x0d\x0a";
my $h = '';
my $modperl = $ENV{MOD_PERL};

loggit("Status: $status_code", 9) if $status_code;
loggit("Set-Cookie: $g->{cookie_header}", 9) if $g->{cookie_header};
loggit("Content-type: $ct", 9);

if($modperl and !$ENV{PERL_SEND_HEADER}) {
  my $r = Apache->request;
  if($status_text) {
    $r->status_line($status_code);
    }
  elsif($status_code) {
    $r->status($status_code);
    }
  $r->header_out('Set-Cookie' => $g->{cookie_header}) if $g->{cookie_header};
  $r->send_http_header($ct);
  }
else {
  $h .= "Status: $status_code$nl" if $status_code;
  $h .= "Set-Cookie: $g->{cookie_header}$nl" if $g->{cookie_header};
  $h .= "Content-type: $ct$nl$nl";
  print $h;
  }

$http_header_sent = TRUE;
}

sub whois
{
my $domain = shift;
my $tld = '';
my $r_host = $g->{phost} || '';
my $r_port = $portname;
my $netblock = FALSE;
my $r_default_host = $default_host;

$r_port = ($r_host =~ /rwhois/) ? $RWHOIS_PORT : $WHOIS_PORT unless $r_port;

# '.' is the root domain
# but it is not recognized by most whois servers
# trim the trailing dot if found ... 
$domain =~ s/\.+$//;

# support for the <request>@<domain>:<port> syntax ...
($domain, $r_host) = split(/\@/, $domain, 2) unless $r_host;
($r_host, $r_port) = split(/:/, $r_host, 2) if $r_host;

# trim leading and trailing whitespace from the query
$domain =~ s/^\s+//;
$domain =~ s/\s+$//;

# is it a packed IP address? 
if($domain =~ /^(\d+)$/ and $1 > 16777215 ) {    # all numeric is a packed IP address
  $domain = unpackip($domain);
  }

_print "Request: $domain\n" unless $g->{quiet};

# is it a netnum or NETBLK? try ARIN first
if(!$r_host and ($domain =~ /^(\d{1,3}\.?){1,4}$/ or $domain =~ /^net(blk)?-[a-z0-9\-]+$/i)) {
  $r_default_host = $netblk_host;
  message "using netblock server $netblk_host\n";
  $netblock = TRUE;
  }

my @rc = ();
my $subrec = '';

# do we need a different default server?
if(!$r_host and ($r_default_host ne $netblk_host)) {
  if($tld_conf and -f $tld_conf) {
    my $tld_host = find_tld($domain);
    $r_default_host = $tld_host if $tld_host;
    } 
  }

# Go Fishin' at the default host ... 
unless($r_host) {
  $r_host = FALSE;

  @rc = whois_fetch($r_default_host, $domain, $r_port);

  if($netblock) {    # is the netblk delegated ?
    foreach (@rc) {
      next if /(nic\.mil|internic\.net|crsnic\.net)/;
      if(/(r?whois\.[\-\.a-z0-9]+)/i and !$r_host) {
        $r_host = $1;
        $r_port = $RWHOIS_PORT if /rwhois/;   # default to the correct port # for rwhois
        } 
      if(/\bport\s+(\d+)/i) { $r_port = $1; }
      }
    }

  else {  # we are at the root whois server ... find the delegation
    unless(grep { /Server Name:/i } @rc){                      # bail if it's a nameserver
      grep { /Whois Server:\s*(\S*)/i and $r_host = $1 } @rc;   # look for the referral
      }
    }
  }

# now we know where to look -- let's go get it
if($r_host) {
  display_buffer(@rc) if $g->{verbose};
  $r_port = $portname unless $r_port;
  @rc = whois_fetch($r_host, $domain, $r_port);
  grep {/\((.*-DOM)\).*$domain$/i and $subrec = $1 } @rc;
  }

# do we have a sub rec? If so, "Fetch!"
if($subrec) {
  display_buffer(@rc) if $g->{verbose};
  message "found a reference to $subrec ... requesting full record ...\n";
  @rc = whois_fetch($r_host, $subrec, $r_port);
  }

# tell 'em what we found ...
message "Registrar: $r_host\n" if (@rc && $r_host);

display_buffer(@rc);
}

sub display_buffer
{
while(@_) {
  my $l = shift;
  if($g->{in_disclaimer}) {
    $g->{in_disclaimer} = in_disclaimer($l);
    }
  else {
    _print $l unless $g->{stripdisclaimer} && in_disclaimer($l);
    }
  }
}

sub in_disclaimer
{
my $l = shift;
my $host = $g->{this_host};
find_disclaimer() unless ($g->{sd_conf_done} and lc $g->{sd_conf_done} eq lc $host);
return FALSE unless ($g->{this_sd}[0] and lc $g->{this_sd}[0] eq lc $host);
return $g->{in_disclaimer} = TRUE if(($l =~ /$g->{this_sd}[1]/) and !$g->{in_disclaimer});
return $g->{in_disclaimer} = FALSE if(($l =~ /$g->{this_sd}[2]/) and $g->{in_disclaimer});
return $g->{in_disclaimer};
}

sub whois_fetch
{
my $w_host = shift;
my $domain = shift;
my $port = shift || $WHOIS_PORT;
my $pf = '';   # prefix command for some whois servers
my ($uri, $handle);
my @rc;

if($g->{cache_table}) {
  error "Cannot use cache_table without database\n" unless $g->{database};
  init_dbi();
  }

my @db_params = ($domain, $w_host, $port);
if(check_cache(@db_params)) {
  loggit("retreived $domain from cache of [$w_host:$port]", 3);
  return splitlines($g->{result});
  }

if($g->{outgoing_ip}) {
  my $n = scalar(@{$g->{outgoing_ip}});
  my $a;
  if($n == 1) {
    $a = $g->{outgoing_ip}[0];
    }
  elsif($n > 1) {
    $a = $g->{outgoing_ip}[int(rand() * $n)];
    }
  if($a) {
    if($a =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/i) { $g->{LocalAddr} = $1; }
    else { error "Invalid outgoing IP address ($a)\n" }
    message "outgoing IP: $g->{LocalAddr}\n" if $g->{LocalAddr};
    }
  }

# this untaint is necessary for -T
if($w_host =~ /^([-a-z0-9_.]+)$/i) { $w_host = $1; }
else { error "Invalid registry hostname ($w_host)\n" }

# reset flags for new host
$g->{this_host} = $w_host;
$g->{in_disclaimer} = FALSE;

my $rs = IO::Socket::INET->new(
    PeerAddr  => $w_host,
    PeerPort  => $port,
    Proto     => $protoname,
    Timeout   => $g->{timeout},
    LocalAddr => $g->{LocalAddr}
  );

# trouble connecting ?
unless($rs) {
  my $errno = 0 + $!;
  if($E::errno_okay) {
    _print $!{EINVAL} 
      ? "host $w_host not found\n" 
      : "unable to connect to $w_host ($errno: $!)\n";
    }
  else { 
    _print "unable to connect to $w_host ($errno)\n"; 
    }
   return;
  }

my $IP = $rs->peerhost; 
my $PORTNUM = $rs->peerport;
_print "connected to $w_host [$IP:$PORTNUM] ... \n" unless $g->{quiet};
$rs->autoflush(1);

loggit("request $domain from $w_host [$IP:$PORTNUM]", 2);

# if it's a valid 2nd-level domain name, treat it as one. 
$g->{dl2} = FALSE;
if($domain =~ /^[a-z\d\-]+\.[a-z\d\-]+$/) {
  $g->{dl2} = TRUE;
  }

# special cases ... 
if($g->{dl2} && $w_host eq $default_host) { $pf = 'domain '; }

# .de whois requires '-T dn' before the domain name
if($w_host eq 'whois.denic.de') { $pf = '-T dn '; }

# .jp whois requires '/e' after domain name, use jpokay flag
if(!$g->{jpokay} and $w_host =~ /\.jp$/) { $domain .= '/e'; }

$rs->print("$pf$domain$newline");

# blocking timeout for servers who accept but don't answer
eval {
  local $SIG{ALRM} = sub { die "timeout\n" };
  alarm $g->{timeout};

  while(<$rs>) { 
    push @rc, $_;
    }

  alarm 0;
  };

# report a blocking timeout 
if($@ eq "timeout\n") {
  _print "Timeout waiting for response.\n" unless $g->{quiet};
  }
elsif($@ =~ /alarm.*unimplemented/) { # no signals on Win32
  while(<$rs>) { 
    push @rc, $_;
    }
  }

$g->{link_host} = $w_host;

write_cache(@db_params, @rc);
return @rc;
}

sub check_referer
{
my $r = $ENV{HTTP_REFERER} || '';
$r =~ m|https?://(.*?)[:/]|; # ensure a valid referer, and get the host part only
$r = $1 || '';
my $_okay = FALSE;

return 'okay' if ($g->{allow_referer} and $g->{allow_referer} eq '*');

# no or poorly-formed referer
return 'no_referer' unless $r;

my $self_host = $ENV{HTTP_HOST} || '';
$self_host = $1 if $self_host =~ m|(.*?):|;  # lose the port part if nec.

$_okay = TRUE if $r eq $self_host;

if(! $_okay and $g->{allow_referer}) {
  my @allow_referer = split(/:/, $g->{allow_referer});
  $_okay = grep { $r eq $_ } @allow_referer;
  loggit("checking allow_referer r: $r (" . join(", ", @allow_referer) . ") \[${_okay}\]", 9);
  return 'allowed_referer' if $_okay;
  }

return 'bad_referer' unless $_okay;
return 'okay';
}

#### SQL support ####

### cache table support ###

# cleanup old cache entries
sub clean_cache
{
return FALSE unless $g->{dbh};  # no db
return FALSE unless $g->{cache_table};  # no cache table

my $db_query = $g->{database} eq 'mysql' ?
  qq|
    DELETE FROM $g->{cache_table} 
    WHERE (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp)) > ?
    | :
  qq|
    DELETE FROM $g->{cache_table} 
    WHERE EXTRACT(EPOCH FROM NOW() - stamp) > ?
    |;
    
$g->{dbh}->do($db_query, undef, $g->{cache_expire}) or error "clean_cache: $DBI::errstr\n";
}

sub check_cache
{
return FALSE unless $g->{dbh};  # no cache db

clean_cache();

my $domain = shift or return FALSE;
my $c_host = shift || $default_host;
my $port = shift || $WHOIS_PORT;
my $domain_select = lc "${domain}\@${c_host}:${port}";

if($g->{refresh_cache}) {
  $g->{dbh}->do( qq|
    DELETE FROM $g->{cache_table} WHERE query = ?
    |, undef, $domain_select) or error "cache_refresh: $DBI::errstr\n";
  return FALSE;
  }
else {
  # is it cached? 
  my $db_query = $g->{database} eq 'mysql' ? 
    qq| SELECT value, UNIX_TIMESTAMP(stamp) FROM $g->{cache_table} WHERE query = ? | :
    qq| SELECT value, EXTRACT(EPOCH FROM stamp)::INT FROM $g->{cache_table} WHERE query = ? | ;
  my ($v, $t) = $g->{dbh}->selectrow_array($db_query, undef, $domain_select) or return FALSE;

  # find the delta time
  my $dt = time - $t;
  my $ts = gmtime($t);

  # report that we have a hit
  if($g->{verbose}) { _print "from $c_host:$port [cached $ts UTC ($dt ticks ago)]\n"; }
  elsif(!$g->{quiet}) { _print "from $c_host:$port [cached $ts UTC]\n";; }

  # store the result
  $g->{link_host} = "${c_host}:${port}";
  $g->{result} = $v;

  # reset flags for new host
  $g->{this_host} = $c_host;
  $g->{in_disclaimer} = FALSE;

  return TRUE;
  }
}

# write a result in the cache database
sub write_cache
{
return unless $g->{dbh};  # no cache db

my $domain = shift or return FALSE;
my $c_host = shift || $default_host;
my $port = shift || $WHOIS_PORT;

# build a results string
my $r = '';
while(@_) {
  $r .= shift;
  }

return unless $r;  # don't cache empty results

# store the string in the databse
$g->{dbh}->do( qq|
  INSERT INTO $g->{cache_table} (query, value) VALUES (?, ?)
  |, undef, lc "${domain}\@${c_host}:${port}", $r)
  or error "write_cache: $DBI::errstr\n";
}

### cookie table support ###

# cleanup old cookie entries
sub clean_cookie
{
return FALSE unless $g->{dbh};  # no db
return FALSE unless $g->{control_table};  # no cookie table

my $db_query = $g->{database} eq 'mysql' ? 
  qq|
    DELETE FROM $g->{control_table} 
    WHERE class = ? and (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp)) > ?
    | :
  qq|
    DELETE FROM $g->{control_table} 
    WHERE class = ? and EXTRACT(EPOCH FROM NOW() - stamp) > ? 
    |;

$g->{dbh}->do($db_query, undef, $g->{session_class}, $g->{cookie_expire}) or error "clean_cookie: $DBI::errstr\n";
}

# check for an existing cookie
sub check_cookie
{
init_dbi() unless $g->{dbh};
error "Cannot use cookie_name without database\n" unless $g->{dbh};
unless ($g->{cookie_in} = $cgi->cookie($g->{cookie_name})) {
  return 'no_cookie';
  }

my $v = $g->{dbh}->selectrow_array( qq|
  SELECT id FROM $g->{control_table} WHERE id = ? AND class = ?
  |, undef, $g->{cookie_in}, $g->{session_class});

if($v) {
  # don't reuse a cookie
  $g->{dbh}->do( qq|
    DELETE FROM $g->{control_table} 
    WHERE id = ? AND class = ?
    |, undef, $g->{cookie_in}, $g->{session_class}) or error "check_cookie[DELETE]: $DBI::errstr\n";
    }
else { 
  return 'expired_cookie';
  }
return 'okay';
}

# create a new cookie
sub new_cookie
{
return unless $g->{dbh};

# A session ID is a simple string of pseudo-random digits. 
# It shouldn't need to be too sophisticated
foreach ( 1 .. 8 ) { $g->{cookie_out} .= sprintf("%4.4x", int(rand(0xffff))) }

$g->{dbh}->do( qq|
  INSERT INTO $g->{control_table} (id, class, count) VALUES (?, ?, 0)
  |, undef, $g->{cookie_out}, $g->{session_class})
  or error "new_cookie: $DBI::errstr\n";

$g->{cookie_header} = $cgi->cookie( -name => $g->{cookie_name}, -value => $g->{cookie_out} );
}

### ip table support ###

# cleanup old ip entries
sub clean_ip
{
return FALSE unless $g->{dbh};  # no db
return FALSE unless $g->{control_table};  # no control table

my $db_query = $g->{database} eq 'mysql' ? 
  qq|
    DELETE FROM $g->{control_table} 
    WHERE class = ? and (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp)) > ?
    | :
  qq|
    DELETE FROM $g->{control_table} 
    WHERE class = ? and EXTRACT(EPOCH FROM NOW() - stamp) > ?
    |;

$g->{dbh}->do($db_query, undef, $g->{ip_class}, $g->{ip_expire}) or error "clean_ip: $DBI::errstr\n";
}

# check for an existing cookie
sub check_ip
{
init_dbi() unless $g->{dbh};
error 'Cannot use ip_control without database' unless $g->{dbh};  # no db
$g->{ip_this} = $ENV{REMOTE_ADDR} or error 'Cannot use ip_control without server REMOTE_ADDR support.';

my $db_query = $g->{database} eq 'mysql' ? 
  qq|
    SELECT id, count, (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp))
    FROM $g->{control_table} WHERE id = ? AND class = ?
    | :
  qq|
    SELECT id, count, EXTRACT(EPOCH FROM NOW() - stamp)
    FROM $g->{control_table} WHERE id = ? AND class = ?
    |;

my ($v, $n, $t) = $g->{dbh}->selectrow_array($db_query, undef, $g->{ip_this}, $g->{ip_class});

if($v) {
  $g->{ip_interval} = $t;
  $n++;
  $g->{dbh}->do( qq|
    UPDATE $g->{control_table} 
    SET count = ?
    WHERE class = ? and id = ? 
    |, undef, $n, $g->{ip_class}, $g->{ip_this}) or error "check_ip[update]: $DBI::errstr\n";

  return "IP count ($n) over limit" if $n > $g->{ip_control};
  }
else { 
  $g->{dbh}->do( qq|
    INSERT INTO $g->{control_table} (id, class, count) VALUES (?, ?, 1)
    |, undef, $g->{ip_this}, $g->{ip_class}) or error "check_ip[insert]: $DBI::errstr\n";
  }
return 'okay';
}

### general SQL support ###

# normalized for modern DBI by wew 2003-07-17
sub init_dbi
{
return if $g->{dbh};  # don't re-init
return unless $g->{database};

my $dbxlat = {
  mysql => 'mysql',
  pgsql => 'Pg'
  };

my $db_module = $dbxlat->{lc $g->{database}} or error "unsupported database $g->{database}\n";
error "DBI and DBD::$db_module are required for this operation.\n" unless $E::dbi_okay;

$g->{dbc} = {};
my $dbc = $g->{dbc};

($dbc->{db}, $dbc->{host}, $dbc->{port}, $dbc->{user}, $dbc->{pass}) =
  split(/:/, $g->{connect});
my $dsn = "DBI:$db_module:dbname=$dbc->{db}";
$dsn .= ";host=$dbc->{host}" if $dbc->{host};
$dsn .= ";port=$dbc->{port}" if $dbc->{port};
$g->{dbh} = DBI->connect($dsn, $dbc->{user}, $dbc->{pass}, { PrintError => 0, AutoCommit => 1 } );
error "cannot connect to database $dsn ($DBI::errstr)\n" unless $g->{dbh};
}

# disconnect from the DB when done.
# the MySQL docs say this is unnecessary 
# my experience is that I get occasional error messages if I don't
sub END
{
my $dbh = $g->{dbh} or return;
$dbh->disconnect;
}

#### utility code ####

sub version { print $banner, "\n"; exit 0 }

sub date_stamp
{
my $t = shift || time;
my $flags = shift || '';
my @months = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
my $i;
my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst);
my $zoffset = "-0000";

if($flags =~ /(gmt|utc)/) {
  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time);
  }
else {
  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time);
  my @gm = gmtime($t);
  $zoffset = sprintf("%+2.02d00", ($i = ($hour - $gm[2])) > 12 ? ($i - 24) : $i );
  }

if($flags =~ /sort/) {
  return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
    $year + 1900, $mon + 1, $mday, $hour, $min, $sec);
  }
else {
  return sprintf("%d %s %d %02d:%02d:%02d $zoffset",
    $mday, $months[$mon], $year + 1900, $hour, $min, $sec);
  }
}

sub loggit
{
return if(!$g->{logfile});
my $m = shift or return;
my $level = shift;

if($level && $g->{log_level}) {
  return unless $level <= $g->{log_level};
  }
elsif ($level) {
  return if $level > 1;
  }

my $d = date_stamp(time, 'sort utc');

unless ($g->{log_name} || $g->{progname}) {
  $0 =~ /([^\/\\]*)$/;
  $g->{progname} = $1 ? $1 : $0;
  }

my $log_name = $g->{log_name} || $g->{progname};

my $pid = $$;

my $r_ip = $ENV{REMOTE_ADDR} || '';
my $r_user = $ENV{REMOTE_USER} || '';
my $remote = '';
$remote .= "${r_user}:" if $r_user;
$remote .= "$r_ip" if $r_ip;

my $message = '';
$message .= "${d}";
$message .= " \[${pid}\]";
$message .= " ($remote)" if $remote;
$message .= " ${log_name}";
$message .= ": $m";
$message .= " (${level})" if $g->{log_level};
$message .= "\n";

# Untaint the logfile filename. It came from the config file, 
# and we just have to trust it. 
$g->{logfile} =~ /(.*)/; 
my $fn = $1;

my $fh = new IO::File(">>$fn");
error "Cannot open log $g->{logfile} ($!)" unless $fh;
flock($fh, LOCK_EX);
$fh->seek(0, SEEK_END);
$fh->print($message);
flock($fh, LOCK_UN);
$fh->close();
}

sub splitlines
{
my @r;
$_ = shift;
while($_) {
  $_ .= "\n" unless(/\x0d|\x0a/);
  s/(.*?(\x0d\x0a|\x0d|\x0a))//;
  push @r, $1;
  }
push(@r, $_) if $_;
return @r;
}

sub find_disclaimer
{
error("could not open $sd_conf (required for the stripdisclaimer feature): $!") unless -f $sd_conf;

# do we have a host?
return unless $g->{this_host};

# do we already have a result for this host? 
return if ($g->{sd_conf_done} and $g->{sd_conf_done} eq $g->{this_host});

my $hconf = new IO::File "< $sd_conf";
$g->{this_sd} = [ '', '', '' ];
while(<$hconf>) {
  next if /^#/;
  chomp;
  s/#.*//;  # lose comments
  s/^\s+//; # lose leading whitespace
  s/\s+$//; # lose trailing whitespace
  next unless $_;
  my ($h, $s, $e) = /(\S+)\s+"([^"]+)"\s+"([^"]+)"/;          
  if($h and (!$s or !$e)) { error "invalid entry in $sd_conf: $h\n" }
  if($h and lc $h eq lc $g->{this_host}) {
    $g->{this_sd} = [ $h, $s, $e ];
    }
  }
$g->{sd_conf_done} = $g->{this_host}
}

sub find_tld
{
my $domain = lc shift;
my $tld = '';
my $server = '';
my $tld_file = "$tld_conf";

return FALSE unless $tld_conf and -f $tld_file;

my $htld = new IO::File "< $tld_file";
error "can't open $tld_file ($!)\n" unless defined($htld);
while(<$htld>) {
  next if /^#/;
  chomp;
  my @tokens = split(/\s+/);
  my $lh = shift @tokens or next;
  my $rh = shift @tokens or next;
  if(substr($domain, 0 - length($lh)) eq $lh) {
    $tld = $lh;
    $server = $rh;
    _print "whois server for *$tld is $server ...\n" unless $g->{quiet};
    last;
    }
  }
$htld->close;
return $server;
}

sub opt_bool
{
return TRUE if shift =~ /^(1|true)$/i;
return FALSE;
}

sub parse_conf
{
# give feedback about the conf file if it's specified and not found
if($g->{whois_conf_switch}) {
  error "configuration file ($g->{whois_conf_switch}): $!\n" unless -f $g->{whois_conf_switch};
  $g->{whois_conf} = $g->{whois_conf_switch};
  }
elsif($ENV{WHOIS_CONF}) {
  error "configuration file (from environment variable)\n$ENV{WHOIS_CONF}: $!\n" unless -f $ENV{WHOIS_CONF};
  $g->{whois_conf} = $ENV{WHOIS_CONF};
  }
elsif(! -f $g->{whois_conf}) {
  # no override and no default file -- try for a copy in pwd
  $g->{whois_conf} =~ m|.*[\/\\](.*)|; # just the part of the filename after '/' or '\';
  my $whois_conf_pwd = $1 || '';
  return unless ($whois_conf_pwd and -f $whois_conf_pwd);
  $g->{whois_conf} = $whois_conf_pwd;
  }

my $hconf = new IO::File "< $g->{whois_conf}";
error "cannot open $g->{whois_conf}: $!\n" unless defined $hconf;

while(<$hconf>) {
  chomp;
  s/#.*//;  # lose comments
  s/^\s+//; # ... leading whitespace
  s/\s+$//; # ... trailing whitespace
  next unless $_;
  my @t = split /\s+/;
  my $tok = lc shift(@t);
 
  if(    $tok eq 'quiet')           { $g->{quiet} = opt_bool(shift(@t)) }
  elsif( $tok eq 'verbose')         { $g->{verbose} = opt_bool(shift(@t)) }
  elsif( $tok eq 'jpokay')          { $g->{jpokay} = opt_bool(shift(@t)) }
  elsif( $tok eq 'cgi_xml')         { $g->{cgi_xmlmode} = opt_bool(shift(@t)) }
  elsif( $tok eq 'stripdisclaimer') { $g->{stripdisclaimer} = opt_bool(shift(@t)) }
  elsif( $tok eq 'debug')           { $g->{debug} = opt_bool(shift(@t)) }
  elsif( $tok eq 'tld_conf')        { $tld_conf = shift(@t) }
  elsif( $tok eq 'sd_conf')         { $sd_conf = shift(@t) }
  elsif( $tok eq 'filters_conf')    { $g->{filters_conf} = shift(@t) }
  elsif( $tok eq 'logfile')         { $g->{logfile} = shift(@t) }
  elsif( $tok eq 'log_name')        { $g->{log_name} = shift(@t) }
  elsif( $tok eq 'log_level')       { $g->{log_level} = shift(@t) }
  elsif( $tok eq 'default_host')    { $default_host = shift(@t) }
  elsif( $tok eq 'htmlfile')        { $g->{htmlfile} = shift(@t) }
  elsif( $tok eq 'htmlfound')       { $g->{htmlfound} = shift(@t) }
  elsif( $tok eq 'htmlnotfound')    { $g->{htmlnotfound} = shift(@t) }
  elsif( $tok eq 'htmlfirst')       { $g->{htmlfirst} = shift(@t) }
  elsif( $tok eq 'timeout')         { $g->{timeout} = shift(@t) }
  elsif( $tok eq 'database')        { $g->{database} = shift(@t) }
  elsif( $tok eq 'connect')         { $g->{connect} = shift(@t) }
  elsif( $tok eq 'cache_table')     { $g->{cache_table} = shift(@t) }
  elsif( $tok eq 'control_table')   { $g->{control_table} = shift(@t) }
  elsif( $tok eq 'cookie_name')     { $g->{cookie_name} = shift(@t) }
  elsif( $tok eq 'cache_expire')    { $g->{cache_expire} = shift(@t) }
  elsif( $tok eq 'cookie_expire')   { $g->{cookie_expire} = shift(@t) }
  elsif( $tok eq 'ip_control')      { $g->{ip_control} = shift(@t) }
  elsif( $tok eq 'ip_expire')       { $g->{ip_expire} = shift(@t) }
  elsif( $tok eq 'allow_referer')   { $g->{allow_referer} = shift(@t) }
  elsif( $tok eq 'direct_link')     { $g->{direct_link} = shift(@t) }
  elsif( $tok eq 'error_403')       { $g->{error_docs}->{403} = shift(@t) }
  elsif( $tok eq 'error_408')       { $g->{error_docs}->{408} = shift(@t) }
  elsif( $tok eq 'outgoing_ip')     { @{$g->{outgoing_ip}} = split(/:/, shift(@t)) }

  else { error "unrecognized token in $g->{whois_conf} : $tok\n" }

  if($g->{direct_link} and !$g->{ip_control}) {
    error 'Cannot use direct_link without ip_control';
    }

  }
}

sub unpackip
{
my $packed_ip = shift;
my $n = $packed_ip;
my @an;

while ($n) {
  unshift @an, $n & 255;
  $n >>= 8;
  }

my $ip = join ".", @an;
_print "packed 32-bit IP $packed_ip => $ip\n" unless $g->{quiet};
return $ip;
}

sub defaulthtml
{
return q{<!--  

  BW whois example HTML file
  Copyright 1999-2006 William E. Weinman  http://whois.bw.org/  

  Placeholders are used for the various values which make this 
  work. These placeholders are represented by text enclosed in 
  '$' signs like this: 

    $PLACEHOLDER$

  The placeholders are: 

    SELF    The URI path of the program on your web server, taken 
            from the value of the SCRIPT_NAME environment variable. 

    DOMAIN  The domain that was last looked up, if any. 

    RESULT  The result of the whois query from BW whois. 

  See the example (below) for specific usage. 

-->

<html>
<title> BW whois &middot; Online Query </title>

<body>

<h2> <a href="http://whois.bw.org/">BW whois</a> &middot; Online Query </h2>

<p>
<form action="$SELF$" method=post>
Enter a domain name: <br>
<input type=text name=domain value="$DOMAIN$">
<input type=submit>
</form>

<p><pre>
$RESULT$
</pre></p>
</body>
</html>

<!-- end of example HTML file for BW whois -->
}
}

sub message
{
return if $g->{quiet};
_print @_ if $g->{verbose};
}

sub _print
{
my ($handle, $uri);

if($g->{htmlmode} or $g->{cgimode}) {
  # RFC-954 whois servers (e.g. whois.networksolutions.com) require the "!" 
  # to look up handles, while other whois servers (e.g. RIPE) prohibit it. 
  # I search for the double-dash option as that is often used on those servers
  $handle = ($g->{link_host} =~ /whois.networksolutions.com/) ? '%21' : '';
  $uri = $g->{SELF} || 'whois';

  while (@_) { 
    my $_outstr = shift;

    # some registrants put HTML in their records. Sheeesh!
    $_outstr =~ s/&/&amp;/g;
    $_outstr =~ s/</&lt;/g;
    $_outstr =~ s/>/&gt;/g;
    $_outstr =~ s/"/&quot;/g;

    # make a link out of a domain
    $_outstr =~ s!
      \b(
      (?:
        [a-z0-9]
        [a-z0-9-]+
        \.
      )?
      ([a-z-]{2,}\.[a-z]{2}|com|net|org|edu|int|gov|mil)
      )(?=[^a-z-.])
      !<a href="$uri?domain=$1">$1</a>!gsxi
       if ($g->{htmlmode} or $g->{cgimode});

    # make a link out of a handle
    $_outstr =~ s|
      \((                    # a handle is in parens ...
        [A-Z]                # ... is all UPPERCASE and starts with a letter
        [A-Z0-9-_]{3,}?)\)   # ... may contain digits, dashes, and underscores
      |(<a href="$uri?domain=$handle$1%40$g->{link_host}">$1</a>)|gsx
       if ($g->{htmlmode} or $g->{cgimode});

    # make a link out of an IP address
    $_outstr =~ s|
      ([\d]{1,3}\.[\d]{1,3}\.[\d]{1,3}\.[\d+]{1,3})    # only for full ip addresses
      |<a href="$uri?domain=$1%40$netblk_host">$1</a>|gsx 
        if ($g->{htmlmode} or $g->{cgimode});

    $g->{outstr} .= $_outstr;
    print $_outstr unless $g->{cgimode};
    }
  }
else { print @_ }
}

sub debug_message
{
$g->{debug_message} .= shift if $g->{debug};
}

sub error_doc
{
my $fn = shift;

if ($E::bwInclude_okay) {
  if($g->{debug_message}) {
    bwInclude->var('debug_message', $g->{debug_message});
    }
  else {
    bwInclude->var('debug_message', '');   # so it doesn't fart
    }
  bwInclude->var('SELF', $g->{SELF});
  bwInclude->pf($fn);
  }
else {
  my $fh = new IO::File("<$fn");
  print "cannot open $fn ($!)\n" unless $fh;
  while(<$fh>) { print }
  }
}

sub error
{
if($g->{cgimode}) {
  my $em = shift || 'Unknown error."';
  my $status_code = shift || '';
  my $status_text = shift if $status_code;
  if($g->{cookie_in}) {
    # client gave us a cookie, send back a blank cookie 
    # to purge the cookie from the broser
    $g->{cookie_header} = $cgi->cookie( -name => $g->{cookie_name}, -value => '')
    }
  else {  
    # client didn't give us a cookie, so don't give one back
    $g->{cookie_header} = undef;
    }
  cgi_header('text/html', $status_code, $status_text);
  if($status_code and $g->{error_docs}->{$status_code}) {
    error_doc($g->{error_docs}->{$status_code});
    }
  else {
    print qq{
      <html><head><title> BW Whois &middot; Error </title></head>
      <body bgcolor=white>
      <h1> Error </h1>\n<p><em>$em</em>
      </body></html>
      };
    }
  exit;
  }
else {
  die @_;
  }
}

sub usage
{
print $banner;
print <<USAGE;

usage: whois [options] (<request> | <request>@<host>) [ ... ]

options: 

  --help             Show this screen.

  --version          Show version information and exit. 

  --config <path>    Full path to the configuration file. 
                     Default: $whois_conf_default

  --refresh          Refresh the cache for this query. 
  -r                 This forces the request to go to the whois server
                     even if the result is cached. (Only valid if caching
                     is configured.)

  --tld <path>       Full path/file name for tld.conf file. Defaults 
                     to "/etc/bw-whois/tld.conf".

  --host <host>      Hostname of the whois server
  -h <host>          this is the same as the <request>@<host> form
                     if not specified will search $default_host
                     for a "Whois Server:" record.

  --timeout <n>      Set the timeout to a number of seconds. The default 
                     is 60 seconds. 

  --port             Specify a different port than the normal whois(43).
  -p

  --quiet            Don't print any extraneous messages. 
  -q                 (overrides --verbose)

  --verbose          Print extra messages.
  -v                 (ignored if --quiet is used)

  --stripdisclaimer  Strip off disclaimers from the results. You've 
  -s                 read it a thousand times already, right?

  --nocgi            Prevent CGI mode. For use when you have your own
                     wrapper.

  --makehtml         Display example HTML file. Prints a small 
                     file to STDOUT with the example HTML in it. 
                     Use this to modify to your own taste for CGI 
                     mode. Set htmlfile in config as needed. 

Get the latest version of BW Whois here: http://whois.bw.org/

USAGE
exit;
}

