# refer.pl - code for referred queries
#
# Copyright (c) 1993, 1994, 1995, 1996, 1997, 1998, 1999 by RIPE NCC
#
# All Rights Reserved
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted,
# provided that the above copyright notice appear in all copies and that
# both that copyright notice and this permission notice appear in
# supporting documentation, and that the name of the author not be
# used in advertising or publicity pertaining to distribution of the
# software without specific, written prior permission.
#
# THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
# ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS; IN NO EVENT SHALL
# AUTHOR BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY
# DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN
# AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
#
# $Id: refer.pl,v 2.6 2000/03/14 10:19:43 engin Exp $
#
#       $RCSfile: refer.pl,v $
#       $Revision: 2.6 $
#       $Author: engin $
#       $Date: 2000/03/14 10:19:43 $

# Sees if the object has a refer attribute.
# If no just return
# If yes, make a whois query and substitue the value obtained
# Include a Warning message

require "dpr.pl";

sub has_refer {

    local($name, $rhost, $domain, %object) = @_;
    my($msg, $query, $message);
    $referral = 0;
    @referral = undef;
    %referral = %object;

    &dpr("\%object = " . join("*", %object) . "\n");
    &dpr("global \$name = $name, \$rhost = $rhost\n");

    # If the query has the -R option, don't do referral
    return \$referral, \@referral, \%referral if ($opt_R);

    if (defined $object{"rf"}) {
	$referral = 1;
	%referral = undef;
	($type,$host,$port)= split /\s+/, $object{"rf"};
        # Default port is 43
	$port = 43 if (!$port);
	$REFERHOST = $host;
        $REFERPORT = $port;
	if ($host eq $rhost || $host eq $name) {
	    # referral loop
	    &dpr("referral loop detected\n");
	    &ReplaceGlobalVars(*REFERRALLOOPERRORTXT);
	    @message = split(/\n+/,$REFERRALLOOPERRORTXT);
	    return \$referral, \@message, \%referral;
	}

	&dpr("Querying referred host $host:$port. Type = $type\n");

#       initially I thought that I should refer query for the 
#       domain object containing refer field (which can be stripped 
#       down up to top level domain:

#	$query = $object{'dn'};

#       but all other seem to prefer other solution - to refer the 
#       original query (not stripped down). Specification was 
#       unclear about this though.
#       However if we have inverse query we should ask remote server
#       for domain name of object containing referral

	$query = (($opt_i) ? $object{'dn'} : $domain);

#       do not pass -F to ripe servers - we now treat ripe servers 
#       in exactly the same way as other server types
#	$query = "-F " . $query if ($type =~ /ripe/i);

	$query = "-r " . $query 
	    if ($type =~ /ripe/i and ($opt_r or $opt_i));

#       If the type of the query is "clientaddress", then 
#       we must send the IP address of the client too. This
#       is done using -V flag. 
#	$query = "-V$::RIPEConfig{VERSION},$rhost " . $query 
#	    if ($type =~ /clientaddress/i);
	if($type =~ /clientaddress/i){
           if(defined($clientIP)){
             $query = "-V$::RIPEConfig{VERSION},$clientIP " . $query;
           }else{
             $query = "-V$::RIPEConfig{VERSION},$rhost " . $query;
           }
        }


	$REFERQUERY = $query;
	&dpr("Query: $query\n");

#       set up timeout and error handling environment for initialising 
#       whois connection to the remote server

	my($handler_ref) = $SIG{'ALRM'};
	$SIG{'ALRM'} = sub {die "REFERRAL TIMEOUT";};
	eval {
	    alarm($REFERRALTIMEOUT);
	    $msg = &initwhoisqry($host, $port, $query);
	    alarm(0);
	};

	$SIG{'ALRM'} = $handler_ref;
	if ($@ =~ /REFERRAL TIMEOUT/) {
	    &dpr("Timeout while initialising connection\n");
	    &ReplaceGlobalVars(*REFERRALTIMEOUTTXT);
	    @message = split(/\n+/,$REFERRALTIMEOUTTXT);
	    return \$referral, \@message, \%referral;
	}

	if ($msg) {
	    &dpr("Connection failed with: $msg\n");
	    $REFERMSG = $msg;
	    &ReplaceGlobalVars(*REFERRALERRORTXT);
	    @message = split(/\n+/,$REFERRALERRORTXT);
	    return \$referral, \@message, \%referral;
	}

#       set up timeout and error handling environment for reading
#       from the remote server

	my(@response);
	my($truncated) = 0;

	$handler_ref = $SIG{'ALRM'}; 
	$SIG{'ALRM'} = sub {die "REFERRAL TIMEOUT";};

	eval {
	    alarm($REFERRALTIMEOUT);
	    while (<WHOIS_S>) {
		if (push(@response, $_) > $REFERRALMAXLINES) {
		    $truncated = 1;
		    last;
		}
	    }
	    alarm(0);
	};

	$SIG{'ALRM'} = $handler_ref;
	if ($@ =~ /REFERRAL TIMEOUT/) {
	    &dpr("Timeout while reading from remote server\n");
	    &ReplaceGlobalVars(*REFERRALTIMEOUTTXT);
	    @message = split(/\n+/,$REFERRALTIMEOUTTXT);
	    return \$referral, \@message, \%referral;
	}

	if ($truncated) {
	    &dpr("Remote response truncated\n");
	    &ReplaceGlobalVars(*REFERRALTRUNCTXT);
	    @message = split(/\n+/,$REFERRALTRUNCTXT);
	}

	close(WHOIS_S);

	map(chomp, @response);

#       do not differentiate between RIPE and other server types

#	if ($type =~ m/ripe/i) {
#	    foreach (@referral) {
#                # Skip the header
#		#print "read: $_\n";
#		next if (/^$/ || /^%/);
#		($attr,$value) = split /\s+/,$_,2;
#                #print "attr: $attr, value: $value\n";
#		$attr = substr $attr,1,2;
#                #print "attr: $attr, value: $value\n";
#		$referral{$attr} .= $value."\n";
#	    }
#	    @referral = ();
#	}


	&ReplaceGlobalVars(*REFERRALTXT);
	my(@header)  = split(/\n+/, $REFERRALTXT);
	&ReplaceGlobalVars(*REFERRALENDTXT);
	my(@footer)  = split(/\n+/, $REFERRALENDTXT);

#       at this point: 
#           @message may be empty or contain truncation message
#           @header contains standard referral header text 
#           @footer contains standard ending text
#           @response contains remote server answer
#       let's construct @referral which is to be printed

#	&dpr("\@header = |", join("*", @header), "|\n");
#	&dpr("\@message = |", join("*", @message), "|\n");
#	&dpr("\@response = |", join("*", @response), "|\n");
#	&dpr("\@footer = |", join("*", @footer), "|\n");

	push(@referral, @header);
	push(@referral, @message);
	push(@referral, "");
	push(@referral, @response);
	push(@referral, @footer);

    }

    &dpr("\$referral = $referral; \@referral = " . join("*", @referral) .
	 "\%referral = " . join("*", %referral) . "\n");

    return \$referral, \@referral, \%referral;
}


1;
