Alien-Taco

 view release on metacpan or  search on metacpan

lib/Alien/Taco.pm  view on Meta::CPAN

=head1 DESCRIPTION

This is the Taco client module for Perl.

=cut

package Alien::Taco;

use IPC::Open2;
use Scalar::Util qw/blessed/;

use Alien::Taco::Object;
use Alien::Taco::Transport;

use strict;

our $VERSION = '0.003';

=head1 METHODS

lib/Alien/Taco.pm  view on Meta::CPAN

    elsif (exists $opts{'lang'}) {
        $serv = 'taco-' . $opts{'lang'};
    }
    else {
        die 'languange or script not specified';
    }

    my ($serv_in, $serv_out);
    my $pid = open2($serv_out, $serv_in, $serv);

    my $self = bless {}, $class;

    $self->{'xp'} = $self->_construct_transport($serv_out, $serv_in);

    return $self;
}

# _construct_transport()

sub _construct_transport {
    my $self = shift;

lib/Alien/Taco/Object.pm  view on Meta::CPAN

# new($taco_client, $object_number)
#
# Constructs a new instance of this class.  A reference to the Taco client
# is stored to allow actions to be sent via it.

sub new {
    my $class = shift;
    my $client = shift;
    my $number = shift;

    return bless {client => $client, number => $number}, $class;
}

# DESTROY
#
# Destructor method.  This invokes the _destroy_object method of
# the Taco client so that the object on the server side can be deleted.

sub DESTROY {
    my $self = shift;

lib/Alien/Taco/Server.pm  view on Meta::CPAN

=head1 DESCRIPTION

This module provides a Perl implementation of the actions
required of a Taco server.

=cut

package Alien::Taco::Server;

use Scalar::Util qw/blessed/;

use Alien::Taco::Transport;
use Alien::Taco::Util qw/filter_struct/;

use strict;

our $VERSION = '0.003';

=head1 SUBROUTINES

lib/Alien/Taco/Server.pm  view on Meta::CPAN

corrupt communications with the client.

=cut

sub new {
    my $class = shift;

    # Create cache of objects held on the server side for which an
    # object number is passed to the client.

    my $self = bless {
        nobject => 0,
        objects => {},
    }, $class;

    # Select STDERR as current file handle so that if a function is
    # called which in turn prints something, it doesn't go into the
    # transport stream.
    select(STDERR);

    $self->{'xp'} = $self->_construct_transport(*STDIN, *STDOUT);

lib/Alien/Taco/Server.pm  view on Meta::CPAN

my $null_result = _make_result(undef);

# _replace_objects(\%message)
#
# Replace objects in the given message with Taco object number references.

sub _replace_objects {
    my $self = shift;
    filter_struct(shift, sub {
        my $x = shift;
        blessed($x) and not JSON::is_bool($x);
    },
    sub {
        my $nn = my $n = ++ $self->{'nobject'};
        $self->{'objects'}->{$nn} = shift;
        return {_Taco_Object_ => $n};
    });
}

# _delete_object($number)
#

lib/Alien/Taco/Server.pm  view on Meta::CPAN

    my $n = $message->{'number'};
    $self->_delete_object($n);

    return $null_result;
}

=item get_attribute($message)

Attempt to read an object attribute, but this depends on the object
being a blessed HASH reference.  If so then the named HASH entry
is returned.  Typically, however, Perl object values will be
accessed by calling the corresponding method on the object instead.

=cut

sub get_attribute {
    my $self = shift;
    my $message = shift;

    my $number = $message->{'number'};

lib/Alien/Taco/Transport.pm  view on Meta::CPAN

Construct a new object.  This stores the given input and output file
handles and instantiates a JSON processor object.

=cut

sub new {
    my $class = shift;
    my %opts = @_;

    my $json = new JSON();
    $json->convert_blessed(1);
    $json->ascii(1);

    if (exists $opts{'filter_single'}) {
        $json->filter_json_single_key_object(@{$opts{'filter_single'}});
    }

    binmode $opts{'in'}, ':encoding(UTF-8)';
    binmode $opts{'out'}, ':encoding(UTF-8)';

    my $self = {
        in => $opts{'in'},
        out => $opts{'out'},
        json => $json,
    };

    return bless $self, $class;
}

=item read()

Attempt to read a message from the input filehandle.  Returns the decoded
message as a data structure or undef if nothing was read.

=cut

sub read {

t/2_object.t  view on Meta::CPAN

# Fake Taco client class for the objects under test to interact
# with.

package TestClient;

sub new {
    my $class = shift;

    return bless {
        destroyed => undef,
    }, $class;
}

sub _call_method {
    my $self = shift;
    $self->{'called'} = [@_];
}

sub _destroy_object {

t/3_client_sub.t  view on Meta::CPAN

package TestClient;

use parent 'Alien::Taco';

sub new {
    my $class = shift;

    my $in_io = new IO::String();
    my $out_io = new IO::String();

    my $self = bless {
        in_io => $in_io,
        out_io => $out_io,
    }, $class;

    $self->{'xp'} = $self->_construct_transport($in_io, $out_io);

    return $self;
}

sub prepare_input {

t/3_server_sub.t  view on Meta::CPAN

package TestServer;

use parent 'Alien::Taco::Server';

sub new {
    my $class = shift;

    my $in_io = new IO::String();
    my $out_io = new IO::String();

    my $self = bless {
        nobject => 0,
        objects => {},
        in_io => $in_io,
        out_io => $out_io,
    }, $class;

    $self->{'xp'} = $self->_construct_transport($in_io, $out_io);

    return $self;
}

t/4_client_msg.t  view on Meta::CPAN

# A test client which just stores message hashes rather than attempting
# to send them.

package TestClient;

use parent 'Alien::Taco';

sub new {
    my $class = shift;

    return bless {msg => undef}, $class;
}

sub _interact {
    my $self = shift;
    $self->{'msg'} = shift;
}

sub msg {
    my $self = shift;
    return $self->{'msg'};

t/4_server_msg.t  view on Meta::CPAN

our $context;
our $static_attr;

BEGIN {
    $context = 'not set yet';
    $static_attr = 112233;
}

sub new {
    my $class = shift;
    return bless {k => 'v'}, $class;
}

sub test_method {
    my $self = shift;
    $self->{'context'} = wantarray;
    $self->{'param'} = [@_];
    return (55555, 666666);
}

sub class_method {

t/4_server_msg.t  view on Meta::CPAN

    @use_param = @_;
}


package TestServer;

use parent 'Alien::Taco::Server';

sub new {
    my $class = shift;
    return bless {
        nobject => 0,
        objects => {},
    }, $class;
}