File Coverage

blib/lib/RPC/ExtDirect.pm

Criterion	Covered	Total	%
statement	82	89	92.1
branch	22	32	68.7
condition			n/a
subroutine	17	19	89.4
pod	0	10	0.0
total	121	150	80.6

package RPC::ExtDirect;

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

use Carp;
use Attribute::Handlers;

use RPC::ExtDirect::API;
use RPC::ExtDirect::Util;

### PACKAGE VARIABLE ###
#
# Version of this module. This should be kept as a string
# because otherwise 'make dist' strips "insignificant" digits
# at the end.
#

our $VERSION = '3.23';

### PACKAGE GLOBAL VARIABLE ###
#
# Debugging; defaults to off.
#
# DEPRECATED. Use `debug` Config option instead.
#

our $DEBUG;

# This is a bit hacky, but we've got to keep a reference to the API object
# so that *compilation time* attributes would work as expected,
# as well as the configuration options for the RPC::ExtDirect::API class.
{
    my $api = RPC::ExtDirect::API->new();

    ### PUBLIC CLASS METHOD ###
    #
    # Return the global API instance
    #

    sub get_api { $api }
}


### PUBLIC PACKAGE SUBROUTINE ###
#
# Provides a facility to assign package-level (action) properties.
# Despite its name, does not import anything to the caller package's
# namespace.
#

sub import {
    my ($class, @args) = @_;

    # Nothing to do
    return unless @args;

    # Only hash-like arguments are supported
    croak "Odd number of arguments in RPC::ExtDirect::import()"
        unless (@args % 2) == 0;

    my %arg = @args;
       %arg = map { lc $_ => delete $arg{ $_ } } keys %arg;

    my ($package, $filename, $line) = caller();

    my $api = $class->get_api;

    # Store Action (class) name as an alias for a package
    my $action_name = defined $arg{action} ? $arg{action}
                    : defined $arg{class}  ? $arg{class}
                    :                        undef
                    ;

    # We don't want to overwrite the existing Action, if any
    $api->add_action(
        package      => $package,
        action       => $action_name,
        no_overwrite => 1,
    );

    # Store package level hooks
    for my $type ( $api->HOOK_TYPES ) {
        my $code = $arg{ $type };

        $api->add_hook( package => $package, type => $type, code => $code )
            if defined $code;
    };
}

### PUBLIC ATTRIBUTE DEFINITION ###
#
# Define ExtDirect attribute subroutine and export it into UNIVERSAL
# namespace. Attribute processing phase depends on the perl version
# we're running under.
#

{
    my $phase = $] >= 5.012 ? 'BEGIN' : 'CHECK';
    my $pkg   = __PACKAGE__;

    eval <
    sub UNIVERSAL::ExtDirect : ATTR(CODE,$phase) {
        my \$attr = RPC::ExtDirect::Util::parse_attribute(\@_);

        eval { ${pkg}->add_method(\$attr) };

        if (\$@) { die 'ARRAY' eq ref(\$@) ? \$\@->[0] : \$@ }; };
END
}

### PUBLIC CLASS METHOD ###
#
# Add a hook to the global API
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

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

    my $api = $class->get_api();

    $api->add_hook(%arg);

    return $arg{code};
}

### PUBLIC CLASS METHOD ###
#
# Return hook coderef by package and method, with hierarchical lookup.
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

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

    my $api  = $class->get_api();
    my $hook = $api->get_hook(%arg);

    return $hook ? $hook->code : undef;
}

### PUBLIC CLASS METHOD ###
#
# Adds Action name as an alias for a package
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

sub add_action {
    my ($class, $package, $action_for_pkg) = @_;

    my $api = $class->get_api();

    return $api->add_action(
        package => $package,
        action  => $action_for_pkg,
    );
}

### PUBLIC CLASS METHOD ###
#
# Returns the list of Actions that have ExtDirect methods
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

sub get_action_list {
    my ($class) = @_;

    my $api = $class->get_api();

    my @actions = sort $api->actions();

    return @actions;
}

### PUBLIC CLASS METHOD ###
#
# Returns the list of poll handler methods as list of
# arrayrefs: [ $action, $method ]
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

sub get_poll_handlers {
    my ($class) = @_;

    my $api     = $class->get_api();
    my @actions = $class->get_api->actions;
    my @handlers;

    for my $name ( @actions ) {
        my $action  = $api->get_action_by_name($name);
        my @methods = $action->polling_methods;

        push @handlers, [ $name, $_ ] for @methods;
    }

    return @handlers;
}

### PUBLIC CLASS METHOD ###
#
# Adds a method to the global API
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

sub add_method {
    my ($class, $attribute_ref) = @_;

    my $api = $class->get_api;

    return $api->add_method( %$attribute_ref );
}

### PUBLIC CLASS METHOD ###
#
# Returns the list of method names with ExtDirect attribute
# for $action_name, or all methods for all actions if $action_name
# is empty
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

sub get_method_list {
    my ($class, $action_name) = @_;

    my $api = $class->get_api;

    my @actions = $action_name ? ( $action_name ) : $api->actions;
    my @list;

    for my $name ( @actions ) {
        my $action = $api->get_action_by_name($name);

        # The output of this method is inconsistent:
        # when called with $action_name it returns the list of
        # method names; when it is called with empty @_
        # it returns the list of Action::method pairs.
        # I don't remember  what was the original intent here but
        # we've got to keep up compatibility. The whole method is
        # deprecated anyway...
        my $tpl = $action_name ? "" : $name.'::';

        push @list, map { $tpl.$_ } $action->methods;
    }

    return wantarray ? @list : shift @list;
}

### PUBLIC CLASS METHOD ###
#
# Returns parameters for given action and method name
# with ExtDirect attribute.
#
# Returns full attribute hash in list context.
# Croaks if called in scalar context.
#
# DEPRECATED. See RPC::ExtDirect::API for replacement.
#

sub get_method_parameters {
    my ($class, $action_name, $method_name) = @_;

    croak "Wrong context" unless wantarray;

    croak "ExtDirect action name is required" unless defined $action_name;
    croak "ExtDirect method name is required" unless defined $method_name;

    my $action = $class->get_api->get_action_by_name($action_name);

    croak "Can't find ExtDirect action $action"
        unless $action;

    my $method = $action->method($method_name);

    croak "Can't find ExtDirect properties for method $method_name"
        unless $method;

    return $method->get_api_definition_compat();
}

1;