File Coverage

blib/lib/RPC/ExtDirect/API/Method.pm

Criterion	Covered	Total	%
statement	248	250	99.2
branch	132	146	90.4
condition	33	40	82.5
subroutine	33	34	97.0
pod	18	23	78.2
total	464	493	94.1

package RPC::ExtDirect::API::Method;

use strict;
use warnings;
no  warnings 'uninitialized';           ## no critic

use Carp;
use JSON;

use RPC::ExtDirect::Config;
use RPC::ExtDirect::Util ();
use RPC::ExtDirect::Util::Accessor;

### PUBLIC CLASS METHOD (ACCESSOR) ###
#
# Return the hook types supported by this Method class
#

sub HOOK_TYPES { qw/ before instead after / }

### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
#
# Instantiate a new Method object
#

sub new {
    my ($class, %arg) = @_;

    my $config     = $arg{config};
    my $hook_class = $config->api_hook_class;

    my $pollHandler = $arg{pollHandler};
    my $formHandler = $arg{formHandler};

    my $is_ordered
        = defined $arg{len} && !$pollHandler && !$formHandler;

    my $is_named
        = !$pollHandler && !$formHandler && !$is_ordered;

    my $processor = $pollHandler ? 'pollHandler'
                  : $formHandler ? 'formHandler'
                  : $is_ordered  ? 'ordered'
                  :                'named'
                  ;

    # Need $self to call instance methods
    my $self = bless {
        upload_arg        => 'file_uploads',
        is_named          => $is_named,
        is_ordered        => $is_ordered,
        argument_checker  => "check_${processor}_arguments",
        argument_preparer => "prepare_${processor}_arguments",
    }, $class;

    # If the Method is named, and params array is empty, force !strict
    if ( $is_named ) {
        $arg{params} = $arg{params} || []; # Better safe than sorry
        $arg{strict} = !1 unless @{ $arg{params} };
    }

    if ( exists $arg{metadata} ) {
        # This method is coupled too tightly to try untangling it,
        # so let's pretend that side effects are ok in this case
        $self->_parse_metadata(\%arg);
    }

    # We avoid hard binding on the hook class
    eval "require $hook_class";

    my %hooks;

    for my $type ( $class->HOOK_TYPES ) {
        my $hook = delete $arg{ $type };

        $hooks{ $type } = $hook_class->new( type => $type, code => $hook )
            if $hook;
    }

    @$self{ keys %arg   } = values %arg;
    @$self{ keys %hooks } = values %hooks;

    return $self;
}

### PUBLIC INSTANCE METHOD ###
#
# Return a hashref with the API definition for this Method,
# or an empty list
#

sub get_api_definition {
    my ($self, $env) = @_;

    # By default we're not using the environment object,
    # but application developers can override this method
    # to make permission and/or other kind of checks

    # Poll handlers are not declared in the remoting API
    return if $self->pollHandler;

    my $name = $self->name;

    my $def;

    # Form handlers are defined like this
    # (\1 means JSON::true and doesn't force us to `use JSON`)
    if ( $self->formHandler ) {
        $def = { name => $name, formHandler => \1 };
    }

    # Ordinary method with positioned arguments
    elsif ( $self->is_ordered ) {
        $def = { name => $name, len => $self->len + 0 }
    }

    # Ordinary method with named arguments
    else {
        my $strict = $self->strict;

        $def = {
            name   => $name,
            params => $self->params || [],
            defined $strict ? (strict => ($strict ? \1 : \0)) : (),
        };
    }

    if ( my $meta = $self->metadata ) {
        $def->{metadata} = {};

        if ( $meta->{len} ) {
            $def->{metadata} = {
                len => $meta->{len},
            };
        }
        else {
            my $strict = $meta->{strict};

            $def->{metadata} = {
                params => $meta->{params},
                defined $strict ? (strict => ($strict ? \1 : \0)) : (),
            };
        }
    }

    return $def;
}

### PUBLIC INSTANCE METHOD ###
#
# Return a hashref with backwards-compatible API definition
# for this Method
#

sub get_api_definition_compat {
    my ($self) = @_;

    my %attrs;

    $attrs{package}     = $self->package;
    $attrs{method}      = $self->name;
    $attrs{param_names} = $self->params;
    $attrs{param_no}    = $self->len;
    $attrs{pollHandler} = $self->pollHandler || 0;
    $attrs{formHandler} = $self->formHandler || 0;
    $attrs{param_no}    = undef if $attrs{formHandler};

    for my $type ( $self->HOOK_TYPES ) {
        my $hook = $self->$type;

        $attrs{$type} = $hook->code if $hook;
    }

    return %attrs;
}

### PUBLIC INSTANCE METHOD ###
#
# Return a reference to the actual code for this Method
#

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

    my $package = $self->package;
    my $name    = $self->name;

    return $package->can($name);
}

### PUBLIC INSTANCE METHOD ###
#
# Run the Method code using the provided Environment object
# and input data; return the result or die with exception
#
# We accept named parameters here to keep the signature compatible
# with the corresponding Hook method.
#

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

    my $arg     = $args{arg};
    my $package = $self->package;
    my $name    = $self->name;

    # pollHandler methods should always be called in list context
    return $self->pollHandler ? [ $package->$name(@$arg) ]
         :                        $package->$name(@$arg)
         ;
}

### PUBLIC INSTANCE METHOD ###
#
# Check the arguments that were passed in the Ext.Direct request
# to make sure they conform to the API declared by this Method.
# Arguments should be passed in a reference, either hash- or array-.
# This method is expected to die if anything is wrong, or return 1
# on success.
#
# This method is intentionally split into several submethods,
# instead of using polymorphic subclasses with method overrides.
# Having all these in the same class is easier to maintain and
# augment in user subclasses.
#
# The same applies to `prepare_method_arguments` below.
#

sub check_method_arguments {
    my $self = shift;

    my $checker = $self->argument_checker;

    return $self->$checker(@_);
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the arguments to be passed to the called Method,
# according to the Method's expectations. This works two ways:
# on the server side, RPC::ExtDirect::Request will call this method
# to prepare the arguments that are to be passed to the actual
# Method code that does things; on the client side,
# RPC::ExtDirect::Client will call this method to prepare
# the arguments that are about to be encoded in JSON and passed
# over to the server side.
#
# The difference is that the server side wants an unfolded list,
# and the client side wants a reference, either hash- or array-.
# Because of that, prepare_*_arguments are context sensitive.
#

sub prepare_method_arguments {
    my $self = shift;

    my $preparer = $self->argument_preparer;

    return $self->$preparer(@_);
}

### PUBLIC INSTANCE METHOD ###
#
# Check the metadata that was passed in the Ext.Direct request
# to make sure it conforms to the API declared by this Method.
#
# This method is similar to check_method_arguments and operates
# the same way; it is kept separate for easier overriding
# in subclasses.
#

sub check_method_metadata {
    my $self = shift;

    return 1 unless $self->metadata;

    my $checker = $self->metadata_checker;

    return $self->$checker(@_);
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the metadata to be passed to the called Method,
# in accordance with Method's specification.
#
# This method works similarly to prepare_method_arguments
# and is kept separate for easier overriding in subclasses.
#

sub prepare_method_metadata {
    my $self = shift;

    return unless $self->metadata;

    my $preparer = $self->metadata_preparer;

    return $self->$preparer(@_);
}

### PUBLIC INSTANCE METHOD ###
#
# Check the arguments for a pollHandler
#

sub check_pollHandler_arguments {
    # pollHandlers are not supposed to receive any arguments
    return 1;
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the arguments for a pollHandler
#

sub prepare_pollHandler_arguments {
    my ($self, %arg) = @_;

    my @actual_arg = ();

    # When called from the client, env_arg should not be defined
    if ( defined (my $env_arg = +$self->env_arg) ) {
        push @actual_arg, $arg{env} if defined $arg{env};
    }

    return wantarray ? @actual_arg : [ @actual_arg ];
}

### PUBLIC INSTANCE METHOD ###
#
# Check the arguments for a formHandler
#

sub check_formHandler_arguments {
    my ($self, $arg, $meta) = @_;

    # Nothing to check here really except that it's a hashref
    die sprintf "ExtDirect formHandler Method %s.%s expects named " .
                "arguments in hashref\n", $self->action, $self->name
        unless 'HASH' eq ref $arg;

    return 1;
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the arguments for a formHandler
#

my @std_params = qw/action method extAction extMethod
                    extType extTID extUpload _uploads/;

sub prepare_formHandler_arguments {
    my ($self, %arg) = @_;

    my $env    = $arg{env};
    my $input  = $arg{input};
    my $upload = $arg{upload};

    # Data should be a hashref here
    my %data = %$input;

    # Ensure there are no runaway ExtDirect form parameters
    delete @data{ @std_params };

    my $upload_arg = $self->upload_arg;

    # Add uploads if there are any
    $data{ $upload_arg } = $upload if defined $upload;

    if ( defined (my $env_arg = $self->env_arg) ) {
        $data{ $env_arg } = $env;
    };

    my $meta_def = $self->metadata;

    if ( $meta_def && defined (my $meta_arg = $meta_def->{arg}) ) {
        my $meta = $self->prepare_method_metadata(%arg);
        $data{ $meta_arg } = $meta if defined $meta;

        # Form handlers receive the input hash almost unimpeded;
        # if $meta_arg value is not default 'metadata' the arguments
        # will include two copies of metadata. We don't want that.
        delete $data{metadata} unless $meta_arg eq 'metadata';
    }

    # Preparers are called in list context on the server side,
    # where params can be decoded if configured so; the client
    # will send all form fields JSON encoded anyway so no special
    # handling required for it.
    if ( wantarray ) {
        for my $param ( @{ $self->decode_params || [] } ) {
            # This check is necessary because inclusion in decode_params
            # does not make the field a mandatory argument!
            if ( exists $data{$param} ) {
                my $value = delete $data{$param};

                if ( defined $value ) {
                    # If JSON throws an exception we will rethrow it
                    # after cleaning up
                    $value = eval { JSON::from_json($value) };

                    die RPC::ExtDirect::Util::clean_error_message($@)
                        if $@;
                }

                $data{$param} = $value;
            }
        }

        return %data;
    }
    else {
        return { %data };
    }
    return wantarray ? %data : { %data };
}

### PUBLIC INSTANCE METHOD ###
#
# Check the arguments for a Method with named parameters.
#
# Note that it does not matter if the Method expects its
# arguments to be strictly conforming to the declaration
# or not; in case of !strict the listed parameters are
# still mandatory. In fact !strict only means that
# non-declared parameters are not dropped.
#

sub check_named_arguments {
    my ($self, $arg) = @_;

    die sprintf "ExtDirect Method %s.%s expects named arguments ".
                "in hashref\n", $self->action, $self->name
        unless 'HASH' eq ref $arg;

    my @params = @{ $self->params };

    my @missing = map { !exists $arg->{$_} ? $_ : () } @params;

    die sprintf "ExtDirect Method %s.%s requires the following ".
                 "parameters: '%s'; these are missing: '%s'\n",
                 $self->action, $self->name,
                 join(', ', @params), join(', ', @missing)
        if @missing;

    return 1;
}

### PUBLIC INSTANCE METHOD ###
#
# Check the metadata for Methods that expect it by-name
#

sub check_named_metadata {
    my ($self, $meta) = @_;

    die sprintf "ExtDirect Method %s.%s expects metadata key/value ".
                "pairs in hashref\n", $self->action, $self->name
        unless 'HASH' eq ref $meta;

    my $meta_def = $self->metadata;
    my @meta_params = @{ $meta_def->{params} };

    my @missing = map { !exists $meta->{$_} ? $_ : () } @meta_params;

    die sprintf "ExtDirect Method %s.%s requires the following ".
                "metadata keys: '%s'; these are missing: '%s'\n",
                $self->action, $self->name,
                join(', ', @meta_params), join(', ', @missing)
        if @missing;

    return 1;
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the arguments for a Method with named parameters
#

sub prepare_named_arguments {
    my ($self, %arg) = @_;

    my $env   = $arg{env};
    my $input = $arg{input};

    my %actual_arg;

    my $strict = $self->strict;
    $strict = 1 unless defined $strict;

    if ( $strict ) {
        my @names = @{ $self->params };

        @actual_arg{ @names } = @$input{ @names };
    }
    else {
        %actual_arg = %$input;
    }

    if ( defined (my $env_arg = $self->env_arg) ) {
        $actual_arg{ $env_arg } = $env;
    }

    my $meta_def = $self->metadata;

    if ( $meta_def && defined (my $meta_arg = $meta_def->{arg}) ) {
        my $meta = $self->prepare_method_metadata(%arg);
        $actual_arg{ $meta_arg } = $meta if defined $meta;
    }

    return wantarray ? %actual_arg : { %actual_arg };
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the metadata for Methods that expect it by-name
#

sub prepare_named_metadata {
    my ($self, %arg) = @_;

    my $meta_def   = $self->metadata;
    my $meta_input = $arg{metadata};

    return unless $meta_input;

    my %meta;

    my $strict = $meta_def->{strict};
    $strict = 1 unless defined $strict;

    if ( $strict ) {
        my @params = @{ $meta_def->{params} };

        @meta{ @params } = @$meta_input{ @params };
    }
    else {
        %meta = %$meta_input;
    }

    return \%meta;
}

### PUBLIC INSTANCE METHOD ###
#
# Check the arguments for a Method with ordered parameters
#

sub check_ordered_arguments {
    my ($self, $input) = @_;

    my $want_len = $self->len;

    # Historically Ext.Direct on the JavaScript client side sent null value
    # instead of empty array for ordered Methods that accept 0 arguments.
    die sprintf "ExtDirect Method %s.%s expects ordered arguments " .
                "in arrayref\n", $self->action, $self->name
        if $want_len > 0 && 'ARRAY' ne ref $input;

    my $have_len = $want_len > 0 ? @$input : 0;

    die sprintf "ExtDirect Method %s.%s requires %d argument(s) ".
                "but only %d are provided\n",
                $self->action, $self->name, $want_len, $have_len
        unless $have_len >= $want_len;

    return 1;
}

### PUBLIC INSTANCE METHOD ###
#
# Check the metadata for Methods that expect it by-position
#

sub check_ordered_metadata {
    my ($self, $meta) = @_;

    die sprintf "ExtDirect Method %s.%s expects metadata in arrayref\n",
                $self->action, $self->name
        unless 'ARRAY' eq ref $meta;

    my $meta_def = $self->metadata;
    my $want_len = $meta_def->{len};
    my $have_len = @$meta;

    die sprintf "ExtDirect Method %s.%s requires %d metadata ".
                "value(s) but only %d are provided\n",
                $self->action, $self->name, $want_len, $have_len
        unless $have_len >= $want_len;

    return 1;
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the arguments for a Method with ordered parameters
#

sub prepare_ordered_arguments {
    my ($self, %arg) = @_;

    my $env   = $arg{env};
    my $input = $arg{input};

    my @actual_arg;

    # For Methods with 0 accepted arguments, input may be either
    # an empty array from RPC::ExtDirect::Client, or undef from
    # the JavaScript client. Hysterical raisins are hysterical,
    # so we have to account for that.
    if ( my $want_len = $self->len ) {
        # Input is by reference! Unpack to avoid changing it.
        my @data = @$input;
        @actual_arg = splice @data, 0, $want_len;
    }

    no warnings;    ## no critic

    if ( defined (my $env_arg = +$self->env_arg) ) {
        # Splicing an empty array at negative subscript will result
        # in a fatal error; we need to guard against that.
        $env_arg = 0 if $env_arg < 0 && -$env_arg > @actual_arg;

        splice @actual_arg, $env_arg, 0, $env;
    }

    my $meta_def = $self->metadata;

    if ( $meta_def && defined (my $meta_arg = +$meta_def->{arg}) ) {
        my $meta = $self->prepare_method_metadata(%arg);

        if ( defined $meta ) {
            $meta_arg = 0 if $meta_arg < 0 && -$meta_arg > @actual_arg;

            splice @actual_arg, $meta_arg, 0, $meta;
        }
    }

    return wantarray ? @actual_arg : [ @actual_arg ];
}

### PUBLIC INSTANCE METHOD ###
#
# Prepare the metadata for Methods that expect it by-position
#

sub prepare_ordered_metadata {
    my ($self, %arg) = @_;

    my $meta_def   = $self->metadata;
    my $meta_input = $arg{metadata};

    return unless $meta_input;

    # Copy array elements to avoid mutating the arrayref
    my @meta_data   = @$meta_input;
    my @meta_output = splice @meta_data, 0, $meta_def->{len};

    return \@meta_output;
}

### PUBLIC INSTANCE METHOD ###
#
# Read-only getter for backward compatibility
#

sub is_formhandler { shift->formHandler }

### PUBLIC INSTANCE METHODS ###
#
# Simple read-write accessors
#

my $accessors = [qw/
    config
    action
    name
    params
    len
    metadata
    formHandler
    pollHandler
    is_ordered
    is_named
    strict
    package
    env_arg
    upload_arg
    meta_arg
    argument_checker
    argument_preparer
    metadata_checker
    metadata_preparer
    decode_params
/,
    __PACKAGE__->HOOK_TYPES,
];

RPC::ExtDirect::Util::Accessor::mk_accessors(
    simple => $accessors,
);

############## PRIVATE METHODS BELOW ##############

### PRIVATE INSTANCE METHOD ###
#
# Parse metadata definition and run sanity checks.
#
# This method has side effects on $arg!
#

sub _parse_metadata {
    my ($self, $arg) = @_;

    my $meta = delete $arg->{metadata};

    if ( 'HASH' eq ref $meta ) {
        my $meta_def = {};

        if ( defined (my $len = $meta->{len}) ) {
            # Metadata is optional so ordered with 0 arguments
            # does not make any sense
            die [
                    sprintf "ExtDirect Method %s.%s cannot accept ".
                            "0 arguments for ordered metadata",
                            $arg->{action}, $arg->{name}
                ]
                unless $len > 0;

            $meta_def->{len} = $len;

            $arg->{metadata_checker}  = 'check_ordered_metadata';
            $arg->{metadata_preparer} = 'prepare_ordered_metadata';
        }
        else {
            my $params = $meta->{params} || [];

            # Same as with main arguments; force !strict if named metadata
            # has empty params
            my $strict = !@$params               ? !1
                       : defined $meta->{strict} ? $meta->{strict}
                       :                           undef
                       ;

            # !strict with no params might be a typo or something;
            # worth a warning in that case
            carp sprintf "ExtDirect Method %s.%s implies strict ".
                         "argument checking for named metadata, ".
                         "but no parameter names are specified.",
                         $arg->{action}, $arg->{name}
                if !@$params && (!defined $meta->{strict} || $meta->{strict});

            $meta_def->{strict} = $strict;
            $meta_def->{params} = $params;

            $arg->{metadata_checker}  = 'check_named_metadata';
            $arg->{metadata_preparer} = 'prepare_named_metadata';
        }

        $meta_def->{arg} = $self->_get_meta_arg($meta, $arg);

        $arg->{metadata} = $meta_def;
    }
}

### PRIVATE INSTANCE METHOD ###
#
# Check that the metadata has valid argument name or position
# to be applied to the called Method.
#
# This code is split from the method above so that we could
# override it in the Client which doesn't need to run the same
# checks as the server side.
#

sub _get_meta_arg {
    my ($self, $meta, $arg) = @_;

    my $meta_arg = $meta->{arg};

    if ( $self->is_ordered ) {
        # There is no way to splice new elements at the end of array
        # without knowing array length. Splicing at negative subscripts
        # will not do what is expected, and I don't see a sane default
        # otherwise. So insist on having the arg defined.
        die [
                sprintf "ExtDirect Method %s.%s cannot accept ".
                        "ordered metadata with no arg position specified",
                        $arg->{action}, $arg->{name}
            ]
            unless defined $meta_arg;
    }
    else {
        $meta_arg = defined $meta_arg ? $meta_arg : 'metadata';
    }

    return $meta_arg;
}

1;