File Coverage

blib/lib/RPC/XML/Procedure.pm

Criterion	Covered	Total	%
statement	124	261	47.5
branch	37	94	39.3
condition	11	35	31.4
subroutine	25	38	65.7
pod	14	16	87.5
total	211	444	47.5

###############################################################################
#
# This file copyright (c) 2001-2011 Randy J. Ray, all rights reserved
#
# Copying and distribution are permitted under the terms of the Artistic
# License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
# the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php).
#
###############################################################################
#
#   Description:    This class abstracts out all the procedure-related
#                   operations from the RPC::XML::Server class. It also
#                   provides the RPC::XML::Method and RPC::XML::Function
#                   namespaces.
#
#   Functions:      new
#                   name        \
#                   code         \
#                   signature     \ These are the accessor functions for the
#                   help          / data in the object, though it's visible.
#                   version      /
#                   hidden      /
#                   clone
#                   add_signature
#                   delete_signature
#                   make_sig_table
#                   match_signature
#                   reload
#                   load_xpl_file
#                   call
#
#   Libraries:      XML::Parser (used only on demand in load_xpl_file)
#                   File::Spec
#
#   Global Consts:  $VERSION
#
#   Environment:    None.
#
###############################################################################

# Perl::Critic:
#
# We use explicit @ISA in RPC::XML::Method and RPC::XML::Function because it
# is faster than doing 'use base' when we're already in the same file.

## no critic (ProhibitExplicitISA)

package RPC::XML::Procedure;

use 5.008008;
use strict;
use warnings;
use vars qw($VERSION %VALID_TYPES);

use File::Spec;
use Scalar::Util 'blessed';

use RPC::XML 'smart_encode';

# This module also provides RPC::XML::Method and RPC::XML::Function
## no critic (ProhibitMultiplePackages)

$VERSION = '1.30';
$VERSION = eval $VERSION;    ## no critic (ProhibitStringyEval)

# This should match the set of type-classes defined in RPC::XML.pm. Note that
# we use "dateTime.iso8601" instead of "datetime_iso8601", because that is how
# it has to be in the signature.
%VALID_TYPES = map { $_ => 1 }
    (qw(int i4 i8 double string boolean dateTime.iso8601 nil array struct
        base64));

###############################################################################
#
#   Sub Name:       new
#
#   Description:    Create a new object of this class, storing the info on
#                   regular keys (no obfuscation used here).
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $class    in      scalar    Class to bless into
#                   @argz     in      variable  Disposition is variable; see
#                                                 below
#
#   Returns:        Success:    object ref
#                   Failure:    error string
#
###############################################################################
sub new
{
    my ($class , @argz) = @_;

    my $new_proc;    # This will be a hashref that eventually gets blessed

    if (ref $class)
    {
        return __PACKAGE__ . '::new: Must be called as a static method';
    }

    # There are three things that @argz could be:
    if (ref $argz[0])
    {
        # 1. A hashref containing all the relevant keys

        # Start wtih the defaults for the optional keys
        $new_proc = {
            namespace => q{},
            version   => 0,
            hidden    => 0,
            help      => q{},
        };
        # Copy everything from the hash, don't try to use it directly
        for (keys %{$argz[0]}) { $new_proc->{$_} = $argz[0]->{$_} }
    }
    elsif (@argz == 1)
    {
        # 2. Exactly one non-ref element, a file to load

        # Loading code from an XPL file, it can actually be of a type other
        # than how this constructor was called. So what we are going to do is
        # this: If $class is RPC::XML::Procedure, act like a factory method
        # and return whatever the file claims to be. Otherwise, the file has
        # to match $class or it's an error.
        ($new_proc, my $pkg) = load_xpl_file($argz[0]);
        if (! ref $new_proc)
        {
            # load_xpl_path signalled an error
            return $new_proc;
        }
        if ($class ne 'RPC::XML::Procedure' && $pkg ne $class)
        {
            return "${class}::new: File loaded ($argz[0]) must match " .
                'this calling class';
        }

        $class = $pkg;
    }
    else
    {
        # 3. If there is more than one arg, it's a sort-of-hash. That is, the
        #    key 'signature' is allowed to repeat.
        my ($key, $val);
        $new_proc = {
            namespace => q{},
            version   => 0,
            hidden    => 0,
            help      => q{},
            signature => [],
        };
        while (@argz)
        {
            ($key, $val) = splice @argz, 0, 2;
            if ($key eq 'signature')
            {
                # Since there may be more than one signature, we allow it to
                # repeat. Of course, that's also why we can't just take @argz
                # directly as a hash. *shrug*
                push @{$new_proc->{signature}},
                    ref $val ? join q{ } => @{$val} : $val;
            }
            else
            {
                $new_proc->{$key} = $val;
            }
        }
    }

    # A sanity check on the content of the object before we bless it:
    if (! ($new_proc->{name} && $new_proc->{code}))
    {
        return "${class}::new: Missing required data (name or code)";
    }
    if (($class ne 'RPC::XML::Function') &&
        (! ((exists $new_proc->{signature}) &&
            (ref($new_proc->{signature}) eq 'ARRAY') &&
            scalar(@{$new_proc->{signature}}))))
    {
        return "${class}::new: Missing required data (signatures)";
    }
    bless $new_proc, $class;

    # This needs to happen post-bless in case of error (for error messages)
    return $new_proc->make_sig_table;
}

###############################################################################
#
#   Sub Name:       make_sig_table
#
#   Description:    Create a hash table of the signatures that maps to the
#                   corresponding return type for that particular invocation.
#                   Makes looking up call patterns much easier.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#
#   Globals:        %VALID_TYPES
#
#   Returns:        Success:    $self
#                   Failure:    error message
#
###############################################################################
sub make_sig_table
{
    my $self = shift;

    my ($return, $rest, @rest);
    my $me = ref($self) . '::make_sig_table';

    delete $self->{sig_table};
    for my $sig (@{$self->{signature}})
    {
        ($return, @rest) = split / /, $sig;
        if (! $return)
        {
            return "$me: Invalid signature, cannot be null";
        }
        if (! $VALID_TYPES{$return})
        {
            return "$me: Unknown return type '$return'";
        }
        # Not going to add List::MoreUtils to my dependencies list, so suppress
        # this critic flag:
        ## no critic (ProhibitBooleanGrep)
        if (grep { ! $VALID_TYPES{$_} } @rest)
        {
            return "$me: One or more invalid types in signature";
        }

        $rest = join q{ } => @rest;
        # If the key $rest already exists, then this is a collision
        if ($self->{sig_table}->{$rest})
        {
            return
                "$me: Cannot have two different return values for one set " .
                "of params ($return vs. $self->{sig_table}->{$rest})";
        }

        $self->{sig_table}->{$rest} = $return;
    }

    return $self;
}

# These are basic accessor/setting functions for the various attributes

sub name { return shift->{name}; }    # "name" cannot be changed at this level
sub namespace { return shift->{namespace} || q{}; }    # Nor can "namespace"

sub help
{
    my ($self, $value) = @_;

    if ($value)
    {
        $self->{help} = $value;
    }

    return $self->{help};
}

sub version
{
    my ($self, $value) = @_;

    if ($value)
    {
        $self->{version} = $value;
    }

    return $self->{version};
}

sub hidden
{
    my ($self, $value) = @_;

    if ($value)
    {
        $self->{hidden} = $value;
    }

    return $self->{hidden};
}

sub code
{
    my ($self, $value) = @_;

    if ($value and ref $value eq 'CODE')
    {
        $self->{code} = $value;
    }

    return $self->{code};
}

sub signature
{
    my ($self, $sig) = @_;

    if ($sig)
    {
        if (ref $sig eq 'ARRAY')
        {
            my $old = $self->{signature};
            $self->{signature} = $sig;
            my $is_good = $self->make_sig_table;
            if (! ref $is_good)
            {
                # If it failed to re-init the table, restore the old list (and
                # old table). We don't have to check this return, since it had
                # worked before.
                $self->{signature} = $old;
                $self->make_sig_table;

                # Return an error message, since this failed:
                return ref($self) . "::signature: $is_good";
            }
        }
        else
        {
            # Anything not an array ref isn't useful
            return ref($self) . "::signature: Bad value '$sig'";
        }
    }

    # Return a copy of the array, not the original
    return [ @{$self->{signature}} ];
}

###############################################################################
#
#   Sub Name:       clone
#
#   Description:    Create a near-exact copy of the invoking object, save that
#                   the listref in the "signature" key is a copy, not a ref
#                   to the same list.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#
#   Returns:        Success:    $new_self
#                   Failure:    error message
#
###############################################################################
sub clone
{
    my $self = shift;

    my $new_self = {};
    for (keys %{$self})
    {
        next if $_ eq 'signature';
        $new_self->{$_} = $self->{$_};
    }
    if (! $self->isa('RPC::XML::Function'))
    {
        $new_self->{signature} = [ @{$self->{signature}} ];
    }

    return bless $new_self, ref $self;
}

###############################################################################
#
#   Sub Name:       add_signature
#                   delete_signature
#
#   Description:    This pair of functions may be used to add and remove
#                   signatures from a method-object.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   @args     in      list      One or more signatures
#
#   Returns:        Success:    $self
#                   Failure:    error string
#
###############################################################################
sub add_signature
{
    my ($self, @args) = @_;

    my (%sigs, $is_good, $old);

    # Preserve the original in case adding the new one causes a problem
    $old = $self->{signature};
    %sigs = map { $_ => 1 } @{$self->{signature}};
    for my $one_sig (@args)
    {
        my $sig_key = (ref $one_sig) ? join q{ } => @{$one_sig} : $one_sig;
        $sigs{$sig_key} = 1;
    }
    $self->{signature} = [ keys %sigs ];
    $is_good = $self->make_sig_table;
    if (! ref $is_good)
    {
        # Because this failed, we have to restore the old table and return
        # an error
        $self->{signature} = $old;
        $self->make_sig_table;
        return ref($self) . '::add_signature: Error re-hashing table: ' .
            $is_good;
    }

    return $self;
}

sub delete_signature
{
    my ($self, @args) = @_;

    my %sigs;

    my $old = $self->{signature};
    %sigs = map { $_ => 1 } @{$self->{signature}};
    for my $one_sig (@args)
    {
        my $sig_key = (ref $one_sig) ? join q{ } => @{$one_sig} : $one_sig;
        delete $sigs{$sig_key};
    }
    $self->{signature} = [ keys %sigs ];

    if (@{$self->{signature}} == 0)
    {
        # Don't have to re-run make_sig_table, because it's still valid for
        # this set:
        $self->{signature} = $old;
        return ref($self) . '::delete_signature: Cannot delete last signature';
    }

    # This can't fail, because deleting a signature will never cause an
    # ambiguity in the table like adding one could.
    return $self->make_sig_table;
}

###############################################################################
#
#   Sub Name:       match_signature
#
#   Description:    Determine if the passed-in signature string matches any
#                   of this method's known signatures.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $sig      in      scalar    Signature to check for
#
#   Returns:        Success:    return type as a string
#                   Failure:    0
#
###############################################################################
sub match_signature
{
    my $self = shift;
    my $sig  = shift;

    if (ref $sig)
    {
        $sig = join q{ } => @{$sig};
    }

    return $self->{sig_table}->{$sig} || 0;
}

###############################################################################
#
#   Sub Name:       reload
#
#   Description:    Reload the method's code and ancillary data from the file
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#
#   Returns:        Success:    $self
#                   Failure:    error message
#
###############################################################################
sub reload
{
    my $self = shift;

    my $class = ref $self;
    my $me = "${class}::reload";

    if (! $self->{file})
    {
        return "$me: No file associated with method $self->{name}";
    }

    my ($newly_loaded) = load_xpl_file($self->{file});

    if (ref $newly_loaded)
    {
        # Update the information on this actual object
        for (keys %{$newly_loaded})
        {
            $self->{$_} = $newly_loaded->{$_};
        }
        # Re-calculate the signature table, in case that changed as well
        return $self->make_sig_table;
    }
    else
    {
        return "$me: Error loading $self->{file}: $newly_loaded";
    }
}

###############################################################################
#
#   Sub Name:       load_xpl_file
#
#   Description:    Load a XML-encoded method description (generally denoted
#                   by a *.xpl suffix) and return the relevant information.
#
#                   Note that this is not a method, it does not take $self as
#                   an argument.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $file     in      scalar    File to load
#
#   Returns:        Success:    hashref of values
#                   Failure:    error string
#
###############################################################################
sub load_xpl_file
{
    my $file = shift;

    require XML::Parser;

    my ($me, $new_proc, $signature, $code, $codetext, $accum, $P, $fh,
        $eval_ret, $class, %attr);

    $me = __PACKAGE__ . '::load_xpl_file';

    $new_proc = {};
    # So these don't end up undef, since they're optional elements
    $new_proc->{hidden}    = 0;
    $new_proc->{version}   = q{};
    $new_proc->{help}      = q{};
    $new_proc->{namespace} = __PACKAGE__;
    $P = XML::Parser->new(
        ErrorContext => 1,
        Handlers     => {
            Char => sub { $accum .= $_[1] },
            Start => sub { %attr = splice @_, 2 },
            End => sub {
                my $elem = $_[1];

                $accum =~ s/^\s+//;
                $accum =~ s/\s+$//;
                if ($elem eq 'signature')
                {
                    $new_proc->{signature} ||= [];
                    push @{$new_proc->{signature}}, $accum;
                }
                elsif ($elem eq 'hidden')
                {
                    $new_proc->{hidden} = 1;
                }
                elsif ($elem eq 'code')
                {
                    if (! ($attr{language} &&
                           $attr{language} ne 'perl'))
                    {
                        $new_proc->{$elem} = $accum;
                    }
                }
                elsif ('def' eq substr $elem, -3)
                {
                    $class = 'RPC::XML::' . ucfirst substr $elem, 0, -3;
                }
                else
                {
                    $new_proc->{$elem} = $accum;
                }

                %attr  = ();
                $accum = q{};
            }
        }
    );
    if (! $P)
    {
        return "$me: Error creating XML::Parser object";
    }
    open $fh, '<', $file or return "$me: Error opening $file for reading: $!";
    # Trap any errors
    $eval_ret = eval { $P->parse($fh); 1; };
    close $fh or return "$me: Error closing $file: $!";
    if (! $eval_ret)
    {
        return "$me: Error parsing $file: $@";
    }

    # Try to normalize $codetext before passing it to eval

    # Fudge a little and let them use '.' as a synonym for '::' in the
    # namespace hierarchy.
    $new_proc->{namespace} =~ s/[.]/::/g;

    # Next step is to munge away any actual subroutine name so that the eval
    # yields an anonymous sub. Also insert the namespace declaration.
    ($codetext = $new_proc->{code}) =~
        s/sub\s+(?:[\w:]+)?\s*[{]/sub \{ package $new_proc->{namespace}; /;
    $code = eval $codetext; ## no critic (ProhibitStringyEval)
    return "$me: Error creating anonymous sub: $@" if $@;

    $new_proc->{code} = $code;
    # Add the file's mtime for when we check for stat-based reloading, name
    # for reloading, and init the "called" counter to 0.
    $new_proc->{mtime}  = (stat $file)[9];
    $new_proc->{file}   = $file;
    $new_proc->{called} = 0;

    return ($new_proc, $class);
}

###############################################################################
#
#   Sub Name:       call
#
#   Description:    Encapsulates the invocation of the code block that the
#                   object is abstracting. Manages parameters, signature
#                   checking, etc.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $srv      in      ref       An object derived from the
#                                                 RPC::XML::Server class
#                   @params_in in     list      The params for the call itself
#
#   Globals:        None.
#
#   Environment:    None.
#
#   Returns:        Success:    value
#                   Failure:    RPC::XML::fault object
#
###############################################################################
sub call
{
    my ($self, $srv, @params_in) = @_;

    my (@paramtypes, @params, $signature, $resptype, $response, $name);

    $name = $self->name;
    # Create the param list.
    # The type for the response will be derived from the matching signature
    @paramtypes = map { $_->type } @params_in;
    @params     = map { $_->value } @params_in;
    $signature = join q{ } => @paramtypes;
    $resptype = $self->match_signature($signature);
    # Since there must be at least one signature with a return value (even
    # if the param list is empty), this tells us if the signature matches:
    if (! $resptype)
    {
        return $srv->server_fault(
            badsignature =>
            "method $name has no matching signature for the argument list: " .
            "[$signature]"
        );
    }
    elsif ($resptype eq 'dateTime.iso8601')
    {
        $resptype = 'datetime_iso8601';
    }

    # Set these in case the server object is part of the param list
    local $srv->{signature} =          ## no critic (ProhibitLocalVars)
        [ $resptype, @paramtypes ];
    local $srv->{method_name} = $name; ## no critic (ProhibitLocalVars)
    # For RPC::XML::Method (and derivatives), pass the server object
    if ($self->isa('RPC::XML::Method'))
    {
        unshift @params, $srv;
    }

    # Now take a deep breath and call the method with the arguments
    if (! eval { $response = $self->{code}->(@params); 1; })
    {
        # On failure, propagate user-generated RPC::XML::fault exceptions, or
        # transform Perl-level error/failure into such an object
        if (blessed $@ and $@->isa('RPC::XML::fault'))
        {
            return $@;
        }
        else
        {
            return $srv->server_fault(
                execerror => "Method $name returned error: $@"
            );
        }
    }

    # Increment the 'called' key on the proc UNLESS the proc is named
    # 'system.status' and has a boolean-true as the first param.
    if (! (($name eq 'system.status') &&
           @params_in &&
           ($paramtypes[0] eq 'boolean') &&
           $params[0]))
    {
        $self->{called}++;
    }
    # Create a suitable return value
    if (! ref $response)
    {
        if ($resptype eq 'scalar')
        {
            # Server code from the RPC::XML::Function class doesn't use
            # signatures, so if they didn't encode the returned value
            # themselves they're trusting smart_encode() to get it right.
            $response = smart_encode($response);
        }
        else
        {
            # We checked that this was valid earlier, so no need for further
            # tests here.
            $response = "RPC::XML::$resptype"->new($response);
        }
    }

    return $response;
}

###############################################################################
#
#   Description:    This is now an empty sub-class of RPC::XML::Procedure.
#                   It differs behaviorally from ::Procedure in that the
#                   RPC::XML::Server object is passed in the arguments list
#                   when the underlying code is invoked by call().
#
#   Functions:      None.
#
###############################################################################

package RPC::XML::Method;

use strict;
use warnings;
use vars qw(@ISA);

@ISA = qw(RPC::XML::Procedure);

###############################################################################
#
#   Description:    This is a type of Procedure that does no signature tests
#                   at either creation or invocation. Like RPC::XML::Procedure
#                   it does *not* get the RPC::XML::Server object when the
#                   underlying code is invoked by call().
#
#   Functions:      signature
#                   make_sig_table (called by some superclass methods)
#                   add_signature
#                   delete_signature
#                   match_signature
#
###############################################################################

package RPC::XML::Function;

use strict;
use warnings;
use vars qw(@ISA);
use subs qw(
    signature make_sig_table add_signature delete_signature match_signature
);

@ISA = qw(RPC::XML::Procedure);

# These are the bits that have to be different for RPC::XML::Function versus
# the other procedure types. They are simple-enough that they don't need
# dedicated comment-blocks for them.
sub signature        { return [ 'scalar' ]; }
sub make_sig_table   { return shift; }
sub add_signature    { return shift; }
sub delete_signature { return shift; }
sub match_signature  { return 'scalar'; }

1;

__END__