File Coverage

blib/lib/Patro/N4.pm

Criterion	Covered	Total	%
statement	64	78	82.0
branch	13	24	54.1
condition	0	3	0.0
subroutine	24	29	82.7
pod			n/a
total	101	134	75.3

package Patro::N4;
use strict;
use warnings;

# Patro::N4. Proxy class for ARRAY type references

# we must keep this namespace very clean
use Carp ();

use overload
    '@{}' => sub {
	no overloading;
	if (${$_[0]}->{overloads}{'@{}'}) {
	    Patro::LeumJelly::deref_handler(@_,'@{}')
	} else {
	    ${$_[0]}->{array}
	}
    },
    'nomethod' => \&Patro::LeumJelly::overload_handler,
    '${}' => sub { Patro::LeumJelly::deref_handler(@_,'${}') },
    '%{}' => sub { Patro::LeumJelly::deref_handler(@_,'%{}') },
    ;

# override UNIVERSAL methods
foreach my $umethod (keys %UNIVERSAL::) {
    no strict 'refs';
    *{$umethod} = sub {
	my $proxy = shift;
	if (!CORE::ref($proxy)) {
	    package
		UNIVERSAL;
	    return &$umethod($proxy,@_);
	}
	no overloading;
	my $context = defined(wantarray) ? 1 + wantarray : 0;
	return Patro::LeumJelly::proxy_request( $$proxy,
	    { id => $$proxy->{id}, topic => 'METHOD', command => $umethod,
	      has_args => @_ > 0, args => [ @_ ], context => $context }, @_ );
    };
}

sub AUTOLOAD {
    my $method = $Patro::N4::AUTOLOAD;
    $method =~ s/.*:://;

    my $self = shift;
    my $has_args = @_ > 0;
    my $args = [ @_ ];

    my $context = defined(wantarray) ? 1 + wantarray : 0;
    no overloading;
    return Patro::LeumJelly::proxy_request( $$self,
	{ id => $$self->{id},
	  topic => 'METHOD',
	  command => $method,
	  has_args => $has_args,
	  args => $args,
	  context => $context,
	  _autoload => 1 }, @_ );
}

sub DESTROY {
    my $self = shift;
    no overloading '${}';
    if ($$self->{_DESTROY}++) {
	return;
    }
    my $socket = $$self->{socket};
    if ($socket) {
	my $response = Patro::LeumJelly::proxy_request(
	    $$self,
	    { id => $$self->{id},
	      topic => 'META',
	      command => 'destroy' } );
	if (CORE::ref($response) && $response->{disconnect_ok}) {
	    close $socket;
	    delete $$self->{socket};
	}
    }
}

############################################################

# tie class for array proxy object. Operations on the proxy object
# are forwarded to the remote server

sub Patro::Tie::ARRAY::TIEARRAY {
    my ($pkg,$proxy) = @_;
    return bless { obj => $proxy, id => $proxy->{id} }, $pkg;
}

sub Patro::Tie::ARRAY::__ {
    my $tied = shift;
    my $name = shift;
    my $context = shift;
    if (!defined($context)) {
	$context = defined(wantarray) ? 1 + wantarray : 0;
    }
    return Patro::LeumJelly::proxy_request( $tied->{obj},
	{ topic => 'ARRAY',
	  command => $name,
	  context => $context,
	  has_args => @_ > 0,
	  args => [ @_ ],
	  id => $tied->{id} }, @_ );
}

sub Patro::Tie::ARRAY::FETCH { return shift->__('FETCH',1,@_) }
sub Patro::Tie::ARRAY::STORE { return shift->__('STORE',0,@_) }
sub Patro::Tie::ARRAY::FETCHSIZE { return shift->__('FETCHSIZE',1) }
sub Patro::Tie::ARRAY::STORESIZE { return shift->__('STORESIZE',1,@_) }
sub Patro::Tie::ARRAY::DELETE    { return shift->__('DELETE',1,@_) }
sub Patro::Tie::ARRAY::CLEAR     { return shift->__('CLEAR',0) }
sub Patro::Tie::ARRAY::EXISTS    { return shift->__('EXISTS',1,@_) }
sub Patro::Tie::ARRAY::PUSH      { return shift->__('PUSH',1,@_) }
sub Patro::Tie::ARRAY::POP       { return shift->__('POP',1) }
sub Patro::Tie::ARRAY::SHIFT     { return shift->__('SHIFT',1) }
sub Patro::Tie::ARRAY::UNSHIFT   { return shift->__('UNSHIFT',1,@_) }
sub Patro::Tie::ARRAY::SPLICE {
    my $tied = shift;
    my $off = @_ ? shift : 0;
    my $len = @_ ? shift : 'undef';
    return $tied->__('SPLICE',wantarray ? 2:1,$off,$len,@_);
}

############################################################

1;