"Fossies" - the Fresh Open Source Software Archive

Member "whois-5.5.2/whois" (8 Aug 2012, 44244 Bytes) of package /linux/privat/old/whois-5.5.2.tgz:


The requested HTML page contains a <FORM> tag that is unusable on "Fossies" in "automatic" (rendered) mode so that page is shown as HTML source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/bin/perl -T
    2 #
    3 # BW whois
    4 #
    5 # Copyright (c) 1999-2012 William E. Weinman
    6 # http://whois.bw.org/
    7 #
    8 # Designed to work with the new-mangled whois system introduced 1 Dec 1999.
    9 #
   10 # Under the new domain-name regime the whois system is now distributed 
   11 # amongst the various domain-police^H^H^H^H^H^H^H^H^H^H registrars, thereby 
   12 # requiring that we make at least two separate requests (to two separate 
   13 # servers) for each whois record. 
   14 #
   15 # This program will first go to the "root" whois server and ask for a record. 
   16 # If found, the root server will tell us where to go get the actual record, and 
   17 # then we go get it. 
   18 #
   19 # This program is free software. You may modify and distribute it under 
   20 # the same terms as perl itself. 
   21 #
   22 # See HISTORY file. 
   23 # Documentation in (man format) whois.1 and (plaintext format) whois.txt
   24 #
   25 
   26 require 5.008;    # must use a modern perl
   27 use strict;
   28 use warnings;
   29 use IO::File;
   30 use IO::Socket;
   31 use Getopt::Long;
   32 use Fcntl ':flock';
   33 
   34 our $VERSION = "5.5.2";
   35 
   36 # the location (full path) for various optional files
   37 our $whois_conf_default = "/etc/whois/whois.conf";
   38 our $tld_conf           = "/etc/whois/tld.conf";
   39 our $sd_conf            = "/etc/whois/sd.conf";
   40 
   41 # where to find bwInclude.pm if you need it
   42 # use lib "/path/to/directory";
   43 
   44 ### no need to modify anything below here ###
   45 
   46 use subs qw{ _print error message TRUE FALSE };
   47 
   48 sub TRUE  { 1 }
   49 sub FALSE { '' }
   50 
   51 # check for modules at runtime
   52 # think of this as a conditional "use ..."
   53 BEGIN {
   54     $E::errno_okay = 0;
   55     if ( eval "require Errno" ) {
   56         Errno->import();
   57         $E::errno_okay = 1;
   58     }
   59     $E::dbi_okay = 0;
   60     if ( eval "require DBI" ) {
   61         $E::dbi_okay = 1;
   62     }
   63     $E::cgi_okay = 0;
   64     if ( eval "require CGI" ) {
   65         $E::cgi_okay = 1;
   66     }
   67     $E::bwInclude_okay = 0;
   68     if ( eval "require bwInclude" ) {
   69         $E::bwInclude_okay = 1;
   70     }
   71 }
   72 
   73 our $cgimode = $ENV{REQUEST_URI} || $ENV{SCRIPT_NAME} || FALSE;
   74 $cgimode = FALSE if ( grep { $_ eq '--nocgi' } @ARGV );
   75 $cgimode =~ s/\?.*// if $cgimode;    # lose any query part
   76 
   77 our $version   = $VERSION;
   78 our $_c        = $cgimode ? '&copy;' : 'Copyright';
   79 our $copyright = "$_c 1999-2012 William E. Weinman";
   80 our $progname  = $cgimode ? '<a href="http://whois.bw.org/">BW whois</a>' : 'BW whois';
   81 our $byline    = $cgimode ? '<a href="http://bw.org/">Bill Weinman</a>' : 'Bill Weinman (http://bw.org/)';
   82 our $banner    = "$progname $version by $byline\n$copyright\n";
   83 $banner .= "\n" if $cgimode;
   84 
   85 our $RWHOIS_PORT      = 4321;
   86 our $WHOIS_PORT       = 43;
   87 our $http_header_sent = FALSE;
   88 our $default_timeout  = 60;
   89 our $newline          = "\x0d\x0a";
   90 
   91 our $default_host = 'whois.crsnic.net';    # more reliable than whois.internic.net
   92 our $netblk_host  = 'whois.arin.net';      # default host for netblocks
   93 our $portname     = FALSE;
   94 our $protoname    = 'tcp';
   95 
   96 # the text to test against for the end of a header with -s
   97 our $headerstop = q{agree to (abide|these terms)};
   98 
   99 our $g = {};
  100 our $q = '';
  101 our $cgi;
  102 
  103 ++$|;
  104 
  105 init();    # initialize variables etc.
  106 
  107 # need the config option here, get the rest of them later
  108 Getopt::Long::Configure('pass_through');
  109 GetOptions( "config=s" => \$g->{whois_conf_switch} );
  110 parse_conf();
  111 
  112 if ( $g->{cgimode} ) {
  113     error("CGI.pm is required for CGI mode.") unless $E::cgi_okay;
  114     $q = CGI::Vars();
  115     do_cgi();
  116     exit 0;
  117 } else {
  118     Getopt::Long::Configure('no_pass_through');
  119     GetOptions(
  120         "host=s"           => \$g->{phost},
  121         "h=s"              => \$g->{phost},
  122         "default_host=s"   => \$default_host,
  123         "port=s"           => \$portname,
  124         "tld=s"            => \$tld_conf,
  125         "stripdisclaimer!" => \$g->{stripdisclaimer},
  126         "makehtml!"        => \$g->{makehtml},
  127         "q|quiet!"         => \$g->{quiet},
  128         "v|verbose!"       => \$g->{verbose},
  129         "r|refresh!"       => \$g->{refresh_cache},
  130         "html!"            => \$g->{htmlmode},
  131         "help!"            => \$g->{help},
  132         "jpokay!"          => \$g->{jpokay},
  133         "version!"         => \$g->{versionflag},
  134         "timeout=i"        => \$g->{timeout},
  135         "cgi!"             => \$g->{cgimode}
  136     ) or usage();
  137 
  138     $g->{cgimode} = FALSE if $g->{cgimode};
  139     do_commandline(@ARGV);
  140     exit 0;
  141 }
  142 
  143 # necessary initializations for reentrant code
  144 # (e.g. mod_perl)
  145 sub init
  146 {
  147     $q   = '';
  148     $cgi = new CGI if $E::cgi_okay;
  149     $g   = {
  150         whois_conf    => $whois_conf_default,
  151         cgimode       => $cgimode,
  152         SELF          => $cgimode,
  153         outstr        => '',
  154         session_class => 'session',
  155         ip_class      => 'ip_control',
  156         timeout       => $default_timeout,
  157         cache_expire  => 432000,      # five days of seconds
  158         cookie_expire => 3600,        # cookies last one hour
  159         ip_expire     => 86400,       # IPs last one day
  160         re_notfound   => 'not?(thing)?\s.*(match|entr(ies|y)|found)',
  161         error_docs    => {} };
  162 }
  163 
  164 sub do_cgi
  165 {
  166     my $domain = $q->{domain} || $q->{keywords} || '';
  167     my $h      = '';
  168     my $_ct    = 'text/html';
  169     $g->{link_host} = '';
  170 
  171     if ( $g->{control_table} ) {
  172         error "Cannot use control_table without database\n" unless $g->{database};
  173         init_dbi();
  174     }
  175 
  176     if ( $g->{cookie_name} ) {
  177         error "Cannot use cookie_name without control_table\n" unless $g->{control_table};
  178         clean_cookie();    # expire old cookies
  179         new_cookie();      # always create a new cookie;
  180     }
  181 
  182     if ( $g->{ip_control} ) {
  183         error "Cannot use ip_control without control_table\n" unless $g->{control_table};
  184         clean_ip();        # expire old IPs
  185     }
  186 
  187     if ($domain) {
  188         loggit( "cgi domain: $domain", 1 );
  189         $g->{rc_referer}   = check_referer();
  190         $g->{rc_cookie}    = check_cookie() if $g->{cookie_name};
  191         $g->{rc_ip}        = check_ip() if $g->{ip_control};
  192         $g->{control_okay} = FALSE;
  193 
  194         loggit( "session in: $g->{cookie_in}",   5 ) if $g->{cookie_in};
  195         loggit( "session out: $g->{cookie_out}", 5 ) if $g->{cookie_out};
  196 
  197         # check no_referer condition
  198         if ( $g->{direct_link} and $g->{rc_referer} =~ /^(no|allowed)_referer$/ ) {
  199 
  200             # condition: been here but interval okay
  201             if ( $g->{ip_interval} and ( $g->{ip_interval} > $g->{direct_link} ) ) {
  202                 $g->{control_okay} = TRUE;
  203             }
  204 
  205             # IP not in our database of recent visitors
  206             elsif ( !defined( $g->{ip_interval} ) ) {
  207                 $g->{control_okay} = TRUE;
  208             }
  209 
  210             # no referer and no exception
  211             else {
  212                 loggit( "refused: no referer", 1 );
  213                 debug_message('no or bad referer and no exception');
  214                 error( 'Forbidden', 403, 'Forbidden' );
  215             }
  216         }
  217 
  218         # check for allowable referer
  219         elsif ( !$g->{control_okay} and $g->{rc_referer} and $g->{rc_referer} =~ /^(no|bad)_referer$/ ) {
  220             loggit( "refused: $1 referer", 1 );
  221             debug_message("rc_referer: $g->{rc_referer}");
  222             error( 'Forbidden', 403, 'Forbidden' );
  223         }
  224 
  225         # check for overused IP address
  226         elsif ( !$g->{control_okay} and $g->{rc_ip} and $g->{rc_ip} ne 'okay' ) {
  227             loggit( "refused: $g->{rc_ip}", 1 );
  228             debug_message("rc_ip: $g->{rc_ip}");
  229             error( 'Forbidden', 403, 'Forbidden' );
  230         }
  231 
  232         # check for expired cookie
  233         elsif ( !$g->{control_okay} and $g->{rc_cookie} and $g->{rc_cookie} ne 'okay' ) {
  234             if ( $g->{rc_cookie} eq 'no_cookie' ) {
  235                 loggit( "refused: no session cookie", 1 );
  236                 debug_message("rc_cookie: $g->{rc_cookie}");
  237                 error( 'Forbidden', 403, 'Forbidden' );
  238             } else {
  239                 loggit( "refused: expired session", 1 );
  240                 debug_message("rc_cookie: $g->{rc_cookie}");
  241                 error( 'Session Expired', 408, 'Session Expired' );
  242             }
  243         }
  244 
  245         # get the data
  246         whois($domain);
  247     }
  248 
  249     $g->{outstr} = $banner . $g->{outstr};
  250 
  251     if ($domain) {
  252         if ( $g->{htmlnotfound} and $g->{outstr} =~ /$g->{re_notfound}/ig ) {
  253             $g->{dispfile} = $g->{htmlnotfound};
  254         } else {
  255             $g->{dispfile} = $g->{htmlfound} || $g->{htmlfile};
  256         }
  257     } else {
  258         $g->{dispfile} = $g->{htmlfirst} || $g->{htmlfile};
  259     }
  260 
  261     if ( $g->{dispfile} ) {
  262         error "$g->{dispfile}: $!" unless -f $g->{dispfile};
  263         if ($E::bwInclude_okay) {
  264 
  265             # create the appropriate variables in the bwInclude namespace
  266             bwInclude->var( 'SELF',   $g->{SELF} );
  267             bwInclude->var( 'DOMAIN', $domain );
  268             bwInclude->var( 'RESULT', $g->{outstr} );
  269 
  270             $h .= bwInclude->spf( $g->{dispfile} );
  271         } else {
  272             my $hh = new IO::File "< $g->{dispfile}";
  273             error "cannot open $g->{dispfile}: $!\n" unless defined $hh;
  274             while (<$hh>) { $h .= $_ }
  275             $hh->close;
  276 
  277             # replace the variables
  278             $h =~ s/\$SELF\$/$g->{SELF}/gs;
  279             $h =~ s/\$DOMAIN\$/$domain/gs;
  280             $h =~ s/\$RESULT\$/$g->{outstr}/gs;
  281         }
  282     } else {
  283         $h = defaulthtml();
  284         $h =~ s/\$SELF\$/$g->{SELF}/gs;
  285         $h =~ s/\$DOMAIN\$/$domain/gs;
  286         $h =~ s/\$RESULT\$/$g->{outstr}/gs;
  287     }
  288 
  289     cgi_header($_ct);
  290     print $h;
  291 }
  292 
  293 sub do_commandline
  294 {
  295     usage()   if $g->{help};
  296     version() if $g->{versionflag};
  297 
  298     if ( $g->{makehtml} ) {
  299         print defaulthtml();
  300         exit;
  301     }
  302 
  303     usage() unless @_;
  304 
  305     # signon
  306     _print $banner unless $g->{quiet};
  307 
  308     message "timeout is $g->{timeout}\n" if ( $g->{timeout} != $default_timeout );
  309 
  310     while ( my $domain = shift ) {
  311         loggit( "commandline domain: $domain", 1 );
  312         whois($domain);
  313     }
  314 }
  315 
  316 sub cgi_header
  317 {
  318     return if $http_header_sent;
  319     my $ct          = shift || 'text/html';
  320     my $status_code = shift || '';
  321     my $status_text = shift || '';
  322     $status_code .= " $status_text" if $status_code and $status_text;
  323     my $nl      = "\x0d\x0a";
  324     my $h       = '';
  325     my $modperl = $ENV{MOD_PERL};
  326 
  327     loggit( "Status: $status_code",            9 ) if $status_code;
  328     loggit( "Set-Cookie: $g->{cookie_header}", 9 ) if $g->{cookie_header};
  329     loggit( "Content-type: $ct",               9 );
  330 
  331     if ( $modperl and !$ENV{PERL_SEND_HEADER} ) {
  332         my $r = Apache->request;
  333         if ($status_text) {
  334             $r->status_line($status_code);
  335         } elsif ($status_code) {
  336             $r->status($status_code);
  337         }
  338         $r->header_out( 'Set-Cookie' => $g->{cookie_header} ) if $g->{cookie_header};
  339         $r->send_http_header($ct);
  340     } else {
  341         $h .= "Status: $status_code$nl"            if $status_code;
  342         $h .= "Set-Cookie: $g->{cookie_header}$nl" if $g->{cookie_header};
  343         $h .= "Content-type: $ct$nl$nl";
  344         print $h;
  345     }
  346 
  347     $http_header_sent = TRUE;
  348 }
  349 
  350 sub whois
  351 {
  352     my $domain         = shift;
  353     my $tld            = '';
  354     my $r_host         = $g->{phost} || '';
  355     my $r_port         = $portname;
  356     my $netblock       = FALSE;
  357     my $r_default_host = $default_host;
  358 
  359     $r_port = ( $r_host =~ /rwhois/ ) ? $RWHOIS_PORT : $WHOIS_PORT unless $r_port;
  360 
  361     # '.' is the root domain
  362     # but it is not recognized by most whois servers
  363     # trim the trailing dot if found ...
  364     $domain =~ s/\.+$//;
  365 
  366     # support for the <request>@<domain>:<port> syntax ...
  367     ( $domain, $r_host ) = split( /\@/, $domain, 2 ) unless $r_host;
  368     ( $r_host, $r_port ) = split( /:/, $r_host, 2 ) if $r_host;
  369 
  370     # trim leading and trailing whitespace from the query
  371     $domain =~ s/^\s+//;
  372     $domain =~ s/\s+$//;
  373 
  374     # is it a packed IP address?
  375     if ( $domain =~ /^(\d+)$/ and $1 > 16777215 ) {    # all numeric is a packed IP address
  376         $domain = unpackip($domain);
  377     }
  378 
  379     _print "Request: $domain\n" unless $g->{quiet};
  380 
  381     # is it a netnum or NETBLK? try ARIN first
  382     if ( !$r_host and ( $domain =~ /^(\d{1,3}\.?){1,4}$/ or $domain =~ /^net(blk)?-[a-z0-9\-]+$/i ) ) {
  383         $r_default_host = $netblk_host;
  384         message "using netblock server $netblk_host\n";
  385         $netblock = TRUE;
  386     }
  387 
  388     my @rc     = ();
  389     my $subrec = '';
  390 
  391     # do we need a different default server?
  392     if ( !$r_host and ( $r_default_host ne $netblk_host ) ) {
  393         if ( $tld_conf and -f $tld_conf ) {
  394             my $tld_host = find_tld($domain);
  395             $r_default_host = $tld_host if $tld_host;
  396         }
  397     }
  398 
  399     # Go Fishin' at the default host ...
  400     unless ($r_host) {
  401         $r_host = FALSE;
  402 
  403         @rc = whois_fetch( $r_default_host, $domain, $r_port );
  404 
  405         if ($netblock) {    # is the netblk delegated ?
  406             foreach (@rc) {
  407                 next if /(nic\.mil|internic\.net|crsnic\.net)/;
  408                 if ( /(r?whois\.[\-\.a-z0-9]+)/i and !$r_host ) {
  409                     $r_host = $1;
  410                     $r_port = $RWHOIS_PORT if /rwhois/;    # default to the correct port # for rwhois
  411                 }
  412                 if (/\bport\s+(\d+)/i) { $r_port = $1; }
  413             }
  414         }
  415 
  416         else {    # we are at the root whois server ... find the delegation
  417             unless ( grep { /Server Name:/i } @rc ) {    # bail if it's a nameserver
  418                 grep { /Whois Server:\s*(\S*)/i and $r_host = $1 } @rc;    # look for the referral
  419             }
  420         }
  421     }
  422 
  423     # now we know where to look -- let's go get it
  424     if ($r_host) {
  425         display_buffer(@rc) if $g->{verbose};
  426         $r_port = $portname unless $r_port;
  427         @rc = whois_fetch( $r_host, $domain, $r_port );
  428         grep { /\((.*-DOM)\).*$domain$/i and $subrec = $1 } @rc;
  429     }
  430 
  431     # do we have a sub rec? If so, "Fetch!"
  432     if ($subrec) {
  433         display_buffer(@rc) if $g->{verbose};
  434         message "found a reference to $subrec ... requesting full record ...\n";
  435         @rc = whois_fetch( $r_host, $subrec, $r_port );
  436     }
  437 
  438     # tell 'em what we found ...
  439     message "Registrar: $r_host\n" if ( @rc && $r_host );
  440 
  441     display_buffer(@rc);
  442 }
  443 
  444 
  445 sub display_buffer
  446 {
  447     while (@_) {
  448         my $l = shift;
  449         if ( $g->{in_disclaimer} ) {
  450             $g->{in_disclaimer} = in_disclaimer($l);
  451         } else {
  452             _print $l unless $g->{stripdisclaimer} && in_disclaimer($l);
  453         }
  454     }
  455 }
  456 
  457 sub in_disclaimer
  458 {
  459     my $l    = shift;
  460     my $host = $g->{this_host};
  461     find_disclaimer() unless ( $g->{sd_conf_done} and lc $g->{sd_conf_done} eq lc $host );
  462     return FALSE unless ( $g->{this_sd}[0] and lc $g->{this_sd}[0] eq lc $host );
  463     return $g->{in_disclaimer} = TRUE  if ( ( $l =~ /$g->{this_sd}[1]/ ) and !$g->{in_disclaimer} );
  464     return $g->{in_disclaimer} = FALSE if ( ( $l =~ /$g->{this_sd}[2]/ ) and $g->{in_disclaimer} );
  465     return $g->{in_disclaimer};
  466 }
  467 
  468 sub whois_fetch
  469 {
  470     my $w_host = shift;
  471     my $domain = shift;
  472     my $port   = shift || $WHOIS_PORT;
  473     my $pf     = '';                     # prefix command for some whois servers
  474     my ( $uri, $handle );
  475     my @rc;
  476 
  477     if ( $g->{cache_table} ) {
  478         error "Cannot use cache_table without database\n" unless $g->{database};
  479         init_dbi();
  480     }
  481 
  482     my @db_params = ( $domain, $w_host, $port );
  483     if ( check_cache(@db_params) ) {
  484         loggit( "retreived $domain from cache of [$w_host:$port]", 3 );
  485         return splitlines( $g->{result} );
  486     }
  487 
  488     if ( $g->{outgoing_ip} ) {
  489         my $n = scalar( @{ $g->{outgoing_ip} } );
  490         my $a;
  491         if ( $n == 1 ) {
  492             $a = $g->{outgoing_ip}[0];
  493         } elsif ( $n > 1 ) {
  494             $a = $g->{outgoing_ip}[ int( rand() * $n ) ];
  495         }
  496         if ($a) {
  497             if ( $a =~ /^(\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3})$/i ) { $g->{LocalAddr} = $1; }
  498             else                                                   { error "Invalid outgoing IP address ($a)\n" }
  499             message "outgoing IP: $g->{LocalAddr}\n" if $g->{LocalAddr};
  500         }
  501     }
  502 
  503     # this untaint is necessary for -T
  504     if ( $w_host =~ /^([-a-z0-9_.]+)$/i ) { $w_host = $1; }
  505     else                                  { error "Invalid registry hostname ($w_host)\n" }
  506 
  507     # reset flags for new host
  508     $g->{this_host}     = $w_host;
  509     $g->{in_disclaimer} = FALSE;
  510 
  511     my $rs = IO::Socket::INET->new(
  512         PeerAddr  => $w_host,
  513         PeerPort  => $port,
  514         Proto     => $protoname,
  515         Timeout   => $g->{timeout},
  516         LocalAddr => $g->{LocalAddr} );
  517 
  518     # trouble connecting ?
  519     unless ($rs) {
  520         my $errno = 0 + $!;
  521         if ($E::errno_okay) {
  522             _print $!{EINVAL}
  523               ? "host $w_host not found\n"
  524               : "unable to connect to $w_host ($errno: $!)\n";
  525         } else {
  526             _print "unable to connect to $w_host ($errno)\n";
  527         }
  528         return;
  529     }
  530 
  531     my $IP      = $rs->peerhost;
  532     my $PORTNUM = $rs->peerport;
  533     _print "connected to $w_host [$IP:$PORTNUM] ... \n" unless $g->{quiet};
  534     $rs->autoflush(1);
  535 
  536     loggit( "request $domain from $w_host [$IP:$PORTNUM]", 2 );
  537 
  538     # if it's a valid 2nd-level domain name, treat it as one.
  539     $g->{dl2} = FALSE;
  540     if ( $domain =~ /^[a-z\d\-]+\.[a-z\d\-]+$/ ) {
  541         $g->{dl2} = TRUE;
  542     }
  543 
  544     # special cases ...
  545     if ( $g->{dl2} && $w_host eq $default_host ) { $pf = 'domain '; }
  546 
  547     # other special case whois servers
  548     if ( $w_host eq 'whois.denic.de' ) { $pf = '-T dn '; }
  549     if ( $w_host eq 'whois.nic.name' ) { $pf = 'domain = '; }
  550     if ( $w_host eq 'whois.arin.net' ) { $pf = 'n '; }
  551 
  552     # .jp whois requires '/e' after domain name, use jpokay flag
  553     if ( !$g->{jpokay} and $w_host =~ /\.jp$/ ) { $domain .= '/e'; }
  554 
  555     $rs->print("$pf$domain$newline");
  556 
  557     # blocking timeout for servers who accept but don't answer
  558     eval {
  559         local $SIG{ALRM} = sub { die "timeout\n" };
  560         alarm $g->{timeout};
  561 
  562         while (<$rs>) {
  563             push @rc, $_;
  564         }
  565 
  566         alarm 0;
  567     };
  568 
  569     # report a blocking timeout
  570     if ( $@ eq "timeout\n" ) {
  571         _print "Timeout waiting for response.\n" unless $g->{quiet};
  572     } elsif ( $@ =~ /alarm.*unimplemented/ ) {    # no signals on Win32
  573         while (<$rs>) {
  574             push @rc, $_;
  575         }
  576     }
  577 
  578     $g->{link_host} = $w_host;
  579 
  580     write_cache( @db_params, @rc );
  581     return @rc;
  582 }
  583 
  584 sub check_referer
  585 {
  586     my $r = $ENV{HTTP_REFERER} || '';
  587     $r =~ m|https?://(.*?)[:/]|;    # ensure a valid referer, and get the host part only
  588     $r = $1 || '';
  589     my $_okay = FALSE;
  590 
  591     return 'okay' if ( $g->{allow_referer} and $g->{allow_referer} eq '*' );
  592 
  593     # no or poorly-formed referer
  594     return 'no_referer' unless $r;
  595 
  596     my $self_host = $ENV{HTTP_HOST} || '';
  597     $self_host = $1 if $self_host =~ m|(.*?):|;    # lose the port part if nec.
  598 
  599     $_okay = TRUE if $r eq $self_host;
  600 
  601     if ( !$_okay and $g->{allow_referer} ) {
  602         my @allow_referer = split( /:/, $g->{allow_referer} );
  603         $_okay = grep { $r eq $_ } @allow_referer;
  604         loggit( "checking allow_referer r: $r (" . join( ", ", @allow_referer ) . ") \[${_okay}\]", 9 );
  605         return 'allowed_referer' if $_okay;
  606     }
  607 
  608     return 'bad_referer' unless $_okay;
  609     return 'okay';
  610 }
  611 
  612 #### SQL support ####
  613 
  614 ### cache table support ###
  615 
  616 # cleanup old cache entries
  617 sub clean_cache
  618 {
  619     return FALSE unless $g->{dbh};            # no db
  620     return FALSE unless $g->{cache_table};    # no cache table
  621 
  622     my $db_query;
  623 
  624     if ( $g->{database} eq 'mysql' ) {
  625         $db_query = qq|
  626         DELETE FROM $g->{cache_table} 
  627         WHERE (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp)) > ?
  628         |;
  629     } elsif ( $g->{database} eq 'pgsql' ) {
  630         $db_query = qq|
  631         DELETE FROM $g->{cache_table} 
  632         WHERE EXTRACT(EPOCH FROM NOW() - stamp) > ?
  633         |;
  634     } elsif ( $g->{database} =~ /sqlite3?/ ) {
  635         # the (? + 0) is to force the parameter to numeric
  636         # this gets around a misfeature in DBD::SQLite
  637         $db_query = qq|
  638         DELETE FROM $g->{cache_table} 
  639         WHERE (STRFTIME('%s', 'now') - STRFTIME('%s', stamp)) > (? + 0)
  640         |;
  641     }
  642     $g->{dbh}->do( $db_query, undef, $g->{cache_expire} ) or error "clean_cache: $DBI::errstr\n";
  643 }
  644 
  645 sub check_cache
  646 {
  647     return FALSE unless $g->{dbh};    # no cache db
  648 
  649     clean_cache();
  650 
  651     my $domain = shift or return FALSE;
  652     my $c_host = shift || $default_host;
  653     my $port   = shift || $WHOIS_PORT;
  654     my $domain_select = lc "${domain}\@${c_host}:${port}";
  655 
  656     if ( $g->{refresh_cache} ) {
  657         $g->{dbh}->do(
  658             qq| DELETE FROM $g->{cache_table} WHERE query = ? |, undef, $domain_select
  659         ) or error "cache_refresh: $DBI::errstr\n";
  660         return FALSE;
  661     } else {
  662 
  663         # is it cached?
  664         my $db_query = '';
  665         if($g->{database} eq 'mysql') {
  666             $db_query = qq| SELECT value, UNIX_TIMESTAMP(stamp) FROM $g->{cache_table} WHERE query = ? |;
  667         } elsif($g->{database} eq 'pgsql') {
  668             $db_query = qq| SELECT value, EXTRACT(EPOCH FROM stamp)::INT FROM $g->{cache_table} WHERE query = ? |;
  669         } elsif($g->{database} eq 'sqlite3') {
  670             $db_query = qq| SELECT value, STRFTIME('%s', stamp) FROM $g->{cache_table} WHERE query = ? |;
  671         }
  672         my ( $v, $t ) = $g->{dbh}->selectrow_array( $db_query, undef, $domain_select ) or return FALSE;
  673 
  674         # find the delta time
  675         my $dt = time - $t;
  676         my $ts = date_stamp($t, 'gmt sort');
  677 
  678         # report that we have a hit
  679         if    ( $g->{verbose} ) { _print "from $c_host:$port [cached $ts UTC ($dt ticks ago)]\n"; }
  680         elsif ( !$g->{quiet} )  { _print "from $c_host:$port [cached $ts UTC]\n"; }
  681 
  682         # store the result
  683         $g->{link_host} = "${c_host}:${port}";
  684         $g->{result}    = $v;
  685 
  686         # reset flags for new host
  687         $g->{this_host}     = $c_host;
  688         $g->{in_disclaimer} = FALSE;
  689 
  690         return TRUE;
  691     }
  692 }
  693 
  694 # write a result in the cache database
  695 sub write_cache
  696 {
  697     return unless $g->{dbh};    # no cache db
  698 
  699     my $domain = shift or return FALSE;
  700     my $c_host = shift || $default_host;
  701     my $port   = shift || $WHOIS_PORT;
  702 
  703     # build a results string
  704     my $r = '';
  705     while (@_) {
  706         $r .= shift;
  707     }
  708 
  709     return unless $r;           # don't cache empty results
  710 
  711     # store the string in the databse
  712     $g->{dbh}->do(
  713         qq| INSERT INTO $g->{cache_table} (query, value) VALUES (?, ?) |,
  714         undef, lc "${domain}\@${c_host}:${port}", $r
  715     ) or error "write_cache: $DBI::errstr\n";
  716 }
  717 
  718 ### cookie table support ###
  719 
  720 # cleanup old cookie entries
  721 sub clean_cookie
  722 {
  723     return FALSE unless $g->{dbh};              # no db
  724     return FALSE unless $g->{control_table};    # no cookie table
  725 
  726     my $db_query = '';
  727     if ( $g->{database} eq 'mysql' ) {
  728         $db_query = qq|
  729             DELETE FROM $g->{control_table} 
  730             WHERE class = ? and (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp)) > ?
  731         |;
  732     } elsif ( $g->{database} eq 'pgsql' ) {
  733         $db_query = qq|
  734             DELETE FROM $g->{control_table} 
  735             WHERE class = ? and EXTRACT(EPOCH FROM NOW() - stamp) > ? 
  736         |;
  737     } elsif ( $g->{database} eq 'sqlite3' ) {
  738         $db_query = qq|
  739             DELETE FROM $g->{control_table} 
  740             WHERE class = ? and (STRFTIME('%s', 'now') - STRFTIME('%s', stamp)) > (? + 0)
  741         |;
  742     }
  743 
  744     $g->{dbh}->do( $db_query, undef, $g->{session_class}, $g->{cookie_expire} ) or error "clean_cookie: $DBI::errstr\n";
  745 }
  746 
  747 # check for an existing cookie
  748 sub check_cookie
  749 {
  750     init_dbi() unless $g->{dbh};
  751     error "Cannot use cookie_name without database\n" unless $g->{dbh};
  752     unless ( $g->{cookie_in} = $cgi->cookie( $g->{cookie_name} ) ) {
  753         return 'no_cookie';
  754     }
  755 
  756     my $v = $g->{dbh}->selectrow_array( qq|
  757       SELECT id FROM $g->{control_table} WHERE id = ? AND class = ?
  758     |, undef, $g->{cookie_in}, $g->{session_class} );
  759 
  760     if ($v) {
  761         # don't reuse a cookie
  762         $g->{dbh}->do( qq|
  763             DELETE FROM $g->{control_table} 
  764             WHERE id = ? AND class = ?
  765         |, undef, $g->{cookie_in}, $g->{session_class} ) or error "check_cookie[DELETE]: $DBI::errstr\n";
  766     } else {
  767         return 'expired_cookie';
  768     }
  769     return 'okay';
  770 }
  771 
  772 # create a new cookie
  773 sub new_cookie
  774 {
  775     return unless $g->{dbh};
  776 
  777     # A session ID is a simple string of pseudo-random digits.
  778     # It shouldn't need to be too sophisticated
  779     foreach ( 1 .. 8 ) { $g->{cookie_out} .= sprintf( "%4.4x", int( rand(0xffff) ) ) }
  780 
  781     $g->{dbh}->do( qq|
  782         INSERT INTO $g->{control_table} (id, class, count) VALUES (?, ?, 0)
  783     |, undef, $g->{cookie_out}, $g->{session_class} ) or error "new_cookie: $DBI::errstr\n";
  784 
  785     $g->{cookie_header} = $cgi->cookie( -name => $g->{cookie_name}, -value => $g->{cookie_out} );
  786 }
  787 
  788 ### ip table support ###
  789 
  790 # cleanup old ip entries
  791 sub clean_ip
  792 {
  793     return FALSE unless $g->{dbh};              # no db
  794     return FALSE unless $g->{control_table};    # no control table
  795 
  796     my $db_query = '';
  797     if ( $g->{database} eq 'mysql' ) {
  798         $db_query = qq|
  799             DELETE FROM $g->{control_table} 
  800             WHERE class = ? and (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp)) > ?
  801         |;
  802     } elsif ( $g->{database} eq 'pgsql' ) {
  803         $db_query = qq|
  804             DELETE FROM $g->{control_table} 
  805             WHERE class = ? and EXTRACT(EPOCH FROM NOW() - stamp) > ? 
  806         |;
  807     } elsif ( $g->{database} eq 'sqlite3' ) {
  808         $db_query = qq|
  809             DELETE FROM $g->{control_table} 
  810             WHERE class = ? and (STRFTIME('%s', 'now') - STRFTIME('%s', stamp)) > (? + 0)
  811         |;
  812     }
  813 
  814     $g->{dbh}->do( $db_query, undef, $g->{ip_class}, $g->{ip_expire} ) or error "clean_ip: $DBI::errstr\n";
  815 }
  816 
  817 # check for an existing cookie
  818 sub check_ip
  819 {
  820     init_dbi() unless $g->{dbh};
  821     error 'Cannot use ip_control without database' unless $g->{dbh};    # no db
  822     $g->{ip_this} = $ENV{REMOTE_ADDR} or error 'Cannot use ip_control without server REMOTE_ADDR support.';
  823 
  824     my $db_query = '';
  825     if ( $g->{database} eq 'mysql' ) {
  826         $db_query = qq|
  827             SELECT id, count, (UNIX_TIMESTAMP() - UNIX_TIMESTAMP(stamp))
  828             FROM $g->{control_table} WHERE id = ? AND class = ?
  829         |;
  830     } elsif ( $g->{database} eq 'pgsql' ) {
  831         $db_query = qq|
  832             SELECT id, count, EXTRACT(EPOCH FROM NOW() - stamp)
  833             FROM $g->{control_table} WHERE id = ? AND class = ?
  834         |;
  835     } elsif ( $g->{database} eq 'sqlite3' ) {
  836         $db_query = qq|
  837             SELECT id, count, (STRFTIME('%s', 'now') - STRFTIME('%s', stamp))
  838             FROM $g->{control_table} WHERE id = ? AND class = ?
  839         |;
  840     }
  841 
  842     my ( $v, $n, $t ) = $g->{dbh}->selectrow_array( $db_query, undef, $g->{ip_this}, $g->{ip_class} );
  843 
  844     if ($v) {
  845         $g->{ip_interval} = $t;
  846         $n++;
  847         $g->{dbh}->do( qq|
  848             UPDATE $g->{control_table} 
  849             SET count = ?
  850             WHERE class = ? and id = ? 
  851         |, undef, $n, $g->{ip_class}, $g->{ip_this} ) or error "check_ip[update]: $DBI::errstr\n";
  852 
  853         return "IP count ($n) over limit" if $n > $g->{ip_control};
  854     } else {
  855         $g->{dbh}->do( qq|
  856             INSERT INTO $g->{control_table} (id, class, count) VALUES (?, ?, 1)
  857         |, undef, $g->{ip_this}, $g->{ip_class} ) or error "check_ip[insert]: $DBI::errstr\n";
  858     }
  859     return 'okay';
  860 }
  861 
  862 ### general SQL support ###
  863 
  864 # normalized for modern DBI by wew 2003-07-17
  865 # added support for SQLite - wew 2010-09-14
  866 sub init_dbi
  867 {
  868     return if $g->{dbh};    # don't re-init
  869     return unless $g->{database};
  870 
  871     my $dbxlat = {
  872         mysql   => 'mysql',
  873         pgsql   => 'Pg',
  874         sqlite  => 'SQLite',
  875         sqlite3 => 'SQLite'
  876     };
  877 
  878     my $db_module = $dbxlat->{ lc $g->{database} } or error "unsupported database $g->{database}\n";
  879     error "DBI and DBD::$db_module are required for this operation.\n" unless $E::dbi_okay;
  880 
  881     $g->{dbc} = {};
  882     my $dbc = $g->{dbc};
  883     my $dsn = '';
  884 
  885     if($db_module eq 'SQLite') {
  886         $dsn = 'DBI:SQLite:' . $g->{connect};
  887     } else {
  888         ( $dbc->{db}, $dbc->{host}, $dbc->{port}, $dbc->{user}, $dbc->{pass} ) =
  889           split( /:/, $g->{connect} );
  890         $dsn = "DBI:$db_module:dbname=$dbc->{db}";
  891         $dsn .= ";host=$dbc->{host}" if $dbc->{host};
  892         $dsn .= ";port=$dbc->{port}" if $dbc->{port};
  893     }
  894     $g->{dbh} = DBI->connect( $dsn, $dbc->{user}, $dbc->{pass}, { PrintError => 0, AutoCommit => 1 } );
  895     error "cannot connect to database $dsn ($DBI::errstr)\n" unless $g->{dbh};
  896 }
  897 
  898 # disconnect from the DB when done.
  899 # the MySQL docs say this is unnecessary 
  900 # my experience is that I get occasional error messages if I don't
  901 sub END
  902 {
  903     my $dbh = $g->{dbh} or return;
  904     $dbh->disconnect;
  905 }
  906 
  907 #### utility code ####
  908 
  909 sub version { print $banner, "\n"; exit 0 }
  910 
  911 sub date_stamp
  912 {
  913     my $t     = shift || time;
  914     my $flags = shift || '';
  915     my @months = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
  916     my $i;
  917     my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst );
  918     my $zoffset = "-0000";
  919 
  920     if ( $flags =~ /(gmt|utc)/ ) {
  921         ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = gmtime($t);
  922     } else {
  923         ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime($t);
  924         my @gm = gmtime($t);
  925         $zoffset = sprintf( "%+2.02d00", ( $i = ( $hour - $gm[2] ) ) > 12 ? ( $i - 24 ) : $i );
  926     }
  927 
  928     if ( $flags =~ /sort/ ) {
  929         return sprintf( "%04d-%02d-%02d %02d:%02d:%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec );
  930     } else {
  931         return sprintf( "%d %s %d %02d:%02d:%02d $zoffset", $mday, $months[$mon], $year + 1900, $hour, $min, $sec );
  932     }
  933 }
  934 
  935 ### deep recursion waring !!! do NOT call error() from loggit() use die() instead !!! ###
  936 sub loggit
  937 {
  938     return if ( !$g->{logfile} );
  939     my $m = shift or return;
  940     my $level = shift;
  941 
  942     if ( $level && $g->{log_level} ) {
  943         return unless $level <= $g->{log_level};
  944     } elsif ($level) {
  945         return if $level > 1;
  946     }
  947 
  948     my $d = date_stamp( time, 'sort utc' );
  949 
  950     unless ( $g->{log_name} || $g->{progname} ) {
  951         $0 =~ /([^\/\\]*)$/;
  952         $g->{progname} = $1 ? $1 : $0;
  953     }
  954 
  955     my $log_name = $g->{log_name} || $g->{progname};
  956 
  957     my $pid = $$;
  958 
  959     my $r_ip   = $ENV{REMOTE_ADDR} || '';
  960     my $r_user = $ENV{REMOTE_USER} || '';
  961     my $remote = '';
  962     $remote .= "${r_user}:" if $r_user;
  963     $remote .= "$r_ip"      if $r_ip;
  964 
  965     my $message = '';
  966     $message .= "${d}";
  967     $message .= " \[${pid}\]";
  968     $message .= " ($remote)" if $remote;
  969     $message .= " ${log_name}";
  970     $message .= ": $m";
  971     $message .= " (${level})" if $g->{log_level};
  972     $message .= "\n";
  973 
  974     # Untaint the logfile filename. It came from the config file,
  975     # and we just have to trust it.
  976     $g->{logfile} =~ /(.*)/;
  977     my $fn = $1;
  978 
  979     my $fh = new IO::File(">>$fn") or die("Cannot open log $g->{logfile} ($!)\n");
  980     flock( $fh, LOCK_EX );
  981     $fh->seek( 0, SEEK_END );
  982     $fh->print($message);
  983     flock( $fh, LOCK_UN );
  984     $fh->close();
  985 }
  986 
  987 sub splitlines
  988 {
  989     my @r;
  990     $_ = shift;
  991     while ($_) {
  992         $_ .= "\n" unless (/\x0d|\x0a/);
  993         s/(.*?(\x0d\x0a|\x0d|\x0a))//;
  994         push @r, $1;
  995     }
  996     push( @r, $_ ) if $_;
  997     return @r;
  998 }
  999 
 1000 sub find_disclaimer
 1001 {
 1002     error("could not open $sd_conf (required for the stripdisclaimer feature): $!") unless -f $sd_conf;
 1003 
 1004     # do we have a host?
 1005     return unless $g->{this_host};
 1006 
 1007     # do we already have a result for this host?
 1008     return if ( $g->{sd_conf_done} and $g->{sd_conf_done} eq $g->{this_host} );
 1009 
 1010     my $hconf = new IO::File "< $sd_conf";
 1011     $g->{this_sd} = [ '', '', '' ];
 1012     while (<$hconf>) {
 1013         next if /^#/;
 1014         chomp;
 1015         s/#.*//;     # lose comments
 1016         s/^\s+//;    # lose leading whitespace
 1017         s/\s+$//;    # lose trailing whitespace
 1018         next unless $_;
 1019         my ( $h, $s, $e ) = /(\S+)\s+"([^"]+)"\s+"([^"]+)"/;
 1020         if ( $h and ( !$s or !$e ) ) { error "invalid entry in $sd_conf: $h\n" }
 1021 
 1022         if ( $h and lc $h eq lc $g->{this_host} ) {
 1023             $g->{this_sd} = [ $h, $s, $e ];
 1024         }
 1025     }
 1026     $g->{sd_conf_done} = $g->{this_host};
 1027 }
 1028 
 1029 sub find_tld
 1030 {
 1031     my $domain   = lc shift;
 1032     my $tld      = '';
 1033     my $server   = '';
 1034     my $tld_file = "$tld_conf";
 1035 
 1036     return FALSE unless $tld_conf and -f $tld_file;
 1037 
 1038     my $htld = new IO::File "< $tld_file";
 1039     error "can't open $tld_file ($!)\n" unless defined($htld);
 1040     while (<$htld>) {
 1041         next if /^#/;
 1042         chomp;
 1043         my @tokens = split(/\s+/);
 1044         my $lh     = shift @tokens or next;
 1045         my $rh     = shift @tokens or next;
 1046         if ( substr( $domain, 0 - length($lh) ) eq $lh ) {
 1047             $tld    = $lh;
 1048             $server = $rh;
 1049             _print "whois server for *$tld is $server ...\n" unless $g->{quiet};
 1050             last;
 1051         }
 1052     }
 1053     $htld->close;
 1054     return $server;
 1055 }
 1056 
 1057 sub opt_bool
 1058 {
 1059     return TRUE if shift =~ /^(1|true)$/i;
 1060     return FALSE;
 1061 }
 1062 
 1063 sub parse_conf
 1064 {
 1065     # give feedback about the conf file if it's specified and not found
 1066     if ( $g->{whois_conf_switch} ) {
 1067         error "configuration file ($g->{whois_conf_switch}): $!\n" unless -f $g->{whois_conf_switch};
 1068         $g->{whois_conf} = $g->{whois_conf_switch};
 1069     } elsif ( $ENV{WHOIS_CONF} ) {
 1070         error "configuration file (from environment variable) $ENV{WHOIS_CONF}: $!\n" unless -f $ENV{WHOIS_CONF};
 1071         $g->{whois_conf} = $ENV{WHOIS_CONF};
 1072     } elsif ( !-f $g->{whois_conf} ) {
 1073         # no override and no default file -- try for a copy in pwd
 1074         $g->{whois_conf} =~ m|.*[\/\\](.*)|;    # just the part of the filename after '/' or '\';
 1075         my $whois_conf_pwd = $1 || '';
 1076         return unless ( $whois_conf_pwd and -f $whois_conf_pwd );
 1077         $g->{whois_conf} = $whois_conf_pwd;
 1078     }
 1079 
 1080     my $hconf = new IO::File "< $g->{whois_conf}";
 1081     error "cannot open $g->{whois_conf}: $!\n" unless defined $hconf;
 1082 
 1083     while (<$hconf>) {
 1084         chomp;
 1085         s/#.*//;                                # lose comments
 1086         s/^\s+//;                               # ... leading whitespace
 1087         s/\s+$//;                               # ... trailing whitespace
 1088         next unless $_;
 1089         my @t   = split /\s+/;
 1090         my $tok = lc shift(@t);
 1091 
 1092         if    ( $tok eq 'quiet' )           { $g->{quiet}             = opt_bool( shift(@t) ) }
 1093         elsif ( $tok eq 'verbose' )         { $g->{verbose}           = opt_bool( shift(@t) ) }
 1094         elsif ( $tok eq 'jpokay' )          { $g->{jpokay}            = opt_bool( shift(@t) ) }
 1095         elsif ( $tok eq 'cgi_xml' )         { $g->{cgi_xmlmode}       = opt_bool( shift(@t) ) }
 1096         elsif ( $tok eq 'stripdisclaimer' ) { $g->{stripdisclaimer}   = opt_bool( shift(@t) ) }
 1097         elsif ( $tok eq 'debug' )           { $g->{debug}             = opt_bool( shift(@t) ) }
 1098         elsif ( $tok eq 'tld_conf' )        { $tld_conf               = shift(@t) }
 1099         elsif ( $tok eq 'sd_conf' )         { $sd_conf                = shift(@t) }
 1100         elsif ( $tok eq 'filters_conf' )    { $g->{filters_conf}      = shift(@t) }
 1101         elsif ( $tok eq 'logfile' )         { $g->{logfile}           = shift(@t) }
 1102         elsif ( $tok eq 'log_name' )        { $g->{log_name}          = shift(@t) }
 1103         elsif ( $tok eq 'log_level' )       { $g->{log_level}         = shift(@t) }
 1104         elsif ( $tok eq 'default_host' )    { $default_host           = shift(@t) }
 1105         elsif ( $tok eq 'htmlfile' )        { $g->{htmlfile}          = shift(@t) }
 1106         elsif ( $tok eq 'htmlfound' )       { $g->{htmlfound}         = shift(@t) }
 1107         elsif ( $tok eq 'htmlnotfound' )    { $g->{htmlnotfound}      = shift(@t) }
 1108         elsif ( $tok eq 'htmlfirst' )       { $g->{htmlfirst}         = shift(@t) }
 1109         elsif ( $tok eq 'timeout' )         { $g->{timeout}           = shift(@t) }
 1110         elsif ( $tok eq 'database' )        { $g->{database}          = shift(@t) }
 1111         elsif ( $tok eq 'connect' )         { $g->{connect}           = shift(@t) }
 1112         elsif ( $tok eq 'cache_table' )     { $g->{cache_table}       = shift(@t) }
 1113         elsif ( $tok eq 'control_table' )   { $g->{control_table}     = shift(@t) }
 1114         elsif ( $tok eq 'cookie_name' )     { $g->{cookie_name}       = shift(@t) }
 1115         elsif ( $tok eq 'cache_expire' )    { $g->{cache_expire}      = shift(@t) }
 1116         elsif ( $tok eq 'cookie_expire' )   { $g->{cookie_expire}     = shift(@t) }
 1117         elsif ( $tok eq 'ip_control' )      { $g->{ip_control}        = shift(@t) }
 1118         elsif ( $tok eq 'ip_expire' )       { $g->{ip_expire}         = shift(@t) }
 1119         elsif ( $tok eq 'allow_referer' )   { $g->{allow_referer}     = shift(@t) }
 1120         elsif ( $tok eq 'direct_link' )     { $g->{direct_link}       = shift(@t) }
 1121         elsif ( $tok eq 'error_403' )       { $g->{error_docs}->{403} = shift(@t) }
 1122         elsif ( $tok eq 'error_408' )       { $g->{error_docs}->{408} = shift(@t) }
 1123         elsif ( $tok eq 'outgoing_ip' ) { @{ $g->{outgoing_ip} } = split( /:/, shift(@t) ) }
 1124 
 1125         else { error "unrecognized token in $g->{whois_conf} : $tok\n" }
 1126 
 1127         if ( $g->{direct_link} and !$g->{ip_control} ) {
 1128             error 'Cannot use direct_link without ip_control';
 1129         }
 1130     }
 1131 }
 1132 
 1133 sub unpackip
 1134 {
 1135     my $packed_ip = shift;
 1136     my $n         = $packed_ip;
 1137     my @an;
 1138 
 1139     while ($n) {
 1140         unshift @an, $n & 255;
 1141         $n >>= 8;
 1142     }
 1143 
 1144     my $ip = join ".", @an;
 1145     _print "packed 32-bit IP $packed_ip => $ip\n" unless $g->{quiet};
 1146     return $ip;
 1147 }
 1148 
 1149 sub defaulthtml
 1150 {
 1151     return q{<!--  
 1152 
 1153   BW whois example HTML file
 1154   Copyright 1999-2012 William E. Weinman  http://whois.bw.org/  
 1155 
 1156   Placeholders are used for the various values which make this 
 1157   work. These placeholders are represented by text enclosed in 
 1158   '$' signs like this: 
 1159 
 1160     $PLACEHOLDER$
 1161 
 1162   The placeholders are: 
 1163 
 1164     SELF    The URI path of the program on your web server, taken 
 1165             from the value of the SCRIPT_NAME environment variable. 
 1166 
 1167     DOMAIN  The domain that was last looked up, if any. 
 1168 
 1169     RESULT  The result of the whois query from BW whois. 
 1170 
 1171   See the example (below) for specific usage. 
 1172 
 1173 -->
 1174 
 1175 <html>
 1176 <title> BW whois &middot; Online Query </title>
 1177 
 1178 <body>
 1179 
 1180 <h2> <a href="http://whois.bw.org/">BW whois</a> &middot; Online Query </h2>
 1181 
 1182 <p>
 1183 <form action="$SELF$" method=post>
 1184 Enter a domain name: <br>
 1185 <input type=text name=domain value="$DOMAIN$">
 1186 <input type=submit>
 1187 </form>
 1188 
 1189 <p><pre>
 1190 $RESULT$
 1191 </pre></p>
 1192 </body>
 1193 </html>
 1194 
 1195 <!-- end of example HTML file for BW whois -->
 1196 }
 1197 }
 1198 
 1199 sub message
 1200 {
 1201     return if $g->{quiet};
 1202     _print @_ if $g->{verbose};
 1203 }
 1204 
 1205 sub _print
 1206 {
 1207     my ( $handle, $uri );
 1208 
 1209     if ( $g->{htmlmode} or $g->{cgimode} ) {
 1210 
 1211         # RFC-954 whois servers (e.g. whois.networksolutions.com) require the "!"
 1212         # to look up handles, while other whois servers (e.g. RIPE) prohibit it.
 1213         # I search for the double-dash option as that is often used on those servers
 1214         $handle = ( $g->{link_host} =~ /whois.networksolutions.com/ ) ? '%21' : '';
 1215         $uri = $g->{SELF} || 'whois';
 1216 
 1217         while (@_) {
 1218             my $_outstr = shift;
 1219 
 1220             # some registrants put HTML in their records. Sheeesh!
 1221             $_outstr =~ s/&/&amp;/g;
 1222             $_outstr =~ s/</&lt;/g;
 1223             $_outstr =~ s/>/&gt;/g;
 1224             $_outstr =~ s/"/&quot;/g;
 1225 
 1226             # make a link out of a domain
 1227             $_outstr =~ s!
 1228                 \b(
 1229                 (?:
 1230                     [a-z0-9]
 1231                     [a-z0-9-]+
 1232                     \.
 1233                 )?
 1234                 ([a-z-]{2,}\.[a-z]{2}|com|net|org|edu|int|gov|mil)
 1235                 )(?=[^a-z-.])
 1236                 !<a href="$uri?domain=$1">$1</a>!gsxi
 1237                 if ( $g->{htmlmode} or $g->{cgimode} );
 1238 
 1239             # make a link out of a handle
 1240             $_outstr =~ s|
 1241                 \((                    # a handle is in parens ...
 1242                     [A-Z]                # ... is all UPPERCASE and starts with a letter
 1243                     [A-Z0-9-_]{3,}?)\)   # ... may contain digits, dashes, and underscores
 1244                 |(<a href="$uri?domain=$handle$1%40$g->{link_host}">$1</a>)|gsx
 1245                 if ( $g->{htmlmode} or $g->{cgimode} );
 1246 
 1247             # make a link out of an IP address
 1248             $_outstr =~ s|
 1249                 ([\d]{1,3}\.[\d]{1,3}\.[\d]{1,3}\.[\d+]{1,3})    # only for full ip addresses
 1250                 |<a href="$uri?domain=$1%40$netblk_host">$1</a>|gsx
 1251                 if ( $g->{htmlmode} or $g->{cgimode} );
 1252 
 1253             $g->{outstr} .= $_outstr;
 1254             print $_outstr unless $g->{cgimode};
 1255         }
 1256     } else {
 1257         print @_;
 1258     }
 1259 }
 1260 
 1261 sub debug_message
 1262 {
 1263     $g->{debug_message} .= shift if $g->{debug};
 1264 }
 1265 
 1266 sub error_doc
 1267 {
 1268     my $fn = shift;
 1269 
 1270     if ($E::bwInclude_okay) {
 1271         if ( $g->{debug_message} ) {
 1272             bwInclude->var( 'debug_message', $g->{debug_message} );
 1273         } else {
 1274             bwInclude->var( 'debug_message', '' );    # so it doesn't fart
 1275         }
 1276         bwInclude->var( 'SELF', $g->{SELF} );
 1277         bwInclude->pf($fn);
 1278     } else {
 1279         my $fh = new IO::File("<$fn");
 1280         print "cannot open $fn ($!)\n" unless $fh;
 1281         while (<$fh>) { print }
 1282     }
 1283 }
 1284 
 1285 sub error
 1286 {
 1287     if ( $g->{cgimode} ) {
 1288         my $em          = shift || 'Unknown error."';
 1289         my $status_code = shift || '';
 1290         my $status_text = shift if $status_code;
 1291         if ( $g->{cookie_in} ) {
 1292 
 1293             # client gave us a cookie, send back a blank cookie
 1294             # to purge the cookie from the broser
 1295             $g->{cookie_header} = $cgi->cookie( -name => $g->{cookie_name}, -value => '' );
 1296         } else {
 1297 
 1298             # client didn't give us a cookie, so don't give one back
 1299             $g->{cookie_header} = undef;
 1300         }
 1301         cgi_header( 'text/html', $status_code, $status_text );
 1302         if ( $status_code and $g->{error_docs}->{$status_code} ) {
 1303             error_doc( $g->{error_docs}->{$status_code} );
 1304         } else {
 1305             print qq{
 1306                 <html><head><title> BW Whois &middot; Error </title></head>
 1307                 <body bgcolor=white>
 1308                 <h1> Error </h1>\n<p><em>$em</em>
 1309                 </body></html>
 1310             };
 1311         }
 1312         exit;
 1313     } else {
 1314         die @_;
 1315     }
 1316 }
 1317 
 1318 sub usage
 1319 {
 1320     print $banner;
 1321     print <<USAGE;
 1322 
 1323 usage: whois [options] (<request> | <request>@<host>) [ ... ]
 1324 
 1325 options: 
 1326 
 1327   --help             Show this screen.
 1328 
 1329   --version          Show version information and exit. 
 1330 
 1331   --config <path>    Full path to the configuration file. 
 1332                      Default: $whois_conf_default
 1333 
 1334   --refresh          Refresh the cache for this query. 
 1335   -r                 This forces the request to go to the whois server
 1336                      even if the result is cached. (Only valid if caching
 1337                      is configured.)
 1338 
 1339   --tld <path>       Full path/file name for tld.conf file. Defaults 
 1340                      to "/etc/whois/tld.conf".
 1341 
 1342   --host <host>      Hostname of the whois server
 1343   -h <host>          this is the same as the <request>@<host> form
 1344                      if not specified will search $default_host
 1345                      for a "Whois Server:" record.
 1346 
 1347   --timeout <n>      Set the timeout to a number of seconds. The default 
 1348                      is 60 seconds. 
 1349 
 1350   --port             Specify a different port than the normal whois(43).
 1351   -p
 1352 
 1353   --quiet            Don't print any extraneous messages. 
 1354   -q                 (overrides --verbose)
 1355 
 1356   --verbose          Print extra messages.
 1357   -v                 (ignored if --quiet is used)
 1358 
 1359   --stripdisclaimer  Strip off disclaimers from the results. You've 
 1360   -s                 read it a thousand times already, right?
 1361 
 1362   --nocgi            Prevent CGI mode. For use when you have your own
 1363                      wrapper.
 1364 
 1365   --makehtml         Display example HTML file. Prints a small 
 1366                      file to STDOUT with the example HTML in it. 
 1367                      Use this to modify to your own taste for CGI 
 1368                      mode. Set htmlfile in config as needed. 
 1369 
 1370 Get the latest version of BW Whois here: http://whois.bw.org/
 1371 
 1372 USAGE
 1373     exit;
 1374 }
 1375