#!/usr/local/bin/perl
#
# radbserver.pl
#
# Simple server of information from various ripe-based databases.
#
# This server can be thought of as an extension of the RIPE whoisd server.
# (The core of this implementation is borrowed from there.)
# Besides the usual RIPE queries, this server also provides a protocol
# for getting information from RIPE-style database files that is not
# easily (rapidly) obtainable using the standard whois queries.
# These queries can be submitted one-at-a-time via whois, or
# by establishing a connection to the server, issuing multiple queries,
# and then closing the connection.
#
# For example, the protocol includes queries desigend to rapidly retrieve
# information to construct config files (for Route Servers, ANS-gated, etc).
# Some of the queries can be answered quickly by fetching items using RIPE/RRDB tools
# (e.g., get object for a given ASnumber) and then returning only
# specified attribute values (e.g., the the as-in values).
# However, to answer some other queries *rapidly*, "indexes" (associative arrays)
# are built and used by this server.  For example, one index has as its keys
# community names, and the associated values are lists of all routes in the db file
# that are members of that community. There are also indexes by origin AS and 
# country, and others can easily be added.
# The indexes are stored in gdbm files (though they easily could be stored in 
# DB or other files).
# 
# The server is also set up to process update commands, i.e., to update the
# indexes it uses when the underlying databases are changed.
# The basic update commands allow one to add a (key:route) pair, or delete one.
# The idea is that dbupdate (the ripe update interface) could send these commands
# to the server when an update is processed (as needed), thus keeping
# radbserver's special indexes up-to-date in real time, without rebuilding.
#
# See Usage() below for more details on protocol commands and return codes and formats,
# and for some examples.
#
#
# NOTES:
# 0. This was originally written as a prototype, just to see/show that the
#    dbserver-net-client architecture would be fast enough to generate config files
#    in a timely fashion. (I took just a few days, starting from a stripped out copy
#    of RIPE's whoisd server.)
#    Thus this is currently code in progress, going from prototype to real production codes.
#    Read and critique with that in mind, please!
#
# 1. This version stores indicies in gdbm files, because (n)dbm has 1K limit on entries.
#    This means we have to use perl5, which makes it possible to use a variety
#    of dbms's to store perl associative arrays.  However, if gdbm proves inadequate,
#    it will be easy to use DB instead, using different tie commands in perl5.
# 
# 2. Currently there are 5 indices built:
#    key       value
#    -------   ---------------------------
#    ASnum     routes with ASnum as origin
#    Country   routes with Country 
#    Commun    routes in Community
#    m=ASnum   routes with metric=ASnum in their nsflist attribute value.
#    <misc>    stores lists of selected things, by special keys:
#              - key = IR   list of all inet-rtr objects in db. 
#
#    The m=ASnum index allows lookup on metric=as values from NSFNET PRDB
#    net-granularity policy.  Currently PRDB nets are dumped into prdb.db in RIPE format,
#    including the nsflist attribute which contains the dynamic net announcements for that net/route.
#
# 3. Actually, all the indexes for each *.db file are stored in one (g)dbm file/associative array.
#    The indexes must be built by a call with the -N parameter.
#    Prefixes are used to distinguish the different key types.
#    Each *.db file has its indexes stored in a separate (gdbm) file
#    named after the associated RIPE source, e.g., RIPE, MERITRR, etc.
#    Commands are available so clients can choose which source(s) they
#    want answers to come from.
#
# 4. radbserver.pl can be used in several ways:
#    - as a daemon:   start it up, it either builds the index files or uses existing one,
#          and then it waits for incoming calls, which it forks to answer.
#    - as an interactive program:  usefull for debugging, it starts and prompts user
#          for commands (of the same format sent to the daemon).
#    - as a one-shot command to build new index files, e.g., when getting
#          ready to switch to a new copy of the db files.
#
# 5. See the client.pl, which calls routines in qradbserver.pl, for an example
#    of how to get things from the radbserver from a perl program.
#    (client.pl is also just a handy way to see what the radbserver will give for answers.)
# 
# Z-1. Things still needs (at least!):
#       ==> handle parameters to whois mode queries (eg all the ripe181 pars)
#       - general cleanup; better error handling (eg for s set-sources)
#         ==> I pass sources and dbfiles around pretty loosely...needs a rethinking...
#       - security for update commands---right now a few trusted hosts can update the indexes by 
#             sending proper command to the whois port the daemon is running on.
#             maybe that should be made more secure
#             (not update the Routing Registry itself, mind you,
#             just the radbserver indicies....but that's bad enough!)
#       - include locking for updating
#       - resolve issue of multipe answers, perhaps differnt, from multiiple sources/ db's.
#             currently radbserver:
#                - whois query: just like std ripe whoisd
#                - non-index query: returns values from (non-null) item found in first source,
#                      and on end-of-data line returns count of number of different values.
#                - index query: returns concatenation of all values.
#                      (this could include duplicates)
#       - any other experimental codes in here cleaned out
#       - better logging
#
# ======>
# ======> in processInputLine, if I have subroutines try to write to default
# ======> filehandle via printf, to write answers to caller, the answers
# ======> don't get there...they don't seem to go anywhere, since the don't go
# ======> to console that started radbserver daemon, either!
# ======> Thus all the garbage in processInputLine, which I will clean up
# ======> as soon as I figure out what the problem is.
# ======>
#
# Z. I used a couple of editors; one seems to copy tabs as spaces!
#    For vi, use tabstop=4.
#
#
# ===> Note on perl5:
#   Things seem to work EXCEPT the lookups using the ripe &dbopen,&dbmatch.
#   These need the    use NDBM_File;    statement.
#
#
# Thanks to RIPE for supplying the whoisd and other RIPE codes.
#
##########################################################################################

@INC = ("/ra/ripe181/lib", @INC);

require "rconf.pl";
require "dbopen.pl";
require "dbclose.pl";
require "enread.pl";
require "enwrite.pl";
require "enkeys.pl";
require "misc.pl";
require "dbmatch.pl";
require "syslog.pl";

#require "template.pl";

	# these should be in the INC path defined above...
require	"radbserver-ripewhois.pl";		# ripe-style whois routines, from their whoisd...
require "radbserver-usage.pl";			# help commands
require "radbserver-misc.pl";			# misc utilities
require	"radbserver-index.pl";          # index building and updating routines
require "radbserver-init.pl";			# initialize constants, global vars, etc

require	"getopts.pl";

use		GDBM_File;
use		NDBM_File;		# need this for dbmatch to not cause core dump!

&Getopts('P:S:f:C:L:hHNDdpqUA');

if ( $opt_h ) {					# take care of various help options...
    &Usage();
	exit;
}
if ( $opt_q ) {
	&Print_Protocol_Query_Codes();
	exit;
}
if ( $opt_H ) {
	&Usage();
	&Explain_Protocol();
	&Examples();
	exit;
}
if ( $opt_U ) {
	&Print_Protocol_Update_Codes();
	exit;
}

# Read config file from RIPEDBCNF, or from run-line.

$conffile= $opt_C;
$conffile=$ENV{"RIPEDBCNF"};
$conffile = $opt_C if ( $opt_C );
$conffile = "./conf" if ( !$conffile );

&rconf($conffile);

&radbserverInit();				# setup constants, global vars from options, etc.


#
# prompt for queries...
#

if ( $opt_p ) {
	print STDERR "\ncmd (q to quit, h for help? ";
	while ( <STDIN> ) {
		if ( $_ eq "q\n" ) { last; }
		if ( $_ eq "h\n" ) { &Usage(); }
		elsif ( $_ eq "d\n" ) { $opt_d = $opt_d ? 0 : 1; print STDERR "\nopt_d now $opt_d.\n"; }
		elsif ( $_ ne "\n" ) {
			if ( $EscapeChar eq substr($_,0,1) ) {
        		&processInputLine( *sources, *dbfiles, substr($_,1), '' );
    		}
    		else {
				local(@S) = @sources;	# don't change overall setting based on -s par to whois
				local(@D) = @dbfiles;
				local($msg);
				local($string) = $_;
				if ( ($msg=&Parse(*string,*S,*D)) ) {
					print "\n$msg\n";
				}
				else {
					print STDERR "\nPar to whois: $string (Set-Sources: @S)\n" if $opt_d;
					&whois(*S,$string);
				}
    		}
		}
		print STDERR "\ncmd? ";
	}
	exit;
}

#
# Going to use the daemon...
#

if ( $opt_d ) {
	print STDERR "($$) running daemon in debug mode\n";
}
else {
    # detach from tty
    exit 0 if (fork() > 0);
    if (open(FILE, "/dev/tty")) {
	    if (!ioctl(FILE,(0x20000000|(ord('t')<<8)|113),0)) {   
            print STDERR "ioctl: $!\n" if ($opt_d);
        }
        close(FILE);
    }
    close(0) if -t;
}

#
# now really start the daemon...
#

if ( $opt_P )    { $port = $opt_P; }
else             { $port = 43; }

print STDERR "($$) running on port $port\n" if $opt_d;

$AF_INET = 2;
$SOCK_STREAM = 1;
$SOL_SOCKET = 0xffff;
$SO_REUSEADDR = 0x0004;

$sockaddr = 'S n a4 x8';

($name, $aliases, $proto) = getprotobyname('tcp');
if ($port !~ /^\d+$/) {
	($name, $aliases, $port) = getservbyport($port, 'tcp');
}

$this = pack($sockaddr, $AF_INET, $port, "\0\0\0\0");

select(NS); $| = 1; select(STDOUT);

socket(S, $AF_INET, $SOCK_STREAM, $proto) || die "socket: $!";
setsockopt(S, $SOL_SOCKET, $SO_REUSEADDR, pack('i', 1)) || die "setsockopt: $!";

while (!bind(S, $this)) {
	if ($bindcount >= 20) {
		print STDERR "whoisd: bind() failed 20 times, giving up\n";
		&syslog($ERRLOG, "whoisd cannot bind() for 20 times, giving up");
		exit 1;
	} else {
		print STDERR "-- bind: $!, trying again\n" if ($opt_d);
		$bindcount++;
		sleep 5;
	}
}

if ($bindcount) {
	&syslog($ERRLOG, "whoisd needed $bindcount binds before succeeding");
}

listen(S,5) || die "listen: $!";

select(S); $| = 1; select(STDOUT);

# Set up the alarm handler

$SIG{'ALRM'} = 'alarmhandler';

# We have come this far, let's write the PID to $PIDFILE, useful for
# killing and stuff.

if (open(PID, ">$PIDFILE")) {
	print PID "$$\n";
	close(PID);
}
else {
	&syslog($ERRLOG, "cannot write to $PIDFILE: $!");
}

# Main waiting loop, wait for connection, and fork of child to process
# the incoming request

print STDERR "\n\n===> $0 entering the main loop, waiting for calls...\n\n";
&syslog($QRYLOG,"[] OK START SERVER ($0): indexpath $DBIPath [@sources]");


for (;;) {
	($addr = accept(NS,S)) || die $!;

	if (($child = fork()) == 0) {
		($af,$port,$inetaddr) = unpack($sockaddr,$addr);
		@inetaddr = unpack('C4', $inetaddr);
		$rhost = "$inetaddr[0].$inetaddr[1].$inetaddr[2].$inetaddr[3]";
		print STDERR "($$) fork connection [$rhost]\n" if $opt_d;
		local($name,$alias,$at,$len,@addr)=gethostbyaddr($inetaddr,$af);
        if ($name eq "") {
            $name = $rhost;
        }		
		print STDERR "($$) rhost '$rhost', name '$name'.\n" if $opt_d;

		# Set alarm to timeout after people did not send anything soon enough...
		# in 60 seconds
		alarm $NormalTimeOut;

		local($remainOpen) = 0;					# set true if user asks for it...

		while(<NS>) {
			$result = 0;
			alarm 0;        # Got something, reset alarm
			chop;
			$string = $_;
			# some telnet's end lines with \r\n (\r=CR, dec13)---so we need this cleanup!!
			&CleanInput( *string );
			print STDERR "($$) chopped,tr input is '$string'.\n" if $opt_d;
			select(NS);

			next if ( length($string) == 0 );

			if ( $remainOpen ) { 			# already in multi-query protocol mode 
				last if ( $EndSessionCode == unpack("c",$string) );	
				&processInputLine(*sources, *dbfiles, $string, $name );
				alarm $BangBangTimeOut;		#reset again---do we need this here?
			}
			elsif ( substr($string,0,2) eq "$EscapeChar$EscapeChar" ) {
				print STDERR "Enter multi-question mode...\n" if $opt_d;
				$remainOpen = 1;
				&syslog($QRYLOG,"[] OK enter multi-query mode [@sources] $name $$");
				alarm $BangBangTimeOut;     #reset again---do we need this here?
			}
			else {		# must be first command to server
				&DoOneShotCommand( $name, $string, *sources, *dbfiles );
				last;
			}
		}
		close(NS);
		&syslog($QRYLOG,"[] OK close multi-query mode [@sources] $name $$") if $remainOpen;
		print STDERR "($$) exit connection [$rhost]\n" if $opt_d;
		exit;
	}
	while (waitpid(-1, 1) > 0) {}
	
} # end main

#############################################
#
# DoOneShotCommand
#
# This may be a one-shot protocol command, an radbserver help
# command, or a standard whois query.    In any case,
# first strip off and process any -parameter settings.
#

sub DoOneShotCommand {
	local($name,$string,*sources,*dbfiles) = @_;
	local(@HelpCmds) = ('-q','-h','-H','-U');

	print STDERR "DoOneShotCommand '$string' ($name); sources:\n    @sources\n" if $opt_d;

	if ( grep( /$string/, @HelpCmds ) ) {
		if ( $string eq '-q' ) {
			&Print_Protocol_Query_Codes();
		}
		elsif ( $string eq '-h' ) {
			&Usage();
		}
		elsif ( $string eq '-H' ) {
			&Usage();
			&Explain_Protocol();
			&Examples();
		}
		elsif ( $string eq '-U' ) {
			&Print_Protocol_Update_Codes();
		}
   		&syslog($QRYLOG,"[] OK $string [@sources] $name");
		return;
	}

	

   	if ( substr($string,0,1) eq $EscapeChar ) { # process one protocol command
		# there must be better way do strip a possible trailing blank...each a s/.../ !
   		$string = substr($string,0,length($string)-1) if ( substr($string,-1,1) eq ' ' );
   		print STDERR "Execute one protocol command: '$string'\n" if $opt_d;
   		&processInputLine(*sources,*dbfiles,substr($string,1), $name );
  	}
   	else { # must be non-protocol ripe-whois command
   		print STDERR "\nPar to whois (after Parse): $string. (Set_Sources @sources)\n" if $opt_d;
   		&whois( *sources, $string );
   		&syslog($QRYLOG,"[] OK whois $string [] $name"); # <=== Should be in &whois probably!!!
	}

}
#      	print STDERR "\nPar to whois (before Parse): $string\n" if $opt_d;
#      	if ( ($msg = &Parse(*string,*sources,*dbfiles)) ) {
#  	   		print "\n$msg\n";
#  	   		&syslog($QRYLOG,"[whois,$string] NO parse: $msg  [@sources] $name");
#      	}



#################################################################################
#
# processInputLine
#
# Process one input line of the form:  <code><string-command-par>\n 
# Return lines of the form <code><msg-string>\n
# Basic idea for a good return is:
#   <code-for-length-of-data-coming><length msg>\n
#   <code-for-data-line>data\n
#   ...repeat those two as needed...
#   <end-of-data-code><differnce-cnt>
# The difference-cnt indicates how many of the db's had different answers
# from value found in the first db (ordered as on the startup command).
# The answer from the first db is the one returned.
#
# See top of file in Usage for list of codes and meanings.
#
# note that we build the indicies if we need to...
#
##################################################################################

sub processInputLine {
    local(*sources,*dbfiles,$string,$rhostname) = @_;
	local($code,$cmdstring,$logmsg);
	local($firstvalue,$firstsource,$diffsources,$rm,$rc) = ('','','','','');
	local($sourceCnt,$itemcnt,$itemsDiffCnt) = (0,0,0);
	local($asType,$commType,$asmacroType) = ("an","cm","am");

	return if ( length( $string ) == 0 );		# nothing to do!
    $string =~ /^(.)(.*)$/;
	$code = unpack("c",$1);
	$cmdstring = $2;
	print STDERR "\n($$) processInputLine => code $1 (numeric $code), cmdstring $cmdstring \n" if $opt_d;

	if ( !grep(/$code/,@AllCmdCodes) ) {		# check the code...
        printf "%cIllegal code $code (cmd '$cmdstring').\n", $ErrorReturnCode;
		&syslog($QRYLOG,"[$code,$cmdstring] NO Illegal code [@sources] $rhostname");
        return;
	}

	if ( $code == $DebugShowCode ) {		# special debugging...
		&DebugShow();
		printf "%c\n", $EODReturnCode;
		return;
	}
	if ( $code == $SetSourceCode ) {		# change sources...  ===> Could use checking!
		local($msg) = '';
		if ( ($msg = &SetSources($cmdstring,*sources,*dbfiles,$CheckIndexesExist)) ) {
			printf "%c$msg\n", $ErrorReturnCode;
			&syslog($QRYLOG,"[$code,$cmdstring] NO SetSources: $msg [@sources] $rhostname ");
		}
		else { 
			printf "%c\n", $EODReturnCode;
			&syslog($QRYLOG,"[$code,$cmdstring] OK SetSources [@sources] $rhostname $$");
		}
		return;
	}
	if ( $code == $GetSpecialCommRoutesCode ) {	# special lookup from a file
		local($msg) = '';
		if ( ($msg = &GetSpecialCommRoutes($cmdstring)) ) {
			printf "%c$msg\n", $ErrorReturnCode;
			&syslog($QRYLOG,"[$code,$cmdstring] NO GetSpecialCommRoutes: $msg [] $rhostname");
		}
		else {
			printf "%c\n", $EODReturnCode;
			&syslog($QRYLOG,"[$code,$cmdstring] OK GetSpecialCommRoutes [] $rhostname");
		}
		return;
	}

	# if its to change indicies, do that and we are done...

	if ( grep( /$code/, @ChangeCmdCodes ) ) {
		local($rc,$msg) = &UpdateIndicies( $code, $cmdstring, $rhostname, *sources, *dbfiles );
		print STDERR "from UpdateIndicies, rc $rc, msg '$msg'\n" if $opt_d;
		printf "%c$msg\n", $rc;
		if ( $rc == $EODReturnCode ) {
			&syslogRLR($UILOG,"[$code,$cmdstring] OK [@sources] $rhostname");
		}
		else {
			&syslogRLR($UILOG,"[$code,$cmdstring] NO $msg [@sources] $rhostname");
		}
		return;
	}

	if ( $code == $DumpAllRoutesCode ) { # optional cmdstring par is list of sources
		local($rc,$routes) = &GetAllRoutes($cmdstring,*dbfiles);
		if ( $rc = $EODReturnCode ) {
			local($l) = length($routes);
		   	printf "%c%d\n", $DataLenCode, $l;
		   	do {
		   		$routes =~ s/(.*)\n*//;
		   		printf "%c$1\n", $DataReturnCode;
		   	} while ( $routes );
			printf "%c0\n", $EODReturnCode;
			&syslog($QRYLOG,"[$code,$cmdstring] OK [@sources] $rhostname");
		}
		else {
			printf "%c$routes\n", $ErrorReturnCode;
   	  		&syslog($QRYOG,"[$code,$cmdstring] NO $routes [@sources] $rhostname");
		}
		return;
	}

   	#
	# see if its a special x-ROUTES community.  If not, leave it for regular lookup...
   	#
	if ( $code == $GetRoutesByCommunCode && grep( /$cmdstring/, @RouteCommunityNames ) ) {
		local($rc,$l,$routes) = ($EODReturnCode,0,'');
		$cmdstring =~ /^(.*)-ROUTES/;
   		print STDERR "\nlook for special community: '$cmdstring' (source $1)...\n" if $opt_d;
		($rc,$routes) = &GetAllRoutes1($1);
		if ( $rc = $EODReturnCode ) {
			local($l) = length($routes) + 1;	# 1 for the \n
		   	printf "%c%d\n", $DataLenCode, $l;
			printf "%c$routes\n", $DataReturnCode;
#		   	do {
#		   		$routes =~ s/(.*)\n*//;
#		   		printf "%c$1\n", $DataReturnCode;
#		   	} while ( $routes );
			printf "%c0\n", $EODReturnCode;
			&syslog($QRYLOG,"[$code,$cmdstring] OK [@sources] $rhostname");
		}
		else {
			printf "%c$routes\n", $ErrorReturnCode;
   	  		&syslog($QRYOG,"[$code,$cmdstring] NO $routes [@sources] $rhostname");
		}			
		undef $routes;
   	   	return;
	}

	# now look in each source for the answer(s).  
	# Note for indexed searches, we cat the answers together.
	# But for the other searches, we just take the firstvalue we find.

	if ( grep(/$code/,@IndexCmdCodes) ) {       # do an index lookup, cat value to firstvalue...
		local($key,$value) = ('','');
        local($prefix) = &GetIndexPrefix( $code );
        if ( $code == $GetRoutesByOriginCode || $code == $GetRoutesByASMetricCode ) {
            $cmdstring =~ tr/[a-z]/[A-Z]/; # don't need to do ths for ByASMetricCode I should think...
        }
        $key = "$prefix-$cmdstring";
		print STDERR "\n Index search on key: $key \n" if $opt_d;

		foreach $source (@sources) {
			($value,$rc,$rm) = &GetValueFromIndex( $key, $source );
            if ( $value ) {
				$firstvalue .= $value . " ";
				$firstsource = $source;
                $itemcnt = 1;		# we always set to 1, no difference-errors in this case...
            }
		}
	}

	elsif ( $code == $GetAVTokens ) {
		local($key,$value) = ('','');
        $cmdstring =~ tr/[a-z]/[A-Z]/;
        $key = "$cmdstring";
		print STDERR "\n Get AVTokens (key '$key')\n" if $opt_d;
		foreach $source (@sources) {
			($value,$rc,$rm) = &GetAVTokens( $key, $source );
            if ( $value ) {
				$firstvalue .= $value . " ";
				$firstsource = $source;
                $itemcnt = 1;		# we always set to 1, no difference-errors in this case...
            }
		}
	}

	else { # for the rest, do the lookups from the db's, using the RIPE tools and some filters...
		# rlr 22sept94 turned off, as screws attr=value searches: $cmdstring =~ tr/[A-Z]/[a-z]/;
		local(@keys) = ();
		local($objtype,$attrname,$attrvalue,$expandASMacro) = ('','','',0);
        if ( grep(/$code/,($GetObjAttrCode,$FindObjsCode)) ) {   # should be <objname>,<key|value>,<attrname>
            $_ = $cmdstring;
            /^([a-z]*)\,(.*)\,(\S*)/;
            $objtype = $1;
			if ( $code == $GetObjAttrCode ) { @keys = ($2); }
			else				            { $attrvalue = $2; }
            $attrname = $3;
            if ( ! $ATTR{$objtype} ) {
                printf "%cUnknown object type '$objtype'.\n", $ErrorReturnCode;
				&syslog($QRYLOG,"[$code,$cmdstring] NO Unknown object type '$objtype' [@sources] $rhostname");
                return;
            }
            # need an attrname check here...a grep of some kind (but must watch embedded stuff?
            $attrname = $ATTR{$attrname} if length( $attrname ) > 2;    # get short internal form
            print STDERR "GetObjAttr/FindObjs: obj $objtype, key/value $2 (keys @keys), attr $attrname.\n" if $opt_d;
        }
		elsif ( $code == $GetObjectCode ) {
			$_ = $cmdstring;
            /^([a-z]*)\,(.*)/; # should be <objecttype>,<key>
            $objtype = $1;
			@keys = ($2);
		}
		elsif ( $code == $ExpandASMacroCode ) {
			$cmdstring =~ /^([\w\-]*)(\,1)?$/; # should be <mname>[,1]  ,1 if present means recursively expand ASMacros to all AS list
			@keys = ($1);
			$expandASMacro = substr($2,1,1) if substr($2,1,1);
		}
		else {
			@keys = ($cmdstring);
		}

		foreach $source (@sources) {
			local(@matches) = ();
			local(*dbi) = 'currentdb';
			local(%nothing) = ();
			foreach (@keys) { tr/[A-Z]/[a-z]/; }	# rlr added 3oct94
			local($K) = join(' ',@keys);
			local($PKeys) = ();
			local($nonintersect) = 1;

			if ( $code == $FindObjsCode ) {	# special case: sequential search...
				local($retvalue,$errcode,$errmsg) = &FindObjsByAttr( $objtype, $attrname, $attrvalue, $source );
				if ( $errcode ) {
					printf "%c$errmsg\n", $errcode;
					&syslog($QRYLOG,"[$code,$cmdstring] NO $errmsg [@sources] $rhostname");
					return;
				}
				elsif ( $retvalue ) {
					$firstvalue .= "$retvalue ";
					$firstsource = $source;
					$itemcnt++;
				}
				next;
			}

			print STDERR "\nkeys '$K', source '$source' -> DBFILE '$DBFILE{$source}': try to open and dbmatch...\n" if $opt_d;
			if ( ! &dbopen(dbi, *nothing, 0, $DBFILE{$source}) ) {
				printf "%cdbopen() failed for source '$source' (dbfile $DBFILE{$source}). Check -S values\n", $ErrorReturnCode ;
				&syslog($ERRLOG,"[$code,$cmdstring] NO dbopen failed for source '$source' [@sources] $rhostname $$");
				return;
			}
			&dbclopen(*nothing,0,$DBFILE{$source});

			@PKeys = &makekeys( $K );
			# print STDERR "\n   = makekeys => PKeys '@PKeys'" if $opt_d;
			&TransKeys( *PKeys );
			print STDERR "\n   = TransKeys => PKeys '@PKeys',nonintersect $nonintersect\n" if $opt_d;
			@matches = &dbmatch(*dbi,*PKeys,$nonintersect);
			print STDERR "...#matches is $#matches...\n" if $opt_d;
			if ( $#matches < 0 ) {
                print STDERR "Nothing found for key '$K'.\n" if $opt_d;
            }
            elsif ( $#matches > 1 ) {
                print STDERR "\nFound more than one match for '@keys'.\n" if $opt_d;
				printf "%c\n", $MultipleInOneDBCode;
				&syslog($QRYLOG,"[$code,$cmdstring] NO found more than one match for '@keys' [@sources] $rhostname");
				return;
            }
			else {	# got an object, lets get the attribute value we want...
                print STDERR "Found $K.\n" if $opt_d;
				local(%en) = &enread(dbi,$matches[0]);
				local($type) = &entype(*en);
                local($value) = "";

				if ( $code == $GetASInLinesCode ) {
					if ( $type ne $asType ) {
						printf "%cObject found type ($type) not '$asType' (AS).\n", $ErrorReturnCode;
						&syslog($QRYLOG,"[$code,$cmdstring] NO found type ($type) not '$asType' [@sources] $rhostname");
						return;
					}
					$value = $en{'ai'};
				}
				elsif ( $code == $GetASOutLinesCode ) {
                    if ( $type ne $asType ) {
                        printf "%cObject found type ($type) not '$asType' (AS).\n", $ErrorReturnCode;
						&syslog($QRYLOG,"[$code,$cmdstring] NO found type ($type) not '$asType' [@sources] $rhostname");
                        return;
                    }

                    $value = $en{'ao'};
                }
				elsif ( $code == $ExpandASMacroCode ) {
					local($r,$rm) = (0,'');
                    if ( $type ne $asmacroType ) {
                        printf "%cObject found with type '$type' not '$asmacroType' (AS-macro).\n", $ErrorReturnCode;
						&syslog($QRYLOG,"[$code,$cmdstring] NO found type ($type) not '$asmacroType' [@sources] $rhostname");
                        return;
                    }
					# The following expand strips all newlines, and we need to add one to be like other returned values
					($value,$r,$rm) = &ExpandASMacroASLines( $en{'al'}, $expandASMacro, join(',',@sources));
					$value .= "\n";
					$value =~ s/\n\n/\n/g;
				}
				elsif ( $code == $GetObjAttrCode ) {
					if ( $type ne $objtype ) {
                        printf "%cObject found with type '$type' not requested type '$objtype'.\n", $ErrorReturnCode;
						&syslog($QRYLOG,"[$code,$cmdstring] NO found type ($type) not '$objtype' [@sources] $rhostname");
                        return;
                    }
                    $value = $en{"$attrname"};
				}
				elsif ( $code == $GetObjectCode ) {
					if ( $type ne $objtype ) {
                        printf "%cObject found with type '$type' not requested type '$objtype'.\n", $ErrorReturnCode;
						&syslog($QRYLOG,"[$code,$cmdstring] NO found type ($type) not '$objtype' [@sources] $rhostname");
                        return;
                    }
					$value = &GetObjectValues(*en);
				}
				# now we have a value, see if its first, or if different from first from some other source.
				# BUT if its a null value, don't count it as first.

				$itemcnt++;
				if ( $itemcnt == 1 ) {
					$firstvalue = $value;
					$firstsource = $source;
				}
				elsif ( $firstvalue ne $value ) {
					$diffsources .= "$source ";
					$itemsDiffCnt++;
					$firstvalue = $value if ( !$firstvalue && $value );	# use value if fvalue null!
				}
			}
			&dbclose(*dbi);
		    &dbclclose();
		} # end foreach source
	} # end non-index case 

	#
	# now lets write out any items we have, and the end-of-data line with difference count.
	#

	print STDERR "\nfrom sources, got $itemcnt items, with $itemsDiffCnt different attribute values.\n" if $opt_d;

	if ( $itemcnt == 0 ) {
		printf "%c\n", $KeyNotFoundCode;
		&syslog($QRYLOG,"[$code,$cmdstring] NO Key not found [@sources] $rhostname $$");
	}
	else {
		local($l) = length($firstvalue)+1;	# +1 the last newline added below
        printf "%c%d\n", $DataLenCode, $l;
		do {
			$firstvalue =~ s/(.*)\n*//;
            printf "%c$1\n", $DataReturnCode;
        } while ( $firstvalue );
		if ( $itemsDiffCnt == 0 ) {
			printf "%c%d\n", $EODReturnCode, $itemsDiffCnt;
		}
		else {
			$itemsDiffCnt++;	# to return total count of db's with answer
			printf "%c%d,%s,%s\n", $EODReturnCode,$itemsDiffCnt,$firstsource,$diffsources;
		}
		$logmsg = "[$code,$cmdstring] OK itemcnt $itemcnt, diff $itemsDiffCnt, length $l [@sources] $rhostname $$";
		&syslog($QRYLOG,$logmsg);
	}

}

######################################################################################
#
# GetObjectValues
#
# given pointer to an object (assoc array), return all its *at: value lines, newline separated.
#
######################################################################################

sub GetObjectValues {
	local(*object) = @_;
    local(@fields) = split(/\s+/, "$OBJATSQ{&entype(*object)}");
	local($key,$val,$i,$rval);
    foreach $key (@fields) {
        if ($object{$key}) {
            @val = split(/\n/, $object{$key});
            for ($i = 0; $i<=$#val;$i++) {
                $rval .= "*".$key.": ".$val[$i]."\n";
            }
        }
    }
	return( $rval );
}

######################################################################################
#
# GetAVTokens
#
# given key and source db name, get m:a[(n)] tokens from associative 
# array (db file) for the source.
# Note we have to first tie the AssocArray var name to the db file, then release it.
# The keys of the array are of the form:
#   <$ROAM>-<m:a[(n)]>
# So if $key is '', get all by just stripping off the $ROAM prefixes.
# If $key is an AS, return only the ones with that AS in it (again, strip off prefix).
#
######################################################################################

sub GetAVTokens {
	local($key,$source) = @_;
	local($v,$rm,$rc) = ('','',0);

    print STDERR "  source: $source, key '$key'..." if $opt_d;
	if ( ($rm = &TieSource( $source, "R" )) ) {
		$rc = $ErrorReturnCode;
	}
	else {
		local(%a) = eval '%' . $source;
		if ( $key eq '' ) {
			foreach (keys %a) {
				if ( /$RoutesOfASMetricPrefix\-([\:\(\)\w]*)/ ) {
					$v .= "$1 ";
				}
			}
		}
		else {
			foreach (keys %a) {
				if ( /$RoutesOfASMetricPrefix\-([\:\(\)\w]*)/ ) {
					$_ = $1;
					/^[S\d]*\:(\d*)/;
					$v .= "$_ "  if ( $1 eq $key );
				}
			}
		}

        &UnTieSource($source);
        printf STDERR "   First 20 char=[%.20s]\n", $v if $opt_d;
    }
    return( $v, $rc, $rm );
}

######################################################################################
#
# GetValueFromIndex
#
# given key and source db name, get value from associative array (db file) for the source.
# Note we have to first tie the AssocArray var name to the db file, then release it.
#
######################################################################################

sub GetValueFromIndex {
	local($key,$source) = @_;
	local($v,$rm,$rc) = ('','',0);

    print STDERR "  source: $source, key '$key'..." if $opt_d;
	if ( ($rm = &TieSource( $source, "R" )) ) {
		$rc = $ErrorReturnCode;
	}
	else {
		$v = eval '$' . $source . '{$key}'; 		# works from cmd line, NOT in daemon!
        &UnTieSource($source);
	    chop $v;       # fetch returns \n at end of its output line
        printf STDERR "   First 20 char=[%.20s]\n", $v if $opt_d;
    }
    return( $v, $rc, $rm );
}


######################################################################################
#
# FindObjsByAttr
#
# given an object-type and attr=value, find and return blank separated list of
# keys for those objects of that type which have that value for that attribute.
# Notes:
# - this will take a couple minutes on larger db files, as its sequence scan.
# - this is not sophisticated about the attribute values: it really just
#   looks for lines that have  *<attr>: <value>
# - return list of $retval,$errcode,$errmsg.
#
######################################################################################

sub FindObjsByAttr {
	local( $objtype,$attrname,$value,$source ) = @_;
	local($retval,$errmsg,$errcode,$cnt,$tcnt) = ('','',0,0,0);
    local($route,$key,$wd);
	local($dbfile) = $DBFILE{$source};
	local($objpat) = '^\\*' . $objtype . ':\\s*(.*)$';
	local($attrpat) = '^\\*' . $attrname . ":\\s*$value" . '$';

    if ( !open(DBFILE, $dbfile) ) {
        $errmsg =  "ERROR(FindObjsByAttr): Can't open '$dbfile'!";
        $errcode = $ErrorReturnCode;
		return('',$errcode,$errmsg);
    }
    print STDERR "\nbegin searching $dbfile for $objtype objs with $attrname=$value:\n" if $opt_d;
    $start = (times)[0];

    while ( <DBFILE> ) {
        chop;
		next if ( /^\ *$/ );
        if ( !/$objpat/ ) {		# not what we want, so skip it all
		    while ( <DBFILE> ) {
			    chop;
		        last if ( /^\ *$/ );
			}
	        print STDERR "." if ( ($opt_p || $opt_d) && $tcnt % 500 == 499 );
			$tcnt++;
		}
		else {					# must be what we want!
	        $key = $1;
			$wd = 0;			# set to 1 if withdrawn found
			$found = 0;			# set to 1 if attrname=attrvalue is found
		    while ( <DBFILE> ) {	# now look for attr=value, wd, or end of object
			    chop;
		        last if ( /^\ *$/ );
	  	        if ( /$attrpat/ ) {
	   		        $cnt++;
	   				$found = 1;
	   				1;		# kludge for perl5 alpha bug...
	   	        }
				elsif ( /^\*wd:\ *(.*)$/ ) {
			   		$wd = 1;	             # could speed this by skipping to end-of-object...
					1;
			   	}
            }
			# now done with this object: if found attr=value and not withdrawn, append key to list of those found.
			$retval .= "$key " if $found && !$wd;
	        print STDERR "." if ( ($opt_p || $opt_d) && $tcnt % 500 == 499 );
			$tcnt++;
		}
	}

    if ( $opt_d ) {
        $end = (times)[0];
        printf STDERR "\nDone searching: found %d (took %.2f CPU seconds).\n", $cnt, $end - $start; 
    }

	return($retval,$errcode,$errmsg);
}
################################################################################
#
# GetAllRoutes         (under developement)
#
#
# Right now returns string of comma separated routes, every 10th followed by \n.
#
# if $source is specified, look in that db, else look in all in dbfiles.
#
###############################################################################

#
# this version depends on pre-stored files of routes, one route
# per line, with each line starting with blank or x (means ignore it!).
# it does't count routes, just one per line.
#

sub GetAllRoutes1 {
	local($sources) = @_;
	local($rc,$routes,$tsources) = ($EODReturnCode,'','');
	local($outCnt,$s) = (0,'');

    $routes = '' x 1200000;
	print STDERR "\nGetAllRoutes1: sources '$sources'\n" if $opt_d;

	if ( $sources eq "IRR" ) {
		$tsources = $ALLLOOK;
	}
	else {
		$tsources = $sources;
	}

    foreach $s (split(/\s+/,$tsources)) {
		if ( !open(ALLROUTESFILE,"$DBIPath/$s-ROUTES") ) {
            $routes =  "Couldn't open $DBIPath/$s-ROUTES for fetching route list!";
			$rc = $ErrorReturnCode;
			last;
        }
        else {
			while ( <ALLROUTESFILE> ) {	# get first one, without leading blank
				chop;
   				$routes .= substr($_,1);
				last;
			}
			while ( <ALLROUTESFILE> ) {
				chop;
   				$routes .= "$_";
			}
			close ALLROUTESFILE;
		}
	}

	return( $rc, $routes );

}

# slow version:
#
#			while ( <ALLROUTESFILE> ) {
#				chop;
#				if ( $outCnt % 19 == 0 ) {
#					$routes .= "$_";
#				}
#				else {
#					$routes .= "$_";
#				}
#			}
#

#
# wed 22 mar 95:
# this version is much faster, by not doing counting and most
# important, just returning and writing one big long line.
#

sub GetAllRoutes {
	local($sources,*dbfiles) = @_;
	local($dbfile,@tdbfiles,$wd);
	local($rc,$routes) = ($EODReturnCode,'');
	local($outCnt) = 0;

    $routes = '' x 1200000;

	print STDERR "\nGetAllRoutes: sources '$sources'\n    dbfiles: '@dbfiles'\n" if $opt_d;

	if ( $sources ) {
		if ( $sources eq "IRR" ) { # special case: union of all in ALLLOOK
			foreach $s ( split(/\s+/,$ALLLOOK )) {
				push(@tdbfiles,$DBFILE{$s});
			}
		}
		else {
			foreach $s ( split(/,/, $sources )) {
				push(@tdbfiles,$DBFILE{$s});
			}
		}
	}
	else {
		@tdbfiles = (@dbfiles);
	}
	
    foreach $dbfile (@tdbfiles) {
        if ( !open(DBFILE, $dbfile) ) {
            $routes = "Couldn't open $dbfile for fetching route list!";
			$rc = $ErrorReturnCode;
			last;
        }
        print STDERR "\nbegin reading fromfile $dbfile:" if $opt_d;
        $start = (times)[0];
		local($netCnt,$wdCnt) = (0,0);
        while ( <DBFILE> ) {
            chop;
            if ( /^\*rt:\ *(.*)$/ ) {
#				++$netCnt;
                $route = $1;
				$wd = 0;
#                local($origin,$comm,$netlist,$country) = ('','','','','');
                while ( <DBFILE> ) {    # now look for end of object or AS (origin) attribute
                    chop;
                    last if ( /^\ *$/ );
#                    if ( /^\*or:\ *(.*)$/ ) {
#                        $origin = $1;
#                    }
#                    elsif ( /^\*cl:\ *(.*)$/ ) {
#                        $comm = $1;
#                    }
#                    elsif ( /^\*cy:\ *(.*)$/ ) {
#                        $country = $1;
#                    }
#                    elsif ( /^\*av:\ *AS690(\ *aslist)*\ *(.*)$/ ) {
#                        $netlist = $2;
#                    }
					if ( /^\*wd:\ *(.*)$/ ) {
#						$wdCnt++;
						$wd = 1;  # could speed this by skipping to end-of-object...
					}
                }
				if ( !$wd ) {
#					$outCnt++;
#					if ( $outCnt % 19 == 0 ) {
#						$routes .= "$route \n";
#					}
#					else {
						$routes .= "$route ";
#					}
				}
            }
#            print STDERR "." if ( $opt_d && $netCnt % 500 == 499 );
        }
        close(DBFILE);
        if ( $opt_d ) {
            $end = (times)[0];
            printf STDERR "\nDone reading all $netCnt (less $wdCnt wd) routes (took %.2f CPU seconds).\n", $end - $start; 
        }
    }

	return( $rc, $routes );

}

