File Coverage

blib/lib/RPC/ExtDirect/Client.pm
Criterion Covered Total %
statement 302 311 97.1
branch 84 110 76.3
condition 29 43 67.4
subroutine 48 52 92.3
pod 7 11 63.6
total 470 527 89.1


line stmt bran cond sub pod time code
1             package RPC::ExtDirect::Client;
2              
3 11     11   826990 use strict;
  11         16  
  11         259  
4 11     11   39 use warnings;
  11         13  
  11         244  
5 11     11   33 no warnings 'uninitialized';
  11         14  
  11         261  
6              
7 11     11   33 use Carp;
  11         9  
  11         586  
8 11     11   604 use JSON;
  11         9761  
  11         57  
9              
10 11     11   951 use File::Spec;
  11         11  
  11         206  
11              
12 11     11   845 use RPC::ExtDirect::Util ();
  11         3255  
  11         197  
13 11     11   847 use RPC::ExtDirect::Config;
  11         14921  
  11         191  
14 11     11   838 use RPC::ExtDirect;
  11         19388  
  11         64  
15              
16             #
17             # This module is not compatible with RPC::ExtDirect < 3.0
18             #
19              
20             croak __PACKAGE__." requires RPC::ExtDirect 3.0+"
21             if $RPC::ExtDirect::VERSION lt '3.0';
22              
23             ### PACKAGE GLOBAL VARIABLE ###
24             #
25             # Module version
26             #
27              
28             our $VERSION = '1.25';
29              
30             ### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
31             #
32             # Instantiate a new Client, connect to the specified server
33             # and initialize the Ext.Direct API
34             #
35              
36             sub new {
37 14     14 1 65013 my ($class, %params) = @_;
38            
39 14         55 my $api = delete $params{api};
40 14   66     594 my $config = delete $params{config} || ($api && $api->config) ||
41             RPC::ExtDirect::Config->new();
42            
43 14         10971 my $self = bless {
44             config => $config,
45             api => {},
46             tid => 0,
47             }, $class;
48            
49 14         116 $self->_decorate_config($config);
50 14 100       43 $self->_decorate_api($api) if $api;
51            
52 14         79 my @config_params = qw/
53             api_path router_path poll_path remoting_var polling_var
54             /;
55            
56 14         45 for my $key ( @config_params ) {
57             $config->$key( delete $params{ $key } )
58 70 50       119 if exists $params{ $key };
59             }
60            
61 14         50 my @our_params = qw/ host port proto cv cookies api_cb /;
62            
63 14         168 @$self{ @our_params } = delete @params{ @our_params };
64            
65             # The rest of parameters apply to the transport
66 14         340 $self->http_params({ %params });
67            
68             # This may die()
69 14         83 eval { $self->_init_api($api) };
  14         53  
70            
71 14 0       39 if ($@) { croak 'ARRAY' eq ref($@) ? $@->[0] : $@ };
  0 50       0  
72            
73 14         81 return $self;
74             }
75              
76             ### PUBLIC INSTANCE METHOD ###
77             #
78             # Call specified Action's Method
79             #
80              
81 32     32 1 34516 sub call { shift->sync_request('call', @_) }
82              
83             ### PUBLIC INSTANCE METHOD ###
84             #
85             # Submit a form to specified Action's Method
86             #
87              
88 9     9 1 10908 sub submit { shift->sync_request('form', @_) }
89              
90             ### PUBLIC INSTANCE METHOD ###
91             #
92             # Upload a file using POST form. Same as submit()
93             #
94              
95             *upload = *submit;
96              
97             ### PUBLIC INSTANCE METHOD ###
98             #
99             # Poll server for Ext.Direct events
100             #
101              
102 11     11 1 5415 sub poll { shift->sync_request('poll', @_) }
103              
104             ### PUBLIC INSTANCE METHOD ###
105             #
106             # Run a specified request type synchronously
107             #
108              
109             sub sync_request {
110 52     52 0 75 my $self = shift;
111 52         80 my $type = shift;
112            
113 52         120 my $tr_class = $self->transaction_class;
114            
115 52         71 my $resp = eval {
116 52         303 my $transaction = $tr_class->new(@_);
117 52         181 $self->_sync_request($type, $transaction);
118             };
119            
120             #
121             # Internally we throw an exception string enclosed in arrayref,
122             # so that die() wouldn't munge it. Easier to do and beats stripping
123             # that \n any time. JSON or other packages could throw a plain string
124             # though, so we need to guard against that.
125             #
126             # Rethrow by croak(), and don't strip the file name and line number
127             # this time -- seeing exactly where the thing blew up in *your*
128             # code is a lot more helpful to a developer than the plain old die()
129             # exception would allow.
130             #
131 52 50       205 if ($@) { croak 'ARRAY' eq ref($@) ? $@->[0] : $@ };
  14 100       1339  
132            
133             # We're only interested in the data, unless it's a poll. In versions
134             # < 1.0, we used to return a scalar value for polls, either a single
135             # event or an arrayref of event hashrefs; that behavior was more or
136             # less closely following the spec and typical server response.
137             # However that was kinda awkward, so we try to DWIM here and adjust
138             # to the caller's expectations.
139 38 100       95 if ( $type eq 'poll') {
140 11 100       67 return wantarray ? @$resp
    100          
141             : @$resp == 1 ? $resp->[0]
142             : $resp
143             ;
144             }
145            
146 27 100       176 return ref($resp) =~ /Exception/ ? $resp : $resp->{result};
147             }
148              
149             ### PUBLIC INSTANCE METHOD ###
150             #
151             # Return next TID (transaction ID)
152             #
153              
154 28     28 0 368 sub next_tid { $_[0]->{tid}++ }
155              
156             ### PUBLIC INSTANCE METHOD ###
157             #
158             # Return API object by its type
159             #
160              
161             sub get_api {
162 87     87 1 1737 my ($self, $type) = @_;
163            
164 87         196 return $self->{api}->{$type};
165             }
166              
167             ### PUBLIC INSTANCE METHOD ###
168             #
169             # Store the passed API object according to its type
170             #
171              
172             sub set_api {
173 28     28 0 38 my ($self, $api, $type) = @_;
174            
175 28   66     450 $type ||= $api->type;
176            
177 28         220 $self->{api}->{$type} = $api;
178             }
179              
180             ### PUBLIC INSTANCE METHODS ###
181             #
182             # Read-only accessor delegates
183             #
184              
185 0     0 1 0 sub remoting_var { $_[0]->config->remoting_var }
186 0     0 1 0 sub polling_var { $_[0]->config->polling_var }
187              
188             ### PUBLIC INSTANCE METHOD ###
189             #
190             # Return the name of the Transaction class. This was not made
191             # a Config option since the only case when somebody would want
192             # to change that is in a subclass.
193             #
194              
195 52     52 0 93 sub transaction_class { 'RPC::ExtDirect::Client::Transaction' }
196              
197             ### PUBLIC INSTANCE METHODS ###
198             #
199             # Read-write accessors
200             #
201              
202             RPC::ExtDirect::Util::Accessor->mk_accessor(
203             simple => [qw/ config host port proto cv cookies http_params api_cb /],
204             );
205              
206             ############## PRIVATE METHODS BELOW ##############
207              
208             ### PRIVATE INSTANCE METHOD ###
209             #
210             # Create a new Exception object
211             #
212              
213             sub _exception {
214 1     1   3 my ($self, $ex) = @_;
215            
216 1         40 my $config = $self->config;
217 1         33 my $exclass = $config->exception_class;
218            
219 1         62 eval "require $exclass";
220            
221 1         1646 return $exclass->new($ex);
222             }
223              
224             ### PRIVATE INSTANCE METHOD ###
225             #
226             # Add the Client-specific accessors to a Config instance
227             # and set defaults
228             #
229              
230             my %std_config = (
231             api_class_client => 'RPC::ExtDirect::Client::API',
232             transport_class => 'HTTP::Tiny',
233             );
234              
235             sub _decorate_config {
236 14     14   39 my ($self, $config) = @_;
237            
238 14         180 $config->add_accessors(
239             overwrite => 1,
240             simple => [ keys %std_config ],
241             );
242            
243 14         6290 for my $key ( keys %std_config ) {
244 28         135294 my $predicate = "has_${key}";
245            
246 28 100       655 $config->$key( $std_config{ $key } )
247             unless $config->$predicate;
248            
249             # This is the best place to load the classes, too
250             # since we only want to do this once.
251 28         1202 eval "require " . $config->$key;
252             }
253            
254 14         126718 my $std_m_class = 'RPC::ExtDirect::Client::API::Method';
255            
256 14 100       75 $config->api_method_class($std_m_class)
257             if $config->_is_default('api_method_class');
258            
259             # Client uses a flavor of API::Method with disabled
260             # metadata arg checks; since the user might have set
261             # the config value we want to make sure the class
262             # has relevant overrides.
263 14         978 my $actual_m_class = $config->api_method_class;
264            
265 14 50 33     105 croak __PACKAGE__ . " is configured to use API Method class ".
266             "$actual_m_class that is not a subclass of $std_m_class"
267             unless $actual_m_class eq $std_m_class ||
268             $actual_m_class->isa($std_m_class);
269             }
270              
271             ### PRIVATE INSTANCE METHOD ###
272             #
273             # Make sure that the API instance passed to us is a subclass
274             # of RPC::ExtDirect::Client::API
275             #
276              
277             sub _decorate_api {
278 4     4   4 my ($self, $api) = @_;
279            
280 4         66 my $api_class = $self->config->api_class_client;
281            
282 4 100       115 bless $api, $api_class unless $api->isa($api_class);
283             }
284              
285             ### PRIVATE INSTANCE METHOD ###
286             #
287             # Initialize API declaration.
288             #
289             # The two-step between _init_api and _import_api is to allow
290             # async API retrieval and processing in Client::Async without
291             # duplicating more code than is necessary
292             #
293              
294             sub _init_api {
295 14     14   16 my ($self, $api) = @_;
296            
297 14 100       52 if ( $api ) {
298 4         8 $self->_assign_api($api);
299             }
300             else {
301 10         44 my $api_js = $self->_get_api();
302            
303 10         45 $self->_import_api($api_js);
304             }
305             }
306              
307             ### PRIVATE INSTANCE METHOD ###
308             #
309             # Assign API object to the corresponding slots
310             #
311              
312             sub _assign_api {
313 4     4   4 my ($self, $api) = @_;
314            
315 4         9 $self->set_api($api, 'remoting');
316            
317 4 50       17 if ( $api->get_poll_handlers ) {
318 4         297 $self->set_api($api, 'polling');
319             }
320             }
321              
322             ### PRIVATE INSTANCE METHOD ###
323             #
324             # Receive API declaration from specified server,
325             # parse it and return Client::API object
326             #
327              
328             sub _get_api {
329 10     10   24 my ($self) = @_;
330              
331 10         44 my $uri = $self->_get_uri('api');
332 10         154 my $params = $self->http_params;
333            
334 10         177 my $transport_class = $self->config->transport_class;
335              
336 10         259 my $resp = $transport_class->new(%$params)->get($uri);
337              
338             die ["Can't download API declaration: $resp->{status} $resp->{content}"]
339 10 50       266695 unless $resp->{success};
340              
341 10 50       40 die ["Empty API declaration"] unless length $resp->{content};
342              
343 10         52 return $resp->{content};
344             }
345              
346             ### PRIVATE INSTANCE METHOD ###
347             #
348             # Import specified API into global namespace
349             #
350              
351             sub _import_api {
352 10     10   21 my ($self, $api_js) = @_;
353            
354 10         333 my $config = $self->config;
355 10         247 my $remoting_var = $config->remoting_var;
356 10         214 my $polling_var = $config->polling_var;
357 10         206 my $api_class = $config->api_class_client;
358            
359 10         616 eval "require $api_class";
360            
361 10         1711 $api_js =~ s/\s*//gms;
362            
363 10         88 my @parts = split /;\s*/, $api_js;
364            
365 10         158 my $api_regex = qr/^\Q$remoting_var\E|\Q$polling_var\E/;
366            
367 10         32 for my $part ( @parts ) {
368 20 50       89 next unless $part =~ $api_regex;
369            
370 20         92 my $api = $api_class->new_from_js(
371             config => $config,
372             js => $part,
373             );
374            
375 20         48 $self->set_api($api);
376             }
377             }
378              
379             ### PRIVATE INSTANCE METHOD ###
380             #
381             # Return URI for specified type of call
382             #
383              
384             sub _get_uri {
385 57     57   2277 my ($self, $type) = @_;
386            
387 57         1225 my $config = $self->config;
388            
389 57         270 my $api;
390            
391 57 100 100     252 if ( $type eq 'remoting' || $type eq 'polling' ) {
392 44         95 $api = $self->get_api($type);
393            
394 44 50       98 die ["Don't have API definition for type $type"]
395             unless $api;
396             }
397            
398 57   100     1008 my $proto = $self->proto || 'http';
399 57         1288 my $host = $self->host;
400 57         1150 my $port = $self->port;
401              
402 57 50 66     1302 my $path = $type eq 'api' ? $config->api_path
    100 66        
    100          
403             : $type eq 'remoting' ? $api->url || $config->router_path
404             : $type eq 'polling' ? $api->url || $config->poll_path
405             : die ["Unknown type $type"]
406             ;
407              
408 57         621 $path =~ s{^/}{};
409              
410 57 100       223 my $uri = $port ? "$proto://$host:$port/$path"
411             : "$proto://$host/$path"
412             ;
413              
414 57         93 return $uri;
415             }
416              
417             ### PRIVATE INSTANCE METHOD ###
418             #
419             # Normalize passed arguments to conform to Method's spec
420             #
421              
422             sub _normalize_arg {
423 30     30   34 my ($self, $method, $trans) = @_;
424            
425 30         606 my $arg = $trans->arg;
426            
427             # This could die with a message that has \n at the end to prevent
428             # file and line being appended. Catch and rethrow in a format
429             # more compatible with what Client does in other places.
430 30         151 eval { $method->check_method_arguments($arg) };
  30         157  
431            
432 30 100       2063 if ( my $xcpt = $@ ) {
433 6         22 $xcpt =~ s/\n$//;
434 6         37 die [$xcpt];
435             }
436              
437 24         91 my $result = $method->prepare_method_arguments( input => $arg );
438              
439 24         2366 return $result;
440             }
441              
442             ### PRIVATE INSTANCE METHOD ###
443             #
444             # Normalize passed metadata to conform to Method's spec
445             #
446              
447             sub _normalize_metadata {
448 32     32   42 my ($self, $method, $trans) = @_;
449            
450 32         556 my $meta = $trans->metadata;
451            
452             # See _normalize_arg above
453 32         144 eval { $method->check_method_metadata($meta) };
  32         97  
454            
455 32 100       1665 if ( my $xcpt = $@ ) {
456 5         18 $xcpt =~ s/\n$//;
457 5         23 die [$xcpt];
458             }
459            
460 27         89 my $result = $method->prepare_method_metadata( metadata => $meta );
461            
462 27         1172 return $result;
463             }
464              
465             ### PRIVATE INSTANCE METHOD ###
466             #
467             # Normalize passed arguments to submit as form POST
468             #
469              
470             sub _formalize_arg {
471 9     9   10 my ($self, $method, $trans) = @_;
472            
473 9         171 my $arg = $trans->arg;
474 9         248 my $upload = $trans->upload;
475            
476             # formHandler method require arguments in a hashref and will die
477             # with an error if the arguments are missing. However it is often
478             # convenient to call Client->upload() with empty arg but with a
479             # list of file names to upload; it doesn't make a lot of sense to
480             # insist on providing an empty argument hashref just for the sake
481             # of being strict.
482 9 100 50     58 $arg = $arg || {} if $upload;
483            
484             # This could die with a message that has \n at the end to prevent
485             # file and line being appended. Catch and rethrow in a format
486             # more compatible with what Client does in other places.
487 9         10 eval { $method->check_method_arguments($arg) };
  9         49  
488            
489 9 50       300 if ( my $xcpt = $@ ) {
490 0         0 $xcpt =~ s/\n$//;
491 0         0 die [$xcpt];
492             }
493            
494 9         168 my $fields = {
495             extAction => $method->action,
496             extMethod => $method->name,
497             extType => 'rpc',
498             extTID => $self->next_tid,
499             };
500              
501             # Go over the uploads and check if they're readable; die if not
502 9         36 for my $file ( @$upload ) {
503 9 100       110 die ["Upload entry '$file' is not readable"] unless -r $file;
504             }
505            
506 8 50       38 $fields->{extUpload} = 'true' if $upload;
507              
508 8         23 my $actual_arg = $method->prepare_method_arguments( input => $arg );
509            
510 8         839 @$fields{ keys %$actual_arg } = values %$actual_arg;
511              
512             # This will die in approved format, so no outer eval
513 8         16 my $meta_json = $self->_formalize_metadata($method, $trans);
514            
515 8 100       17 $fields->{metadata} = $meta_json if $meta_json;
516              
517 8         18 return $fields;
518             }
519              
520             ### PRIVATE INSTANCE METHOD ###
521             #
522             # Normalize passed metadata to conform to Method's spec
523             # and encode in JSON to be submitted in a form POST
524             #
525              
526             sub _formalize_metadata {
527 8     8   12 my ($self, $method, $transaction) = @_;
528            
529 8         7 my $meta_json;
530            
531             # This will die according to plan so no outer eval
532 8         16 my $metadata = $self->_normalize_metadata($method, $transaction);
533            
534 8 100       18 if ( $metadata ) {
535             # This won't die according to plan :(
536 2         3 $meta_json = eval { JSON::to_json($metadata) };
  2         6  
537            
538 2 50       36 if ( $@ ) {
539 0         0 my $xcpt = RPC::ExtDirect::Util::clean_error_message($@);
540 0         0 die [$xcpt];
541             }
542             }
543            
544 8         11 return $meta_json;
545             }
546              
547             ### PRIVATE INSTANCE METHOD ###
548             #
549             # Make an HTTP request in synchronous fashion. Note that we do not
550             # guard against exceptions here, they should be propagated upwards
551             # to be caught in public sync_request() that calls this one.
552             #
553              
554             sub _sync_request {
555 52     52   77 my ($self, $type, $transaction) = @_;
556            
557 52         103 my $prepare = "_prepare_${type}_request";
558 52         74 my $handle = "_handle_${type}_response";
559 52 100       152 my $method = $type eq 'poll' ? 'GET' : 'POST';
560            
561 52         201 my ($uri, $request_content, $http_params, $request_options)
562             = $self->$prepare($transaction);
563            
564 38         58 $request_options->{content} = $request_content;
565            
566 38         707 my $transport_class = $self->config->transport_class;
567            
568 38         1133 my $transport = $transport_class->new(%$http_params);
569 38         2634 my $response = $transport->request($method, $uri, $request_options);
570            
571             # By Ext.Direct spec that shouldn't even happen; however the transport
572             # may crap out or something else might cause a failed request.
573             # Status code 599 is internal for HTTP::Tiny, with the error message
574             # placed in the response content.
575 38 50       316192 if (!$response->{success}) {
576             my $err = $response->{status} == 599 ? $response->{content}
577             : $response->{status}
578 0 0       0 ;
579 0         0 die ["Ext.Direct request unsuccessful: $err"];
580             }
581            
582 38         176 return $self->$handle($response, $transaction);
583             }
584              
585             ### PRIVATE INSTANCE METHOD ###
586             #
587             # Prepare the POST body, headers, request options and other
588             # data necessary to make an HTTP request for a non-form call
589             #
590              
591             sub _prepare_call_request {
592 32     32   31 my ($self, $transaction) = @_;
593            
594 32         857 my $action_name = $transaction->action;
595 32         768 my $method_name = $transaction->method;
596            
597 32         205 my $api = $self->get_api('remoting');
598 32         137 my $action = $api->get_action_by_name($action_name);
599            
600 32 100       179 die ["Action $action_name is not found"] unless $action;
601            
602 31         108 my $method = $action->method($method_name);
603            
604 31 100       162 die ["Method $method_name is not found in Action $action_name"]
605             unless $method;
606            
607 30         78 my $actual_arg = $self->_normalize_arg($method, $transaction);
608 24         73 my $metadata = $self->_normalize_metadata($method, $transaction);
609            
610 19         70 my $post_body = $self->_encode_post_body(
611             action => $action_name,
612             method => $method_name,
613             data => $actual_arg,
614             metadata => $metadata,
615             );
616            
617             # HTTP params is a union between transaction params and client params.
618 19         103 my $http_params = $self->_merge_params($transaction);
619              
620 19         70 my $request_options = {
621             headers => { 'Content-Type' => 'application/json', }
622             };
623              
624 19         46 $self->_parse_cookies($request_options, $http_params);
625              
626 19         45 my $uri = $self->_get_uri('remoting');
627            
628             return (
629 19         62 $uri,
630             $post_body,
631             $http_params,
632             $request_options,
633             );
634             }
635              
636             ### PRIVATE INSTANCE METHOD ###
637             #
638             # Prepare the POST body, headers, request options and other
639             # data necessary to make an HTTP request for a form call
640             #
641              
642             sub _prepare_form_request {
643 9     9   13 my ($self, $transaction) = @_;
644            
645 9         232 my $action_name = $transaction->action;
646 9         193 my $method_name = $transaction->method;
647            
648 9         52 my $api = $self->get_api('remoting');
649 9         27 my $action = $api->get_action_by_name($action_name);
650            
651 9 50       48 die ["Action $action_name is not found"] unless $action;
652            
653 9         26 my $method = $action->method($method_name);
654            
655 9 50       44 die ["Method $method_name is not found in Action $action_name"]
656             unless $method;
657            
658 9         27 my $fields = $self->_formalize_arg($method, $transaction);
659 8         137 my $upload = $transaction->upload;
660            
661 8 100       48 my $form_body
662             = $upload ? $self->_www_form_multipart($fields, $upload)
663             : $self->_www_form_urlencode($fields)
664             ;
665            
666 8 100       1061 my $ct
667             = $upload ? 'multipart/form-data; boundary='.$self->_get_boundary
668             : 'application/x-www-form-urlencoded; charset=utf-8'
669             ;
670            
671 8         27 my $request_options = {
672             headers => { 'Content-Type' => $ct, },
673             };
674            
675 8         22 my $http_params = $self->_merge_params($transaction);
676            
677 8         20 $self->_parse_cookies($request_options, $http_params);
678            
679 8         20 my $uri = $self->_get_uri('remoting');
680            
681             return (
682 8         31 $uri,
683             $form_body,
684             $http_params,
685             $request_options,
686             );
687             }
688              
689             ### PRIVATE INSTANCE METHOD ###
690             #
691             # Prepare the POST body, headers, request options and other
692             # data necessary to make an HTTP request for an event poll
693             #
694              
695             sub _prepare_poll_request {
696 11     11   19 my ($self, $transaction) = @_;
697            
698 11         30 my $uri = $self->_get_uri('polling');
699            
700 11         38 my $http_params = $self->_merge_params($transaction);
701            
702 11         57 my $request_options = {
703             headers => { 'Content-Type' => 'application/json' },
704             };
705            
706 11         33 $self->_parse_cookies($request_options, $http_params);
707            
708             return (
709 11         23 $uri,
710             undef,
711             $http_params,
712             $request_options,
713             );
714             }
715              
716             ### PRIVATE INSTANCE METHOD ###
717             #
718             # Create POST payload body
719             #
720              
721             sub _create_post_payload {
722 19     19   70 my ($self, %arg) = @_;
723            
724             my $href = {
725             type => 'rpc',
726             tid => $self->next_tid,
727             action => $arg{action},
728             method => $arg{method},
729             data => $arg{data},
730 19         46 };
731            
732             $href->{metadata} = $arg{metadata}
733 19 50       65 if exists $arg{metadata};
734            
735 19         32 return $href;
736             }
737              
738             ### PRIVATE INSTANCE METHOD ###
739             #
740             # Encode post payload body
741             #
742              
743             sub _encode_post_body {
744 19     19   26 my $self = shift;
745            
746 19         54 my $payload = $self->_create_post_payload(@_);
747              
748 19         316 return JSON->new->utf8(1)->encode($payload);
749             }
750              
751             ### PRIVATE INSTANCE METHOD ###
752             #
753             # Encode form fields as multipart/form-data
754             #
755              
756             sub _www_form_multipart {
757 1     1   1 my ($self, $arg, $uploads) = @_;
758              
759             # This code is shamelessly "adapted" from CGI::Test::Input::Multipart
760 1         2 my $CRLF = "\015\012";
761 1         5 my $boundary = '--' . $self->_get_boundary();
762 1         1 my $format = 'Content-Disposition: form-data; name="%s"';
763              
764 1         1 my $result;
765              
766 1         6 foreach my $field (keys %$arg) {
767 5         5 my $value = $arg->{$field};
768            
769 5         5 $result .= $boundary . $CRLF;
770 5         8 $result .= sprintf($format, $field) . $CRLF.$CRLF;
771 5         8 $result .= $value . $CRLF;
772             };
773              
774 1   66     9 while ( $uploads && @$uploads ) {
775 8         8 my $filename = shift @$uploads;
776 8         68 my $basename = (File::Spec->splitpath($filename))[2];
777              
778 8         9 $result .= $boundary . $CRLF;
779 8         16 $result .= sprintf $format, 'upload';
780 8         9 $result .= sprintf('; filename="%s"', $basename) . $CRLF;
781 8         8 $result .= "Content-Type: application/octet-stream" . $CRLF.$CRLF;
782              
783 8 50       150 if ( open my $fh, '<', $filename ) {
784 8         9 binmode $fh;
785 8         22 local $/;
786              
787 8         160 $result .= <$fh> . $CRLF;
788             };
789             }
790              
791 1 50       4 $result .= $boundary . '--' if $result;
792              
793 1         13 return $result;
794             }
795              
796             ### PRIVATE INSTANCE METHOD ###
797             #
798             # Generate multipart/form-data boundary
799             #
800              
801             my $boundary;
802              
803             sub _get_boundary {
804 2 100   2   6 return $boundary if $boundary;
805            
806 1         2 my $rand;
807              
808 1         3 for ( 0..19 ) {
809 20         34 $rand .= (0..9, 'A'..'Z')[$_] for int rand 36;
810             };
811              
812 1         3 return $boundary = $rand;
813             }
814              
815             ### PRIVATE INSTANCE METHOD ###
816             #
817             # Encode form fields as application/x-www-form-urlencoded
818             #
819              
820             sub _www_form_urlencode {
821 7     7   8 my ($self, $arg) = @_;
822            
823 7         104 my $transport_class = $self->config->transport_class;
824              
825 7         164 return $transport_class->new->www_form_urlencode($arg);
826             }
827              
828             ### PRIVATE INSTANCE METHOD ###
829             #
830             # Produce a union of transaction HTTP parameters
831             # with client HTTP parameters
832             #
833              
834             sub _merge_params {
835 38     38   50 my ($self, $trans) = @_;
836            
837 38         43 my %client_params = %{ $self->http_params };
  38         1221  
838 38         334 my %trans_params = %{ $trans->http_params };
  38         688  
839            
840             # Transaction parameters trump client's
841 38         237 @client_params{ keys %trans_params } = values %trans_params;
842            
843             # Cookies from transaction trump client's as well,
844             # but replace them entirely instead of combining
845 38   100     659 $client_params{cookies} = $trans->cookies || $self->cookies;
846            
847 38         955 return \%client_params;
848             }
849              
850             ### PRIVATE INSTANCE METHOD ###
851             #
852             # Process Ext.Direct response and return either data or exception
853             #
854              
855             sub _handle_call_response {
856 27     27   37 my ($self, $resp) = @_;
857            
858 27         72 my $content = $self->_decode_response_body( $resp->{content} );
859            
860             return $self->_exception($content)
861 27 100 66     270 if 'HASH' eq ref $content and $content->{type} eq 'exception';
862            
863 26         1314 return $content;
864             }
865              
866             *_handle_form_response = *_handle_call_response;
867              
868             ### PRIVATE INSTANCE METHOD ###
869             #
870             # Handle poll response
871             #
872              
873             sub _handle_poll_response {
874 11     11   16 my ($self, $resp) = @_;
875              
876             # JSON->decode can die()
877 11         28 my $ev = $self->_decode_response_body( $resp->{content} );
878              
879             # Poll provider has to return a null event if there are no events
880             # because returning empty response would break JavaScript client
881             # in certain (now outdated) Ext JS versions. The server has to keep
882             # the compatible behavior but we don't have to follow that
883             # broken implementation here.
884             return []
885             if ('HASH' ne ref $ev and 'ARRAY' ne ref $ev) or
886             ('HASH' eq ref $ev and
887             ($ev->{name} eq '__NONE__' or $ev->{name} eq '' or
888 11 50 66     304 $ev->{type} ne 'event')
      66        
      66        
      33        
889             )
890             ;
891            
892             # Server side can return either a single event, or an array
893             # of events. This is how the spec goes. :/ Normalize the output
894             # here so that we could sanitize it upstream.
895 10 100       35 $ev = 'ARRAY' eq ref($ev) ? $ev : [ $ev ];
896              
897 10         31 delete $_->{type} for @$ev;
898              
899 10         432 return $ev;
900             }
901              
902             ### PRIVATE INSTANCE METHOD ###
903             #
904             # Decode Ext.Direct response body
905             #
906              
907             sub _decode_response_body {
908 38     38   47 my ($self, $body) = @_;
909              
910 38         53 my $json_text = $body;
911              
912             # Form POSTs require this additional handling
913 38         150 my $re = qr{^$}msi;
914              
915 38 100       340 if ( $body =~ $re ) {
916 8         16 $json_text = $1;
917 8         16 $json_text =~ s{\\"}{"}g;
918             };
919              
920 38         743 return JSON->new->utf8(1)->decode($json_text);
921             }
922              
923             ### PRIVATE INSTANCE METHOD ###
924             #
925             # Parse cookies if provided, creating Cookie header
926             #
927              
928             sub _parse_cookies {
929 40     40   9077 my ($self, $to, $from) = @_;
930              
931 40         57 my $cookie_jar = $from->{cookies};
932              
933 40 100       82 return unless $cookie_jar;
934              
935 14         9 my $cookies;
936              
937 14 100       24 if ( 'HTTP::Cookies' eq ref $cookie_jar ) {
938 4         9 $cookies = $self->_parse_http_cookies($cookie_jar);
939             }
940             else {
941 10         20 $cookies = $self->_parse_raw_cookies($cookie_jar);
942             }
943              
944 14 50       48 $to->{headers}->{Cookie} = $cookies if $cookies;
945             }
946              
947             ### PRIVATE INSTANCE METHOD ###
948             #
949             # Parse cookies from HTTP::Cookies object
950             #
951              
952             sub _parse_http_cookies {
953 4     4   5 my ($self, $cookie_jar) = @_;
954              
955 4         3 my @cookies;
956              
957             $cookie_jar->scan(sub {
958 8     8   74 my ($v, $key, $value) = @_;
959              
960 8         20 push @cookies, "$key=$value";
961 4         25 });
962              
963 4         22 return \@cookies;
964             }
965              
966             ### PRIVATE INSTANCE METHOD ###
967             #
968             # Parse (or rather, normalize) cookies passed as a hashref
969             #
970              
971             sub _parse_raw_cookies {
972 10     10   6 my ($self, $cookie_jar) = @_;
973              
974 10 50       20 return [] unless 'HASH' eq ref $cookie_jar;
975              
976 10         19 return [ map { join '=', $_ => $cookie_jar->{$_} } keys %$cookie_jar ];
  20         48  
977             }
978              
979             package
980             RPC::ExtDirect::Client::Transaction;
981              
982             my @fields = qw/ action method arg upload cookies metadata /;
983              
984             sub new {
985 52     52   196 my ($class, %params) = @_;
986            
987 52         95 my %self_params = map { $_ => delete $params{$_} } @fields;
  312         591  
988            
989 52         338 return bless {
990             http_params => { %params },
991             %self_params,
992             }, $class;
993             }
994              
995       0     sub start {}
996       0     sub finish {}
997              
998             RPC::ExtDirect::Util::Accessor->mk_accessors(
999             simple => ['http_params', @fields],
1000             );
1001              
1002             1;