view release on metacpan or  search on metacpan

lib/RPC/XML/Procedure.pm  view on Meta::CPAN

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