asused 3.72-12 / usr / share / perl5 / Whois.pm

# Copyright (c) 2000                    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.

#------------------------------------------------------------------------------
# Module Header
# Filename          : Whois.pm
# Purpose           : Make whois queries
# Author            : Timur Bakeyev <timur@ripe.net>
# Date              : 08082000
# Description       : General purpose, simple client to make whois queries
# Language Version  : Perl5
# OSs Tested        : BSD/OS 3.1
# Command Line      : None
# Input Files       : None
# Output Files      : None
# External Programs : None
# Problems          : None known
# To Do             : Make more consistent(?)
# Comments          :
# $Id: Whois.pm,v 1.8 2001/08/28 14:04:33 timur Exp $
#------------------------------------------------------------------------------
package Whois;

use strict;
use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
use vars qw($ERRORSTRING $ERRORCODE);

require Exporter;

@ISA = qw(Exporter); 
# External modules
use IO::Socket;
# Error handling
use Carp;

use vars qw(
        $WHOIS_TIMEOUT
	$WHOIS_NO_ENTRY
        $WHOIS_UNKNOWN_QUERY
	$REQUEST_IGNORED
        $HOST_CONNECT_ERROR
	$NO_RESPONSE_FROM_SOCKET
        $CONNECTION_CLOSED
	$ERROR_WRITING_SOCKET
        $NO_RESULT
	$EMPTY_QUERY
        $SOCKET_ERROR
	$NO_HOST_PASSED
        $NO_PORT_PASSED
);

# Error codes
use vars qw(%ERROR);
	
@EXPORT = ();

@EXPORT_OK = qw(%WHOIS_ERROR %ERROR);

%EXPORT_TAGS = (
    'ERROR_CODES' => [qw(
        $WHOIS_TIMEOUT
	$WHOIS_NO_ENTRY
        $WHOIS_UNKNOWN_QUERY
	$REQUEST_IGNORED
        $HOST_CONNECT_ERROR
	$NO_RESPONSE_FROM_SOCKET
        $CONNECTION_CLOSED
	$ERROR_WRITING_SOCKET
        $NO_RESULT
	$EMPTY_QUERY
        $SOCKET_ERROR
	$NO_HOST_PASSED
        $NO_PORT_PASSED
    )]
);

Exporter::export_ok_tags('ERROR_CODES');

$VERSION = '1.04';

#6xx  Other software/system errors
$WHOIS_TIMEOUT		= 602;
$WHOIS_NO_ENTRY		= 603;
$WHOIS_UNKNOWN_QUERY	= 604;
$REQUEST_IGNORED	= 605;
$HOST_CONNECT_ERROR	= 622;
$NO_RESPONSE_FROM_SOCKET= 623;
$CONNECTION_CLOSED	= 624;
$ERROR_WRITING_SOCKET	= 625;
$NO_RESULT		= 626;
$EMPTY_QUERY		= 627;
$SOCKET_ERROR		= 628;
$NO_HOST_PASSED		= 629;
$NO_PORT_PASSED		= 630;

# List of error messages, that correspond to error codes
%ERROR = (
    $NO_RESULT		=> 'No results were returned',
    $NO_HOST_PASSED	=> 'No hostname was passed',
    $NO_PORT_PASSED	=> 'No port was passed',
    $WHOIS_TIMEOUT	=> 'Timeout',
    $WHOIS_NO_ENTRY	=> 'No such entry in the database',
    $WHOIS_UNKNOWN_QUERY=> 'Unknown type of the query',
    $CONNECTION_CLOSED	=> 'Connection closed by foreign host',
    $EMPTY_QUERY	=> 'Query is empty',
);


# Global error variables, work ONLY for constructor
$ERRORSTRING = '';
$ERRORCODE = 0;

# http://www.ripe.net/ripencc/pub-services/db/rpsl/errors.html

# %ERROR:101: no entries found
# %ERROR:102: unknown source
# %ERROR:103: unknown object type
# %ERROR:104: unknown attribute
# %ERROR:105: attribute is not searchable
# %ERROR:106: no search key specified
# 
# %ERROR:201: access denied
# %ERROR:202: access control limit reached 
# %ERROR:203: address passing not allowed
# %ERROR:204: maximum referral lines exceeded
# 
# %ERROR:301: connection has been closed
# %ERROR:302: referral timeout
# %ERROR:303: no referral host
# %ERROR:304: referral host not responding
# 
# %ERROR:401: invalid range: Not within <first>-<last> 
# %ERROR:402: not authorized to mirror the database 
# %ERROR:403: unknown source 


# Default values for the object
my %default = (
    'Port'	=> 'whois(43)',	# Default whois port
    'Timeout'	=> 5,		# Connection timeout
    'Retry'	=> 3,		# Retry count
    'Debug'	=> 0		# Debuging
);

####################################################################
#  DESCRIPTION: Show debug message, if debugging is on
#        INPUT: Debug message
#       OUTPUT: None
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub debug {
    my $self = shift;
    my(@dbgString) = @_;
    
    if($self->{'Debug'}) {
	print STDERR @dbgString, "\n";
    }
}

####################################################################
#  DESCRIPTION: Set an error code and string and return code
#        INPUT: Error code, error string
#       OUTPUT: Error code
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub error {
    my $self = shift;
    my($errCode, $errString) = @_;
    
    $self->{'ErrorString'} = $errString;
    $self->{'ErrorCode'} = $errCode;
    
    if(wantarray()) {
	return ($self->{'ErrorCode'}, $self->{'ErrorString'});
    }
    else {
	return $self->{'ErrorCode'};
    }
}

####################################################################
#  DESCRIPTION: Retrive current error
#        INPUT: None
#       OUTPUT: Last error string
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub GetError {
    my $self = shift;
    
    if(wantarray()) {
	return ($self->{'ErrorCode'}, $self->{'ErrorString'});
    }
    else {
	return $self->{'ErrorCode'};
    }
}

####################################################################
#  DESCRIPTION: Retrive current error code
#        INPUT: None
#       OUTPUT: Last error string
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub GetErrorCode {
    my $self = shift;
    
    return $self->{'ErrorCode'};
}

####################################################################
#  DESCRIPTION: Retrive current error code
#        INPUT: None
#       OUTPUT: Last error string
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub GetErrorString {
    my $self = shift;
    
    return $self->{'ErrorString'};
}

####################################################################
#  DESCRIPTION: Clean error status
#        INPUT: None
#       OUTPUT: None
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub ClearError {
    my $self = shift;
    
    $self->{'ErrorString'} = '';
    $self->{'ErrorCode'} = 0;
}

####################################################################
#  DESCRIPTION: Create new object
#        INPUT: Hash of parameters, can be:
#		host, port, timeout, retry.
#       OUTPUT: Object
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my %param = (@_);
    my $param = '';
    my $self = { };
    
    bless $self, $class;
    
    # Clear global error variables
    $ERRORSTRING = '';
    $ERRORCODE = 0;

    # Turn debugging on if necessary
    $self->{'Debug'} = $default{'Debug'};
    
    $param = delete $param{'Debug'};
    if($param && $param =~ /^\d+$/) {
	$self->{'Debug'} = $param;
    }
    # We can override debuging switch through the environment
    if($ENV{'WHOIS_DEBUG'} && $ENV{'WHOIS_DEBUG'} =~ /^\d+$/) {
	$self->{'Debug'} = $ENV{'WHOIS_DEBUG'};
    }

    # Get server name and port
    $param = delete $param{'Host'};
    $self->{'Host'} = ($param && $param =~ /^\S+$/) ? $param : $default{'Host'};
    # We can override hostname through the environment
    if($ENV{'WHOIS_HOST'} && $ENV{'WHOIS_HOST'} =~ /^\S+$/) {
	$self->{'Host'} = $ENV{'WHOIS_HOST'};
    }
    $self->debug("Host: ", $self->{'Host'});
    
    $param = delete $param{'Port'};
    $self->{'Port'} = ($param && $param =~ /^\S+$/) ? $param : $default{'Port'};
    # We can override port through the environment
    if($ENV{'WHOIS_PORT'} && $ENV{'WHOIS_PORT'} =~ /^\S+$/) {
	$self->{'Port'} = $ENV{'WHOIS_PORT'};
    }
    $self->debug("Port: ", $self->{'Port'});
    
    # Use passed timeout if supplied
    $param = delete $param{'Timeout'};
    $self->{'Timeout'} = ($param && $param =~ /^\d+$/) ? $param : $default{'Timeout'};
    $self->debug("Timeout: ", $self->{'Timeout'});
    
    # Use passed retry count if supplied
    $param = delete $param{'Retry'};
    $self->{'Retry'} = ($param && $param =~ /^\d+$/) ? $param : $default{'Retry'};
    $self->debug("Retry count: ", $self->{'Retry'});
    
    croak("Illeagal attributes: " . join(' ', sort(keys(%param)))) if(%param);

    # Clear errors
    $self->ClearError();
    # Try to open connection and destroy object, if fail.
    if($self->Open()) {
	# Put the connection error into the global variables
	# for farther investigations of the failure
	($ERRORCODE, $ERRORSTRING) = $self->GetError();
	# No object was created
	return;
    }

    $self->debug(ref($self), " object was created");

    return $self;
}

####################################################################
#  DESCRIPTION: Open connection to whois server
#        INPUT: None
#       OUTPUT: Error code on error, 0 on success.
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub Open {
    my $self = shift;
    # Clear error
    $self->ClearError();
    # Check, that we really do have where to connect to
    return $self->error($NO_HOST_PASSED, $ERROR{$NO_HOST_PASSED})
	unless($self->{'Host'});

    return $self->error($NO_PORT_PASSED, $ERROR{$NO_PORT_PASSED})
	unless($self->{'Port'});
    
    # Retry count
    my $retry = 0;
    # Create connection
    do {
	if($retry++ > $self->{'Retry'}) {
	    return $self->error($HOST_CONNECT_ERROR, 
		sprintf("Can't connect to %s:%s after %d attempts",
		$self->{'Host'}, $self->{'Port'}, $retry));
	}
	# Delay between attempts
	sleep($retry);
	# Create connection
	$self->{'Sock'} = IO::Socket->new(
		Domain	 => AF_INET,
		PeerAddr => $self->{'Host'},
		PeerPort => $self->{'Port'},
		Proto    => 'tcp',
		Type	 => SOCK_STREAM,
		Timeout	 => $self->{'Timeout'}
		);
    
	} until($self->{'Sock'});
    # Ok
    return 0;
}

####################################################################
#  DESCRIPTION: Query whois server
#        INPUT: Query, that should be send to the server
#       OUTPUT: Error code on error, 0 on success.
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub Query {
    my $self = shift;
    # Filter out empty paramters
    my @query = grep { /\S+/ } @_;
    # Convert an array of parameters into string
    my $query = join(' ', @query);

    # Make sure we don't have trailing "\r|\n"
    if($query) {
	$query =~ s/\s*$//s;
	$query =~ s/^\s*//s;
    }

    # Clear error
    $self->ClearError();
    
    # If query is empty - fail
    return $self->error($EMPTY_QUERY, $ERROR{$EMPTY_QUERY})
	unless($query);
    
    # Store query for farther references
    $self->{'Query'} = $query;
    
    # Check, that connection exist
    unless(defined($self->{'Sock'}) && $self->{'Sock'}->opened()) {
	# Try to re-open connection
	my $error = $self->Open();
	
	$self->debug("Try to re-open connection");
	# Return, if reconnection failed
	return $error if($error);
    }

    # Make local change of input record separator
    # XXX This is RIPE specific, but, hopefuly, harmless
    local $/ = "\n\n\n";
    
    # Clear old result
    undef($self->{'Result'});
    
    # Just make shortcut to ease access
    my $sock = $self->{'Sock'};
    
    # In case of any other error also terminate
    return $self->error($SOCKET_ERROR, $sock->error())
	if($sock->error());

    $self->debug("Query: ", $self->{'Query'});
    
    # Pass a query to the server
    $sock->printf("%s\x0d\x0a", $self->{'Query'});
    
    # In case of any other error also terminate
    return $self->error($SOCKET_ERROR, $sock->error())
	if($sock->error());
    
    # Obtain results from the server
    $self->{'Result'} = $sock->getline();
    
    $self->debug("Result: ", $self->{'Result'});

    # In case of any other error also terminate
    return $self->error($SOCKET_ERROR, $sock->error())
	if($sock->error());
    
    # Close the connection
    $self->Close();
    
    # Everything is ok
    return 0;
}

####################################################################
#  DESCRIPTION: Return raw result of the query
#        INPUT: None
#       OUTPUT: Scalar with the result
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub GetResult {
    my $self = shift;
    
    return $self->{'Result'};
}

####################################################################
#  DESCRIPTION: Close connection with the whois server
#        INPUT: None
#       OUTPUT: None
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub Close {
    my $self = shift;
    
    if(defined($self->{'Sock'}) && $self->{'Sock'}->opened()) {
	$self->debug("Shutdown the connection");
	$self->{'Sock'}->shutdown(2);
	$self->{'Sock'}->close();
    }
    # Destroy socket
    undef($self->{'Sock'});
}

####################################################################
#  DESCRIPTION: Destructor for the object.
#        INPUT: None
#       OUTPUT: None
# SIDE EFFECTS: None
#       SYNTAX:	None
####################################################################
sub DESTROY {
    my $self = shift;
    
    $self->Close();
    $self->debug(ref($self), " object was destroyed");
}

1;

__END__
# Below is the stub of documentation for your module. You better edit it!

=head1 NAME

Whois - Perl extension to make queries to the whois servers

=head1 SYNOPSIS

  use Whois;
 
  $whois = new Whois('Host' => 'whois.ripe.net');
 
 die("Failed to create object") unless(ref($whois));
 
 die($whois->GetError()) if($whois->GetError());
 
 if($whois->Query("BAT-RIPE")) {
    printf("Query error: %s\n", $whois->GetError());
    exit;
 }
 
 my $result = $whois->GetResult();
 
 if($result) {
    print "$result\n";
 }
 else {
   printf("No results: %s\n", $whois->GetError());
 }
 
 $whois->Close();

=head1 DESCRIPTION

Stub documentation for Whois was created by h2xs. It looks like the
author of the extension was negligent enough to leave the stub
unedited.

Blah blah blah.

=head1 AUTHOR

Timur Bakeyev <timur@ripe.net>

=head1 SEE ALSO

perl(1).

=cut