File Coverage

blib/lib/RPC/ExtDirect/API/Action.pm
Criterion Covered Total %
statement 74 78 94.8
branch 5 8 62.5
condition 2 5 40.0
subroutine 15 16 93.7
pod 10 10 100.0
total 106 117 90.6


line stmt bran cond sub pod time code
1             package RPC::ExtDirect::API::Action;
2              
3 26     26   85 use strict;
  26         22  
  26         576  
4 26     26   72 use warnings;
  26         25  
  26         528  
5 26     26   73 no warnings 'uninitialized'; ## no critic
  26         38  
  26         585  
6              
7 26     26   78 use Carp;
  26         24  
  26         1289  
8              
9 26     26   100 use RPC::ExtDirect::Config;
  26         23  
  26         473  
10 26     26   84 use RPC::ExtDirect::Util::Accessor;
  26         27  
  26         16139  
11              
12             ### PUBLIC CLASS METHOD (ACCESSOR) ###
13             #
14             # Return the hook types supported by this Action class
15             #
16              
17 110     110 1 262 sub HOOK_TYPES { qw/ before instead after / }
18              
19             ### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
20             #
21             # Create a new Action instance
22             #
23              
24             sub new {
25 84     84 1 211 my ($class, %arg) = @_;
26            
27 84         108 my $config = delete $arg{config};
28 84         1669 my $hook_class = $config->api_hook_class;
29            
30             # For the caller, the 'action' parameter makes sense as the Action's
31             # name, but within the Action itself it's just "name" for clarity
32 84         118 my $name = delete $arg{action};
33 84         87 my $package = delete $arg{package};
34 84   50     356 my $methods = delete $arg{methods} || [];
35            
36             # These checks are mostly for debugging
37 84 50       156 croak "Can't create an Action without a name!"
38             unless defined $name;
39            
40             # We accept :: in Action names so that the API would feel
41             # more natural on the Perl side, but convert them to dots
42             # anyway to be compatible with JavaScript
43 84         94 $name =~ s/::/./g;
44            
45             # We avoid hard binding on the hook class
46 84         71 { local $@; eval "require $hook_class"; }
  84         74  
  84         3301  
47            
48 84         156 my %hooks;
49            
50 84         228 for my $type ( $class->HOOK_TYPES ) {
51 252         216 my $hook = delete $arg{ $type };
52            
53 252 50       391 $hooks{ $type } = $hook_class->new( type => $type, code => $hook )
54             if $hook;
55             }
56            
57 84         376 my $self = bless {
58             config => $config,
59             name => $name,
60             package => $package,
61             methods => {},
62             %arg,
63             %hooks,
64             }, $class;
65            
66 84         154 $self->add_method($_) for @$methods;
67            
68 84         220 return $self;
69             }
70              
71             ### PUBLIC INSTANCE METHOD ###
72             #
73             # Merge method definitions from incoming Action object
74             #
75              
76             sub merge {
77 0     0 1 0 my ($self, $action) = @_;
78            
79             # Add the methods, or replace if they exist
80 0         0 $self->add_method(@_) for $action->methods();
81            
82 0         0 return $self;
83             }
84              
85             ### PUBLIC INSTANCE METHOD ###
86             #
87             # Return the list of this Action's Methods' names
88             #
89              
90 88     88 1 68 sub methods { keys %{ $_[0]->{methods} } }
  88         262  
91              
92             ### PUBLIC INSTANCE METHOD ###
93             #
94             # Return the list of this Action's publishable
95             # (non-pollHandler) methods
96             #
97              
98             sub remoting_methods {
99 33     33 1 28 my ($self) = @_;
100            
101 158         168 my @method_names = map { $_->[0] }
102 163         2827 grep { !$_->[1]->pollHandler }
103 33         50 map { [ $_, $self->method($_) ] }
  163         171  
104             $self->methods;
105            
106 33         93 return @method_names;
107             }
108              
109             ### PUBLIC INSTANCE METHOD ###
110             #
111             # Return the list of this Action's pollHandler methods
112             #
113              
114             sub polling_methods {
115 47     47 1 44 my ($self) = @_;
116            
117 15         33 my @method_names = map { $_->[0] }
118 210         3519 grep { $_->[1]->pollHandler }
119 47         62 map { [ $_, $self->method($_) ] }
  210         210  
120             $self->methods;
121            
122 47         111 return @method_names;
123             }
124              
125             ### PUBLIC INSTANCE METHOD ###
126             #
127             # Return the list of API definitions for this Action's
128             # remoting methods
129             #
130              
131             sub remoting_api {
132 33     33 1 30 my ($self, $env) = @_;
133            
134             # Guard against user overrides returning undefs instead of
135             # empty lists
136 33         52 my @method_names = $self->remoting_methods;
137 33         30 my @method_defs;
138            
139 33         43 for my $method_name ( @method_names ) {
140 158         283 my $method = $self->method($method_name);
141 158         233 my $def = $method->get_api_definition($env);
142            
143 158 100       313 push @method_defs, $def if $def;
144             }
145            
146 33         93 return @method_defs;
147             }
148              
149             ### PUBLIC INSTANCE METHOD ###
150             #
151             # Return true if this Action has any pollHandler methods
152             #
153              
154             sub has_pollHandlers {
155 26     26 1 25 my ($self, $env) = @_;
156            
157             # By default we're not using the env object here,
158             # but an user override may do so
159            
160 26         37 my @methods = $self->polling_methods;
161            
162 26         53 return !!@methods;
163             }
164              
165             ### PUBLIC INSTANCE METHOD ###
166             #
167             # Add a method, or replace it if exists.
168             # Accepts Method instances, or hashrefs to be fed
169             # to Method->new()
170             #
171              
172             sub add_method {
173 364     364 1 347 my ($self, $method) = @_;
174            
175 364         6445 my $config = $self->config;
176            
177 364 50       583 if ( 'HASH' eq ref $method ) {
178 364         6126 my $m_class = $config->api_method_class();
179            
180             # This is to avoid hard binding on RPC::ExtDirect::API::Method
181 364         14849 eval "require $m_class";
182            
183 364   33     1221 my $name = delete $method->{method} || delete $method->{name};
184            
185 364         6654 $method = $m_class->new(
186             config => $config,
187             package => $self->package,
188             action => $self->name,
189             name => $name,
190             %$method,
191             );
192             }
193             else {
194 0         0 $method->config($config);
195             }
196            
197 363         6939 my $m_name = $method->name;
198            
199 363         519 $self->{methods}->{ $m_name } = $method;
200            
201 363         5214 return $self;
202             }
203              
204             ### PUBLIC INSTANCE METHOD ###
205             #
206             # Returns a Method object by name
207             #
208              
209             sub method {
210 1056     1056 1 808 my ($self, $method_name) = @_;
211              
212 1056         1832 return $self->{methods}->{ $method_name };
213             }
214              
215             ### PUBLIC INSTANCE METHODS ###
216             #
217             # Simple read-write accessors
218             #
219              
220             my $accessors = [qw/
221             config
222             name
223             package
224             /,
225             __PACKAGE__->HOOK_TYPES,
226             ];
227              
228             RPC::ExtDirect::Util::Accessor::mk_accessors(
229             simple => $accessors,
230             );
231              
232             1;