File Coverage

blib/lib/Ph.pm

Criterion	Covered	Total	%
statement	117	188	62.2
branch	20	56	35.7
condition			n/a
subroutine	19	26	73.0
pod	15	16	93.7
total	171	286	59.7

#
# Ph.pm - a module for talking to CCSO Ph servers
#
# Copyright 1995-1998, Garrett D'Amore.
# See the Artistic License for licensing details and use
# agreements.
#
# Important: READ THE Artistic FILE -- it limits my liability
# and provids the specific agreements to which you must agree
# if you use this package.
#
package Ph;

use strict;
use vars qw($VERSION $DefaultPhPort $DefaultPhServer @ISA);

$VERSION = '2.01';
@ISA = qw();

require 5.003;

use IO::Socket;
use Carp;

$DefaultPhPort = "ns(105)";
$DefaultPhServer = "ns";

sub new
{
    my ($class, %arg) = @_;
    return bless \%arg, $class;
}

sub Add
{
    my $self = shift;
    my $entry = shift;
    my $request = "add";

    $request .= $self->_MakeFieldsLine($entry);
    $self->_SendRequest($request);

    return $self->_IsSuccessful($self->_GetCode());
}

sub Change
{
    my $self = shift;
    my ($query,$changes) = @_;
    my $request = "change ";

    $request .= $self->_MakeFieldsLine($query);
    $request .= " make";
    $request .= $self->_MakeFieldsLine($changes);

    $self->_SendRequest($request);

    return $self->_IsSuccessful($self->_GetCode());
}

sub Connect
{
    my $self = shift;
    my $code;
    my ($PhServer, $PhPort) = @_;
    if (!defined $PhServer)
    {
	$PhServer = $DefaultPhServer;
    }
    if (!defined $PhPort)
    {
	$PhPort = $DefaultPhPort;
    }

    my $sock = IO::Socket::INET->new(PeerAddr	=> $PhServer,
				     PeerPort	=> $PhPort,
				     Proto	=> 'tcp');

    if (!defined $sock)
    {
	$self->{last_message} = $@;
	$self->{last_message} =~ s/^IO::Socket::INET/connect/;
	$self->{last_code} = 998;
	return 0;
    }

    # make socket unbuffered, this is the default under 5.004_04
    $sock->autoflush;
    $self->{sock} = $sock;

    # send id -- we send our UNIX account name -- this is not
    # strictly required but it is polite
    $self->_SendRequest("id $<");
    $code = $self->_GetCode();

    if (!$self->_IsSuccessful($code))
    {
	return 0;
    }

    # get the database status
    $self->_SendRequest("status");
    return $self->_IsSuccessful($self->_GetCode());
}

sub Delete
{
    my $self	= shift;
    my $entry	= shift;
    my $request = "delete";

    $request .= $self->_MakeFieldsLine($entry);
    $self->_SendRequest($request);

    return $self->_IsSuccessful($self->_GetCode());
}

sub Disconnect
{
    my $self = shift;
    my $code;
    if (defined $self->{sock})
    {
	$self->_SendRequest("quit");
	# we don't care about the value, we just throw it away
	$self->_GetCode();
	close($self->{sock});
	delete $self->{sock};
    }
}

sub ErrorMessage
{
    my $self = shift;
    my $code = shift;

    my %messages =  (
	100	=>     'In progress (general).',
	101	=>     'Echo of current command.',
	102	=>     'Count of number of matches to query.',
	200	=>     'Success (general).',
	201	=>     'Database ready, but read only.',
	300	=>     'More information (general).',
	301	=>     'Encrypt this string.',
	400	=>     'Temporary error (general).',
	401	=>     'Internal database error.',
	402	=>     'Lock not obtained within timeout period.',
	475	=>     'Database unavailable; try later.',
	500	=>     'Permanent error (general).',
	501	=>     'No matches to query.',
	502	=>     'Too many matches to query.',
	503	=>     'Not authorized for requested information.',
	504	=>     'Not authorized for requested search criteria.',
	505	=>     'Not authorized to change requested field.',
	506	=>     'Request refused; must be logged in to execute.',
	507	=>     'Field does not exist.',
	508	=>     'Field is not present in requested entry.',
	509	=>     'Alias already in use.',
	510	=>     'Not authorized to change this entry.',
	511	=>     'Not authorized to add entries.',
	512	=>     'Illegal value.',
	513	=>     'Unknown option.',
	514	=>     'Unknown command.',
	515	=>     'No indexed field in query.',
	516	=>     'No authorization for request.',
	517	=>     'Operation failed because database is read only.',
	518	=>     'Too many entries selected by change command.',
	520	=>     'CPU usage limit exceeded.',
	521	=>     'Change command would have overridden existing field, and the "addonly" option is on.',
	522	=>     'Attempt to view "Encrypted" field.',
	523	=>     'Expecting "answer" or "clear"',
	524	=>     'Names of help topics may not contain "/".',
	598	=>     'Command unknown.',
	599	=>     'Syntax error.',
        995	=>     '[socket failure]',
        996	=>     '[bind failure]',
	997     =>     '[unknown host]',
        998	=>     '[connection failure]',
	999	=>     '[connection closed]'
	);
    return $messages{$code};
}

sub Fields
{
    my $self = shift;
    my %result = ();
    my $name;
    my $code;

    # get the field descriptions
    $self->_SendRequest("fields");
    do
    {
	my @response = $self->_ParseResponse($self->_GetResponse());
	$code = $response[0];
	$name = $response[2];
	# second line is just the description
	if (defined $result{$name})
	{
	    $result{$name}->{desc} = $response[3];
	}
	# first line contains the good stuff
	else
	{
	    my $flag;
	    my @flags = split(/\s+/, $response[3]);

	    $result{$name} = {};
	    $result{$name}->{number} = $response[1];
	    $result{$name}->{name} = $name;

	    foreach $flag (@flags)
	    {
		if ($flag =~ /^\d+$/)
		{
		    $result{$name}->{max} = $flag;
		}
		elsif ($flag eq 'max')
		{
		    # nop
		}
		else
		{
		    $result{$name}->{$flag} = $flag;
		}
	    } # foreach $flag
	} # defined $result{$name}, i.e. end of field description
    } while ($code < 200);
    return ($self->_IsSuccessful($code)) ? %result : undef;
}

sub _IsSuccessful
{
    my $self = shift;
    my $code = shift;
    return (int($code / 100) == 2);
}

sub _GetCode
{
    my $self = shift;
    my $code;
    do
    {
	my @result = $self->_ParseResponse($self->_GetResponse());
	$code = $result[0];
    } while ($code < 200);
    return $code;
}

sub _GetResponse
{
    my $self = shift;
    my $sock = $self->{sock};
    my $response;

    if (!defined $sock)
    {
	$response="999: [no active connection]\n";
    }
    else
    {
	$response = $sock->getline();
    }

    if (!defined $response)
    {
	$response="999: [connection closed]\n";
	delete $self->{sock};
    }
    chomp $response;
    print STDERR "server> $response\n" if ($self->{Debug});
    return $response;
}

sub GetLastCode
{
    my $self = shift;
    return $self->{last_code};
}

sub GetLastMessage
{
    my $self = shift;
    return $self->{last_message};
}

sub IsConnected
{
    my $self = shift;
    return defined($self->{sock});
}

sub Login
{
    my $self = shift;
    my ($alias, $password) = @_;
    my ($code, $challenge, $answer);

    $self->_SendRequest("login $alias");

    $code = $self->_GetCode();

    # abort if we were not challenged!
    return 0 if $code != 301;

    #
    # unfortunately, I don't know how to answer the challenge
    # Dorner's code is *very* hard to understand!  But if we
    # ever figure it out, here's where we'll put the challenge
    # response.
    #

    # so for now we send the password in the clear (blech!)
    $self->_SendRequest("clear $password");

    # overwrite password to minimize exposure; not sure if
    # this really helps with perl
    $password = "xxxxxxxxxxxxxx";

    return $self->_IsSuccessful($self->_GetCode());
}

sub Logout
{
    my $self = shift;

    $self->_SendRequest("logout");
    return $self->_IsSuccessful($self->_GetCode());
}

sub _MakeFieldsLine
{
    my $self	= shift;
    my $fields	= shift;
    my ($output, $field);

    $output = "";

    if (ref($fields) eq 'HASH')
    {
	foreach $field (keys %$fields)
	{
	    $fields->{$field} =~ s/"/\\"/;
	    $output .= " $field=\"$fields->{$field}\"";
	}
    }
    elsif (ref($fields) eq 'ARRAY')
    {
	foreach $field (@$fields)
	{
	    $output .= " $field";
	}
    }
    else
    {
	$output = " $fields";
    }
    return $output;
}

sub _ParseResponse
{
    my $self = shift;
    my $unparsed = shift;
    my @parsed = split(/: */, $unparsed, 4);
    $self->{last_code} = $parsed[0];
    $self->{last_message} = $parsed[1];
    return @parsed;
}

sub Query
{
    my $self = shift;
    my ($query, $fieldlist) = @_;
    my ($key, $request, $index, @response, $lastfield, $code, $field, $value);
    my @matches = ();

    $index = 0;

    $request = "query";
    $request .= $self->_MakeFieldsLine($query);
    if (defined ($fieldlist))
    {
	$request .= " return";
        $request .= $self->_MakeFieldsLine($fieldlist);
    }
    $self->_SendRequest($request);

    do
    {
	@response = ();
	@response = $self->_ParseResponse($self->_GetResponse());
        $code = $response[0];
        if (defined $response[3])
	{
	    $index = $response[1] - 1;
	    $field = length($response[2]) ? $response[2] : $lastfield;
	    $lastfield = $field;
	    $value = $response[3];

	    if (!defined $matches[$index])
	    {
		$matches[$index] = { };
	    }

	    if (!defined $matches[$index]->{$field} )
	    {
		$matches[$index]->{$field} = '';
	    }
	    else
	    {
		$matches[$index]->{$field} .= "\n";
	    }

	    $matches[$index]->{$field} .= $value;
	}
    } while ($code < 200);
    return $self->_IsSuccessful($code) ? @matches : undef;
}

sub _SendRequest
{
    my $self = shift;
    my $request = shift;
    my $sock = $self->{sock};
    if (!defined $sock)
    {
	print STDERR "client> [connection not open]\n" if $self->{Debug};
    }
    elsif (print $sock "$request\r\n")
    {
    	print STDERR "client> $request\n" if $self->{Debug};
    }
    else
    {
	print STDERR "client> [connection closed]\n" if $self->{Debug};
	delete $self->{sock};
    }
}

sub SiteInfo
{
    my $self = shift;
    my %results;
    my $code;
    $self->_SendRequest("siteinfo");
    do
    {
	my @response = $self->_ParseResponse($self->_GetResponse());
	if ($response[2])
        {
	    $results{$response[2]} = $response[3];
	}
	$code = $response[0];
    } while ($code < 200);

    return $self->_IsSuccessful($code) ? %results : undef;
}

sub Version
{
    return $VERSION;
}
1;

__END__