view release on metacpan or  search on metacpan

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

# Taco Perl server module.
# Copyright (C) 2013-2014 Graham Bell
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

=head1 NAME

Alien::Taco::Server - Taco Perl server module

=head1 SYNOPSIS

    use Alien::Taco::Server;
    my $server = new Alien::Taco::Server();
    $server->run();

=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

=head2 Main Methods

=over 4

=item new()

Set up a L<Alien::Taco::Transport> object communicating via
C<STDIN> and C<STDOUT>.

C<STDERR> is selected as the current stream to try to avoid
any subroutine or method calls printing to C<STDOUT> which would
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);

    return $self;
}

# _construct_transport
#
# Implements construction of the Alien::Taco::Transport object.

sub _construct_transport {
    my $self = shift;
    my $in = shift;
    my $out = shift;

    return new Alien::Taco::Transport(in => $in, out => $out,
            filter_single => ['_Taco_Object_' =>  sub {
                return $self->_get_object(shift);
            }],
    );
}

=item run()

Enter the message handling loop, which exits on failure to read from
the transport.

=cut

sub run {
    my $self = shift;
    my $xp = $self->{'xp'};

    while (1) {
        my $message = $xp->read();
        last unless defined $message;

        my $act = $message->{'action'};
        my $res = undef;

        if ($act !~ /^_/ and $self->can($act)) {
            $res = eval {$self->$act($message)};

            $res = {
                action => 'exception',
                message => 'exception caught: ' . $@,
            } unless defined $res;
        }
        else {
            $res = {
                action => 'exception',
                message => 'unknown action: ' . $act,
            };
        }

        $self->_replace_objects($res);
        $xp->write($res);
    }
}