WHOIS caching proxy in perl

#!/usr/bin/perl
#
# $Header: /usr/local/etc/RCS/whois-proxy.pl,v 1.8 2014/11/04 22:47:28 mwd Exp $
#
# WHOIS caching proxy
#
#-----------------------------------------------------------------------
my $VERSION = substr( q$Revision: 1.8 $, 10 );

package Whois {
    use strict;
    use warnings;
    use POSIX qw( strftime );

    use parent 'Net::Server::PreFork';

    use Net::Whois::Proxy;
    use Cache::FileCache;
    use Net::IP::Match::XS;
    use Net::CIDR;

    my $debug = 1;

    logstderr("starting $0 ( v$VERSION)") if ($debug);

    sub whois_query {

        my $request = shift;
        my $expires = '';
        my $created = '';

        # default the lookup key to the original request, that way
        # if we can't find a proper key to use, we fall back to
        # the original request just so we don't waste the lookup.
        # ie. at the very least, if we lookup this address again,
        # it will be cached using itself as a key
        my $key = $request;
        my $whois_body_cache =
          new Cache::FileCache(
                                {'namespace'          => 'WHOIS_cache',
                                 'default_expires_in' => '7 days'} );

        foreach my $cache_key ( $whois_body_cache->get_keys() ) {
            logstderr("cache_key==$cache_key") if ( $debug > 5 );
            if ( my $match_key = match_ip( $request, $cache_key ) ) {
                logstderr("using MATCHED KEY $cache_key for $request") if ( $debug > 1 );
                $key = $cache_key;
            } else {
                logstderr("$request did NOT match $cache_key") if ( $debug > 4 );
            }
        }

        # Get the body based on the original IP address we were given
        my $body = $whois_body_cache->get($key);

        # Didn't get a cache hit? do the WHOIS lookup from scratch
        if ( not defined $body ) {
            my $whois = Net::Whois::Proxy->new( debug => 0, stacked_results => 1, clean_stack => 1 );

            logstderr("looking up $request from remote WHOIS databases") if ($debug);
            $body = $whois->whois($request);

            if ( !$body ) {
                $body = $whois->errstr;
            } else {

                my $netaddresses = '';
                my %CIDRs        = ();

                # Step thru and extract all things that look like a CIDR or a NETRANGE
                # and then see which one is the best match for the requested IP address
                # BEST MATCH will most likely be the CIDR/mask where the mask is the largest
                # integer that still matches that subnet
                # 161.143.0.0 - 161.143.255.255
                # 18.0.0.0/8
                # 14.0.0/8
                # 10.0/8
                # 55/8 # Hopefully we  don't get these
                while ( $body =~
m!(\d+\.\d+\.\d+\.\d+\s+\-\s+\d+\.\d+\.\d+\.\d+)|(\d+\.\d+\.\d+\.\d+/\d+)|(\d+\.\d+\.\d+/\d+)|(\d+\.\d+/\d+)|(\d+/\d+)!osmg
                  ) {
                    my ( $netrange, $full_cidr, $ctype_cidr, $btype_cidr, $atype_cidr ) =
                      ( $1, $2, $3, $4 );

                    if ( defined $netrange ) {
                        logstderr("FOUND NETRANGE $netrange");

                        # convert NETRANGE to CIDR
                        foreach my $range_cidr ( Net::CIDR::range2cidr($netrange) ) {
                            if ( $range_cidr =~ m!(\d+\.\d+\.\d+\.\d+)/(\d+)!o ) {
                                logstderr("FOUND FULL CIDR FROM NETRANGE $range_cidr");
                                my ( $full, $mask ) = ( $1, $2 );
                                $full_cidr = "$full/$mask";
                                $CIDRs{$full_cidr} = $mask;
                            }
                        }
                    } elsif ( defined $full_cidr ) {
                        logstderr("FOUND FULL CIDR $full_cidr");
                        if ( $full_cidr =~ m!(\d+\.\d+\.\d+\.\d+)/(\d+)!o ) {
                            my ( $full, $mask ) = ( $1, $2 );
                            $full_cidr = "$full/$mask";
                            $CIDRs{$full_cidr} = $mask;
                        }
                    } elsif ( defined $ctype_cidr ) {
                        logstderr("FOUND CTYPE CIDR $ctype_cidr");
                        if ( $ctype_cidr =~ m!(\d+\.\d+\.\d+)/(\d+)!o ) {
                            my ( $c, $mask ) = ( $1, $2 );
                            $ctype_cidr = "$c.0/$mask";
                            $CIDRs{$ctype_cidr} = $mask;
                        }
                    } elsif ( defined $btype_cidr ) {
                        logstderr("FOUND BTYPE CIDR $btype_cidr");
                        if ( $btype_cidr =~ m!(\d+\.\d+)/(\d+)!o ) {
                            my ( $b, $mask ) = ( $1, $2 );
                            $btype_cidr = "$b.0.0/$mask";
                            $CIDRs{$btype_cidr} = $mask;
                        }
                    } elsif ( defined $atype_cidr ) {
                        logstderr("FOUND ATYPE CIDR $atype_cidr");
                        if ( $atype_cidr =~ m!(\d+)/(\d+)!o ) {
                            my ( $a, $mask ) = ( $1, $2 );
                            $atype_cidr = "$a.0.0.0/$mask";
                            $CIDRs{$atype_cidr} = $mask;
                        }
                    }
                } ## end while ( $body =~ ...)

                # Step thru all the CIDRs sorting by highest bit mask first.
                # the address we want as a key, will be the CIDR that first
                # matches the highest netmask
                foreach my $cidr_key ( sort { $CIDRs{$b} <=> $CIDRs{$a} } keys %CIDRs ) {

                    # if the bitmask is greater than 32 we bail out - no CIDR bit masks are greater
                    # than 32 - at least in IPv4 and we only handle IPv4 so....
                    next if ( $CIDRs{$cidr_key} > 32 );

                    $netaddresses .= "$cidr_key, ";

                    logstderr("$cidr_key==$CIDRs{$cidr_key}") if ( $debug > 2 );

                    # if we get a match, set the key to this CIDR and skip the rest of the foreach loop
                    if ( my $match_key = match_ip( $request, $cidr_key ) ) {
                        logstderr("setting key for $request as $cidr_key");
                        $key = $cidr_key;

                        # BAIL out of the loop, we found what we are looking for...
                        last;
                    }

                } ## end foreach my $cidr_key ( sort...)

                # Chop off the final ", "
                $netaddresses =~ s!,\s+$!!soig;
                ##die $netaddresses;

            } ## end else [ if ( !$body ) ]

            $whois_body_cache->set( $key, $body );
        } else {
            logstderr("serving up cached request for $request with $key") if ($debug);
        }

        my $object = $whois_body_cache->get_object($key);
        $expires = $object->get_expires_at();
        $created = $object->get_created_at();

        return ( $body, $key, $expires || '', $created || '' );

    } ## end sub whois_query

    sub process_request {
        ( my $request = <> ) =~ s/[.]([^.]+)\x{0d}\x{0a}/.$1/;
        my ( $mybody, $mykey, $myexpires, $mycreated ) = whois_query($request);

       #print "pid=$$ request=$request key=$mykey expires=$myexpires created=$mycreated\r\n$mybody\r\n";
        printf "pid=%d request=%s key=%s expires=%s created=%s\r\n%s\r\n",
          $$, $request, $mykey, fmttime($myexpires), fmttime($mycreated), $mybody;
    }

    sub fmttime {
        my $thistime = shift;
        return ( strftime "%Y/%m/%d-%H:%M:%S", localtime($thistime) );
    }

    sub logstderr {
        my $msg = shift;

        #my $timestring = strftime "%Y/%m/%d-%H:%M:%S", localtime;
        printf STDERR "%s %s\n", fmttime( time() ), $msg;
    }

} ## end package Whois

Whois->run( user              => "nobody",
            group             => "nobody",
            port              => 43,
            min_servers       => 1,              #min number of children
            max_servers       => 5,              #max number of children
            min_spare_servers => 1,              #fork if we don't have this many waiting
            max_spare_servers => 2,              #kill if we have this many waiting
            max_requests      => 10_000,         #num of requests before killing a child
            );