Alvis-Saa

 view release on metacpan or  search on metacpan

README  view on Meta::CPAN

   perl Makefile.PL
   make
   make test
   make install

DEPENDENCIES

This module requires these other modules and libraries:

	IO::Socket
	Data::Dumper (only if you uncomment debugging)
	Sys::Hostname
	IO::Select
        Fcntl

COPYRIGHT AND LICENCE

Put the correct copyright and licence information here.

Copyright (C) 2006 by Antti Tuominen, Kimmo Valtonen

lib/Alvis/Saa.pm  view on Meta::CPAN

use Alvis::Tana;

# use Data::Dumper;
use Sys::Hostname;
use IO::Socket;
use IO::Select;
use Fcntl;

my $LOCALADDR_PREFIX = "/var/tmp/searchrpc_localsoc_";
my $debug = 0;

######################################################################
#
#  Public methods
#
###################################################################

sub new
{
    my ($this) = @_;

lib/Alvis/Saa.pm  view on Meta::CPAN

    my $conn = undef;
# local socket handling is fundamentally broken, a saa-redesign is needed
#    if($this->{'my_addr'} eq $addr) # try domain socket first
#    {
#	$conn = IO::Socket::UNIX->new(Peer => "$LOCALADDR_PREFIX$port",
#				      Type => SOCK_STREAM,
#				      Timeout => 10);
#    }
    if(!defined($conn))
    {
#	$debug && print STDERR "Saa::connect(): domain socket $LOCALADDR_PREFIX$port failed with $!, trying inet\n";
	if(!($conn = IO::Socket::INET->new(PeerAddr => $host,
					   PeerPort => $port,
					   Proto => "tcp",
					   Type => SOCK_STREAM)))
	{
	    $debug && print STDERR "Saa::connect(): tcp connect failed with $@\n";
	    $this->{'err'} = "$@";
	    return 0;
	}
    }
    else
    {
	$debug && print STDERR "Saa::connect(): Successfully opened localsoc!\n";
    }

    binmode($conn, ":raw");

    $cn->{'conn'} = $conn;
    $this->{'conn_sel'}->add($conn);
    $this->{'conns'}->{"${host}_$port"} = $cn;

    return 1;
}

lib/Alvis/Saa.pm  view on Meta::CPAN

	    ($port, $iaddr) = sockaddr_in($sockaddr);
	    $str_ip = inet_ntoa($iaddr);
#	    print STDERR "Saa: accept found port $port and ip $str_ip\n";
#	}
#	else # AF_UNIX
#	{
#	    my $sn = $client->sockname();
#	    $sn =~ /$LOCALADDR_PREFIX([0-9]+)/;
#	    $port = $1;
#	    $str_ip = inet_ntoa($this->{'my_addr'});
#	    $debug && print STDERR "Saa::process_accept(): AF_UNIX connection with ip $str_ip port $port\n";
#	}

	my $cn = 
	{
	    'host' => $str_ip,
	    'port' => $port,
	    'conn' => $client,
	    'lport' => $serv->{'port'},
	};

lib/Alvis/Saa.pm  view on Meta::CPAN

		$entry->{'arb'} = $arb;
	    }
	}
	
	if($cn->{'callback'})
	{
	    my $cb = $cn->{'callback'};
	    my $func = undef;
	    my @param = ();
	    
	    $debug && print STDERR "Callback = ", ref($cb), "\n";
	    if(ref($cb) eq 'CODE')
	    {
		$func = $cb;
	    }
	    else
	    {
		@param = @$cb;
		$func = shift(@param);
	    }
	    $debug && print STDERR "Func cb ref = ", ref($func), "\n";
	    $func->($this, $entry, @param);
	}
	else
	{
	    push(@$received, $entry);
	}
    }

    return (1, 0);
}

lib/Alvis/Tana.pm  view on Meta::CPAN

package Alvis::Tana;

$Alvis::Tana::VERSION = '0.1';

# use Data::Dumper;

use strict;

my %ERROR;
my $debug = 0;

######################################################################
#
#  Public methods
#
###################################################################

sub error($)
{
    my ($client) = @_;

lib/Alvis/Tana.pm  view on Meta::CPAN

    my $got = 0;
    my $num = '';
    my $char = '0';

    while($char =~ /[0-9]/)
    {
	my $bytes = CORE::sysread($client, $char, 1);
	if($bytes != 1)
	{
	    $ERROR{$client} = "Readnum error: $@";
	    !$debug || print STDERR "readnum: $ERROR{$client}\n";
	    return undef;
	}

	if($char =~ /[0-9]/)
	{
	    $num .= $char;
	    $got++;
	}
    }

    if($char =~ /[^\n ]/)
    {
	$ERROR{$client} = "Non-eol/space at end of number. Got '$char' instead.";
	!$debug || print STDERR "readnum: $ERROR{$client}\n";
	return undef;
    }
    if(0 == $got)
    {
	$ERROR{$client} = "No numbers in readnum, got '$char' instead.";
	!$debug || print STDERR "readnum: $ERROR{$client}\n";
	return undef;	
    }

#    warn "Alvis::Tana::readnum() read num $num";
    
    return $num;
}

sub readbytes($$)
{
    my ($client, $len) = @_;

    my $str = '';


    my $got = CORE::sysread($client, $str, $len);
#    if($len != $got)
#    {
#	warn "Alvis::Tana::readbytes(): Wanted $len bytes, got $got";
#	$ERROR{$client} = "Wanted $len bytes, got $got";
#	!$debug || print STDERR "readnum: $ERROR{$client}\n";
#	return undef;
#    }

#    warn "Alvis::Tana::readbytes(): read $str";
    
    return ($str,$got);
}

sub read_field_header($)
{
    my ($client) = @_;

    my $keylen = readnum($client);
    if(!defined($keylen))
    {
	!$debug || print STDERR "read: $ERROR{$client}\n";
	return (undef, undef);
    }
    !$debug || print "keylen = *$keylen*\n";
    
    my ($key,$got) = readbytes($client, $keylen);
    if(!defined($key))
    {
	!$debug || print STDERR "read: $ERROR{$client}\n";
	return (undef, undef);
    }
    !$debug || print "key = $key\n";
    
    my $dummy;
    ($dummy,$got)=readbytes($client, 2);
    if(!defined($dummy))
    {
	!$debug || print STDERR "read: $ERROR{$client}\n";
	return (undef, undef);
    }
    
    return ($keylen, $key);
}

sub read
{
    my ($client, $autoread_arb) = @_;

lib/Alvis/Tana.pm  view on Meta::CPAN

    my $fieldc = readnum($client);
    if(!defined($fieldc))
    {
	return undef;
    }
    
    if(($mtype ne 'arb') && ($mtype ne 'fix'))
    {
	$ERROR{$client} = "Invalid message type '$mtype'";
	!$debug || print STDERR "read: $ERROR{$client}\n";
	return undef;
    }

    my $read_arb = 1;
    if(defined($$autoread_arb))
    {
	if(! $$autoread_arb)
	{
	    $read_arb = 0;
	}

lib/Alvis/Tana.pm  view on Meta::CPAN

#	warn "Alvis::Tana::read(): keylen:$keylen key: $key";

	if(!defined($keylen))
	{
	    return undef;
	}

	my $len = readnum($client);
	if(!defined($len))
	{
	    !$debug || print STDERR "read: $ERROR{$client}\n";
	    return undef;
	}
	!$debug || print "len = $len\n";

	my $value = '';
	my $gotten_so_far=0;
	if($len > 0)
	{
	    while ($gotten_so_far<$len)
	    {
#		warn "before reading to get ",$len-$gotten_so_far," bytes";
		my ($value_piece,$got) = readbytes($client, 
						   $len-$gotten_so_far);
		if(!defined($value_piece))
		{
		    !$debug || print STDERR "read: $ERROR{$client}\n";
		    return undef;
		}
		!$debug || print "value = $value_piece\n";
		
#		warn "after reading $got bytes. Value:$value_piece";
		
		$gotten_so_far+=$got;
		$value.=$value_piece;
	    }	    

	    my ($dummy,$got)=readbytes($client, 1);
	    if(!defined($dummy))
	    {
		!$debug || print STDERR "read: $ERROR{$client}\n";
		return undef;
	    }
	}
	
	$msg->{$key} = $value;
    }

    if(($mtype eq 'arb') && (!$read_arb))
    {
	my ($keylen, $key) = read_field_header($client);

	if(!defined($keylen))
	{
	    return undef;
	}

	!$debug || print STDERR "Alvis::Tana::read() set autoread_arb to -$key-\n";
	$$autoread_arb = $key;
    }
    elsif(defined($autoread_arb))
    {
	$$autoread_arb = undef;
    }

    return $msg;
}

lib/Alvis/Tana.pm  view on Meta::CPAN

    $$eof = 0;

    while($len > 0)
    {
	my $char;
	my $got = CORE::sysread($client, $char, 1);

	if(1 != $got)
	{
	    $ERROR{$client} = "Wanted 1 bytes, got $got";
	    !$debug || print STDERR "read_arb: $ERROR{$client}\n";
	    return undef;
	}

	!$debug || print STDERR "Read arb '$char'\n";
	if($char eq "\\")
	{
	    $got = CORE::sysread($client, $char, 1);
	    if(1 != $got)
	    {
		$ERROR{$client} = "Wanted 1 bytes, got $got";
	    !$debug || print STDERR "read_arb: $ERROR{$client}\n";
		return undef;
	    }

	    !$debug || print STDERR "Read arb '$char'\n";
	    if($char eq 'n')
	    {
		$str .= "\n";
	    }
	    elsif($char eq "\\")
	    {
		$str .= "\\";
	    }
	    else
	    {
		$ERROR{$client} = "Invalid escaped char '$char' after '\\'";
		!$debug || print STDERR "read_arb: $ERROR{$client}\n";
		return undef;
	    }
	}
	elsif($char eq "\n")
	{
	    $$eof = 1;
	    last;
	}
	else
	{

lib/Alvis/Tana.pm  view on Meta::CPAN

}


sub write_arb($$$)
{
    my ($client, $str, $final) = @_;

    while(length($str) > 0)
    {
	$str =~ s/(.)(.*)/$2/s;
	!$debug || print STDERR "Sending arb '$1'\n";
	if($1 eq "\\")
	{
	    my $out = "\\\\";
	    if(length($out) != CORE::syswrite($client, $out, length($out)))
	    {
		$ERROR{$client} = "write to socket failed: $@";
		return 0;
	    }
	}
        elsif($1 eq "\n")