RPC::XML::Function - Object class for RPC routines that do not check signatures

    require RPC::XML::Function;

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

###############################################################################
#
# This file copyright (c) 2002-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 is a type of Procedure that does no signature tests
#                   at either creation or invocation.
#
#   Functions:      new (superclass new expects signatures)
#                   signature
#                   make_sig_table (called by some superclass methods)
#                   clone
#                   is_valid
#                   match_signature
#
#   Libraries:      RPC::XML::Procedure (base class)
#
#   Global Consts:  $VERSION
#
#   Environment:    None
#
###############################################################################

package RPC::XML::Function;

use 5.006001;
use strict;
use warnings;
use vars qw($VERSION);
use subs qw(new signature make_sig_table clone is_valid match_signature);
use base qw(RPC::XML::Procedure);

use AutoLoader 'AUTOLOAD';

$VERSION = '1.09';
$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
{
    #
    # This is largely a verbatim-copy of RPC::XML::Procedure::new. I plan on
    # going back and coming up with a way for this class to be able to use
    # the super-class new, but this is sufficient for now.
    #

    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. (But this class ignores it)
        my ($key, $val);
        $data = {};
        while (@argz)
        {
            ($key, $val) = splice @argz, 0, 2;
            if ($key eq 'signature')
            {
                # Noop
                next;
            }
            elsif (exists $data->{$key})
            {
                return "${class}::new: Key '$key' may not be repeated";
            }
            else
            {
                $data->{$key} = $val;
            }
        }
    }

    if (! ($data->{name} and $data->{code}))
    {
        return "${class}::new: Missing required data";
    }

    return bless $data, $class;
}

#
# These two are only implemented here at all, because some of the logic in
# other places call them
#
sub signature      { return; }
sub make_sig_table { return shift; }

1;

__END__

#
# These are the same as RPC::XML::Procedure subs, except that they have no
# references to signatures.
#
###############################################################################
#
#   Sub Name:       clone
#
#   Description:    Create a copy of the invoking object.
#
#   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 = {};
    %{$new_self} = %{$self};

    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});
}

###############################################################################
#
#   Sub Name:       match_signature
#
#   Description:    Noop. Needed for RPC::XML::Server.
#
#   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
{
    return 'scalar';
}