RPC::XML::Procedure - Object encapsulation of server-side RPC procedures

    require RPC::XML::Procedure;

    ...
    $method_1 = RPC::XML::Procedure->new({ name => 'system.identity',
                                           code => sub { ... },
                                           signature => [ 'string' ] });
    $method_2 = RPC::XML::Procedure->new('/path/to/status.xpl');

###############################################################################
#
# This file copyright (c) 2001-2010 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
#
#   Functions:      new
#                   name        \
#                   code         \
#                   signature     \ These are the accessor functions for the
#                   help          / data in the object, though it's visible.
#                   version      /
#                   hidden      /
#                   clone
#                   is_valid
#                   add_signature
#                   delete_signature
#                   make_sig_table
#                   match_signature
#                   reload
#                   load_XPL_file
#
#   Libraries:      XML::Parser (used only on demand in load_XPL_file)
#                   File::Spec
#
#   Global Consts:  $VERSION
#
#   Environment:    None.
#
###############################################################################

package RPC::XML::Procedure;

use 5.006001;
use strict;
use warnings;
use vars qw($VERSION);
use subs qw(new is_valid name code signature help version hidden
    add_signature delete_signature make_sig_table match_signature
    reload load_XPL_file);

use AutoLoader 'AUTOLOAD';
use File::Spec;

use Scalar::Util 'blessed';

use RPC::XML 'smart_encode';

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

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

###############################################################################
#
#   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 $data;    # This will be a hashref that eventually gets blessed

    $class = ref($class) || $class;

    #
    # There are three things that @argz could be:
    #
    if (ref $argz[0])
    {
        # 1. A hashref containing all the relevant keys
        $data  = {};
        %{$data} = %{$argz[0]};
    }
    elsif (@argz == 1)
    {
        # 2. Exactly one non-ref element, a file to load

        # And here is where I cheat in a way that makes even me uncomfortable.
        #
        # 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 undef, that can only mean that we were called
        # with the intent of letting the XPL file dictate the resulting object.
        # If $class is set, then we'll call load_XPL_file normally, as a
        # method, to allow for subclasses to tweak things.
        if (defined $class)
        {
            $data = $class->load_XPL_file($argz[0]);
            if (! ref $data)
            {
                # load_XPL_path signalled an error
                return $data;
            }
        }
        else
        {
            # Spoofing the "class" argument to load_XPL_file makes me feel
            # even dirtier...
            $data = load_XPL_file(\$class, $argz[0]);
            if (! ref $data)
            {
                # load_XPL_path signalled an error
                return $data;
            }
            $class = "RPC::XML::$class";
        }
    }
    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);
        $data = {};
        $data->{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 @{$data->{signature}},
                    ref $val ? join q{ } => @{$val} : $val;
            }
            elsif (exists $data->{$key})
            {
                return "${class}::new: Key '$key' may not be repeated";
            }
            else
            {
                $data->{$key} = $val;
            }
        }
    }

    if (! (exists $data->{signature} &&
           (ref($data->{signature}) eq 'ARRAY') &&
           scalar(@{$data->{signature}}) &&
           $data->{name} &&
           $data->{code}))
    {
        return "${class}::new: Missing required data";
    }
    bless $data, $class;

    # This needs to happen post-bless in case of error (for error messages)
    return $data->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
#
#   Returns:        Success:    $self
#                   Failure:    error message
#
###############################################################################
sub make_sig_table
{
    my $self = shift;

    my ($return, $rest);

    delete $self->{sig_table};
    for my $sig (@{$self->{signature}})
    {
        ($return, $rest) = split / /, $sig, 2;
        if (! $rest)
        {
            $rest = q{};
        }
        # If the key $rest already exists, then this is a collision
        if ($self->{sig_table}->{$rest})
        {
            return
                ref($self) . '::make_sig_table: 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) = @_;

    $value and $self->{help} = $value;

    return $self->{help};
}

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

    $value and $self->{version} = $value;

    return $self->{version};
}

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

    $value and $self->{hidden} = $value;

    return $self->{hidden};
}

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

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

    return $self->{code};
}

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

    if ($sig and ref $sig eq 'ARRAY')
    {
        my $old = $self->{signature};
        $self->{signature} = $sig;
        if (! ref $self->make_sig_table)
        {
            # 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 a copy of the array, not the original
    return [ @{$self->{signature}} ];
}

package RPC::XML::Method;

use strict;
use base qw(RPC::XML::Procedure);

# Needed for AutoSplit to be happy:
package RPC::XML::Procedure;

1;

__END__

###############################################################################
#
#   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->{$_};
    }
    $new_self->{signature} = [];
    @{$new_self->{signature}} = @{$self->{signature}};

    return bless $new_self, ref $self;
}

###############################################################################
#
#   Sub Name:       is_valid
#
#   Description:    Boolean test to tell if the calling object has sufficient
#                   data to be used as a server method for RPC::XML::Server or
#                   Apache::RPC::Server.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object to test
#
#   Returns:        Success:    1, valid/complete
#                   Failure:    0, invalid/incomplete
#
###############################################################################
sub is_valid
{
    my $self = shift;

    return (    (ref($self->{code}) eq 'CODE')
            and $self->{name}
            and (ref($self->{signature}) && scalar(@{$self->{signature}})));
}

###############################################################################
#
#   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, $tmp, $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)
    {
        $tmp = (ref $one_sig) ? join q{ } => @{$one_sig} : $one_sig;
        $sigs{$tmp} = 1;
    }
    $self->{signature} = [ keys %sigs ];
    $tmp = $self->make_sig_table;
    if (! ref $tmp)
    {
        # 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: ' . $tmp;
    }

    return $self;
}

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

    my (%sigs, $tmp, $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)
    {
        $tmp = (ref $one_sig) ? join q{ } => @{$one_sig} : $one_sig;
        delete $sigs{$tmp};
    }
    $self->{signature} = [ keys %sigs ];
    $tmp = $self->make_sig_table;
    if  (! ref $tmp)
    {
        # Because this failed, we have to restore the old table and return
        # an error
        $self->{signature} = $old;
        $self->make_sig_table;
        return
            ref $self . '::delete_signature: Error re-hashing table: ' . $tmp;
    }

    return $self;
}

###############################################################################
#
#   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;

    if (! $self->{file})
    {
        return sprintf '%s::reload: No file associated with method %s',
            ref $self, $self->{name};
    }

    my $tmp = $self->load_XPL_file($self->{file});

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

    return $tmp;
}

###############################################################################
#
#   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 does not fill in $self if $self is a hash
#                   or object reference. This routine is not a substitute for
#                   calling new() (which is why it isn't part of the public
#                   API).
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   $file     in      scalar    File to load
#
#   Returns:        Success:    hashref of values
#                   Failure:    error string
#
###############################################################################
sub load_XPL_file
{
    my $self = shift;
    my $file = shift;

    require XML::Parser;

    my ($me, $data, $signature, $code, $codetext, $accum, $P, %attr);

    if (ref($self) eq 'SCALAR')
    {
        $me = __PACKAGE__ . '::load_XPL_file';
    }
    else
    {
        $me = (ref $self) || $self || __PACKAGE__;
        $me .= '::load_XPL_file';
    }
    $data = {};
    # So these don't end up undef, since they're optional elements
    $data->{hidden}  = 0;
    $data->{version} = q{};
    $data->{help}    = q{};
    $data->{called}  = 0;
    $P = XML::Parser->new(
        ErrorContext => 1,
        Handlers     => {
            Char => sub { $accum .= $_[1] },
            Start => sub { %attr = splice @_, 2 },
            End => sub {
                my $elem = $_[1];

                $accum =~ s/^[\s\n]+//;
                $accum =~ s/[\s\n]+$//;
                if ($elem eq 'signature')
                {
                    $data->{signature} ||= [];
                    push @{$data->{signature}}, $accum;
                }
                elsif ($elem eq 'code')
                {
                    if (! ($attr{language} &&
                           $attr{language} ne 'perl'))
                    {
                        $data->{$elem} = $accum;
                    }
                }
                elsif ('def' eq substr $elem, -3)
                {
                    # Don't blindly store the container tag...
                    # We may need it to tell the caller what
                    # our type is
                    if (ref $self eq 'SCALAR')
                    {
                        ${$self} = ucfirst substr $elem, 0, -3;
                    }
                }
                else
                {
                    $data->{$elem} = $accum;
                }

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

    # Try to normalize $codetext before passing it to eval

    # First step is set the namespace the code will live in. The default is
    # the package that we're in (be it ::Procedure, ::Method, etc.). If they
    # specify one, use it instead.
    if ($data->{namespace})
    {
        # Fudge a little and let them '.' as a synonym for '::' in the
        # namespace hierarchy.
        $data->{namespace} =~ s{\.}{::}g;
    }
    else
    {
        $data->{namespace} = __PACKAGE__;
    }

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

    $data->{code} = $code;
    # Add the file's mtime for when we check for stat-based reloading
    $data->{mtime} = (stat $file)[9];
    $data->{file}  = $file;

    return $data;
}

###############################################################################
#
#   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
#                   @dafa     in      list      The params for the call itself
#
#   Globals:        None.
#
#   Environment:    None.
#
#   Returns:        Success:    value
#                   Failure:    dies with RPC::XML::Fault object as message
#
###############################################################################
sub call
{
    my ($self, $srv, @data) = @_;

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

    $name = $self->name;
    # Create the param list.
    # The type for the response will be derived from the matching signature
    @paramtypes = map { $_->type } @data;
    @params     = map { $_->value } @data;
    $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]"
        );
    }

    # Make sure that the response-type is a valid XML-RPC type
    if (($resptype ne 'scalar') && (! "RPC::XML::$resptype"->can('new')))
    {
        return $srv->server_fault(badsignature =>
            "Signature [$signature] for method $name has unknown " .
            "return-type '$resptype'");
    }

    # 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)
    # If the method being called is "system.status", check to see if we should
    # increment the server call-count.
    $noinc =
        (($name eq 'system.status') &&
            @data &&
            ($paramtypes[0] eq 'boolean') &&
            $params[0]) ? 1 : 0;
    # 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 ($@)
        {
            return (blessed $@ and $@->isa('RPC::XML::fault')) ?
                $@ : $srv->server_fault(execerror =>
                                        "Method $name returned error: $@");
        }
    }

    if (! $noinc)
    {
        $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;
}