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.

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

}

=item get_class_attribute($message)

Attempt the read a variable from the given class's package.
The attribute name should begin with the appropriate sigil
(C<$> / C<@> / C<%>).

=cut

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

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

    # Construct full name from sigil + class + '::' + attribute.
    return $self->_get_attr_or_value(
        substr($name, 0, 1) . $message->{'class'} . '::' . substr($name, 1));
}

=item get_value($message)

Try to read the given variable.  The variable name should begin
with the appropriate sigil (C<$> / C<@> / C<%>).

=cut

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

    return $self->_get_attr_or_value($message->{'name'});
}

# _get_attr_or_value($name)
#
# Internal method to get a value based on its sigil.

sub _get_attr_or_value {
    my $self = shift;
    my $name = shift;

    no strict 'refs';
    if ($name =~ s/^\$//) {
        return _make_result($$name);
    }
    elsif ($name =~ s/^\@//) {
        return _make_result(\@{$name});
    }
    elsif ($name =~ s/^\%//) {
        return _make_result(\%{$name});
    }
    else {
        die 'unknown sigil';
    }
}

=item import_module($message)

Convert the supplied module name to a path by replacing C<::> with C</>
and appending C<.pm>.  Then require the resulting module file and
call its C<import> subroutine.  Any parameters provided are passed
to C<import>.

=cut

sub import_module {
    my $self = shift;
    my $message = shift;
    my @param = _get_param($message);

    my $m = $message->{'name'};
    my $f = $m; $f =~ s/::/\//g;

    require $f . '.pm';
    $m->import(@param);

    return $null_result;
}

=item set_attribute($message)

Attempt to set an attribute of an object, but see the notes for
C<get_attribute> above.

=cut

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

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

    my $object = $self->_get_object($number);

    die 'object is not a hash' unless $object->isa('HASH');

    $object->{$name} = $value;

    return $null_result;
}

=item set_class_attribute($message)

Attempt to set a variable in the given class's package.
The attribute name should begin with the appropriate sigil
(C<$> / C<@> / C<%>).

=cut

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

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

    # Construct full name from sigil + class + '::' + attribute.
    $self->_set_attr_or_value(