File Coverage

blib/lib/CGI/ExtDirect.pm
Criterion Covered Total %
statement 62 161 38.5
branch 9 46 19.5
condition 14 33 42.4
subroutine 14 22 63.6
pod 4 5 80.0
total 103 267 38.5


line stmt bran cond sub pod time code
1             package CGI::ExtDirect;
2              
3 6     6   299444 use strict;
  6         9  
  6         134  
4 6     6   20 use warnings;
  6         6  
  6         118  
5 6     6   20 no warnings 'uninitialized'; ## no critic
  6         7  
  6         143  
6              
7 6     6   18 use Carp;
  6         8  
  6         263  
8 6     6   489 use IO::Handle;
  6         4716  
  6         199  
9 6     6   22 use File::Basename qw(basename);
  6         6  
  6         285  
10              
11 6     6   2436 use RPC::ExtDirect::Util ();
  6         18820  
  6         118  
12 6     6   2391 use RPC::ExtDirect::Config;
  6         45601  
  6         148  
13 6     6   2641 use RPC::ExtDirect::API;
  6         22513  
  6         26  
14 6     6   2406 use RPC::ExtDirect;
  6         28211  
  6         26  
15              
16             #
17             # This module is not compatible with RPC::ExtDirect < 3.0
18             #
19              
20             die __PACKAGE__." requires RPC::ExtDirect 3.0+"
21             if $RPC::ExtDirect::VERSION lt '3.0';
22              
23             ### PACKAGE GLOBAL VARIABLE ###
24             #
25             # Version of this module.
26             #
27              
28             our $VERSION = '3.24';
29              
30             ### PUBLIC CLASS METHOD (CONSTRUCTOR) ###
31             #
32             # Instantiate a new CGI::ExtDirect object
33             #
34              
35             sub new {
36 1     1 1 10 my $class = shift;
37              
38 1 50 33     5 my %arg = @_ == 1 && 'HASH' eq ref $_[0] ? %{ $_[0] }
  0         0  
39             : @_
40             ;
41            
42 1   33     6 my $api = delete $arg{api} || RPC::ExtDirect->get_api();
43 1   33     31 my $config = delete $arg{config} || $api->config;
44            
45             # We need a CGI object for input processing
46 1   33     11 my $cgi = $arg{cgi} || do { require CGI; new CGI };
47              
48             # Debug flag defaults to off
49 1 50       179 $config->debug( $arg{debug} ) if exists $arg{debug};
50              
51 1         7 my $self = bless {
52             config => $config,
53             api_obj => $api,
54             cgi => $cgi,
55             %arg,
56             }, $class;
57              
58 1         2 return $self;
59             }
60              
61             ### PUBLIC INSTANCE METHOD ###
62             #
63             # Returns API definition for ExtDirect, along with headers
64             #
65              
66             sub api {
67 0     0 1 0 my ($self, @headers) = @_;
68              
69             # Get the API JavaScript
70 0         0 my $js = eval {
71 0         0 $self->api_obj->get_remoting_api(
72             config => $self->config,
73             env => $self->cgi,
74             )
75             };
76              
77             # If JS API call failed, return error headers
78             # What exactly went wrong is not too relevant here
79 0 0       0 return $self->error_headers(@headers) if $@;
80              
81             # If API call succeed, return application/javascript with 200 OK
82 0         0 my $content_type = 'application/javascript';
83 0         0 my $http_status = '200 OK';
84              
85             # And we need content length, too (in octets)
86 6     6   1854 my $content_length = do { use bytes; length $js; };
  6         14  
  6         30  
  0         0  
  0         0  
87              
88             # Munge the headers passed on us
89 0         0 my @real_headers = $self->_munge_headers($content_type,
90             $http_status,
91             $content_length,
92             @headers);
93              
94             # Finally, compile HTTP response
95 0         0 my $response = $self->cgi->header(@real_headers) .
96             $js;
97              
98 0         0 return $response;
99             }
100              
101             ### PUBLIC INSTANCE METHOD ###
102             #
103             # Routes the action request and returns HTTP response with headers
104             #
105              
106             sub route {
107 0     0 1 0 my ($self, @headers) = @_;
108              
109             # If any but POST method is used, just throw an error
110 0 0       0 return $self->error_headers(@headers)
111             if $self->cgi->request_method() ne 'POST';
112              
113             # Try to distinguish between raw POST and form call (Ugh)
114 0         0 my $router_input = $self->_extract_post_data();
115              
116             # When extraction fails, undef is returned
117 0 0       0 return $self->error_headers(@headers)
118             unless defined $router_input;
119            
120 0         0 my $config = $self->config;
121 0         0 my $api = $self->api_obj;
122 0         0 my $router_class = $config->router_class;
123            
124 0         0 eval "require $router_class";
125            
126 0         0 my $router = $router_class->new(
127             config => $config,
128             api => $api,
129             );
130              
131             # Routing requests is safe (Router won't croak under torture)
132 0         0 my $result = $router->route($router_input, $self->cgi);
133              
134 0         0 my ($content_type, $http_body, $content_length);
135              
136 0         0 $content_type = $result->[1]->[1];
137 0         0 $content_length = $result->[1]->[3];
138 0         0 $http_body = $result->[2]->[0];
139 0         0 my $http_status = '200 OK';
140              
141             # Munge the headers passed on us
142 0         0 my @real_headers = $self->_munge_headers($content_type,
143             $http_status,
144             $content_length,
145             @headers);
146              
147             # Finally, compile HTTP response
148 0         0 my $response = $self->cgi->header(@real_headers) .
149             $http_body;
150              
151 0         0 return $response;
152             }
153              
154             ### PUBLIC INSTANCE METHOD ###
155             #
156             # Queries Event providers for events, returning serialized stream.
157             #
158              
159             sub poll {
160 0     0 1 0 my ($self, @headers) = @_;
161              
162             # Only GET and POST methods are supported for polling
163 0 0       0 return $self->error_headers(@headers)
164             if $self->cgi->request_method() !~ / \A (GET|POST) \z /xms;
165            
166 0         0 my $config = $self->config;
167 0         0 my $api = $self->api_obj;
168 0         0 my $provider_class = $config->eventprovider_class;
169            
170 0         0 eval "require $provider_class";
171            
172 0         0 my $provider = $provider_class->new(
173             config => $config,
174             api => $api,
175             );
176              
177             # Polling for Events is safe
178 0         0 my $http_body = $provider->poll($self->cgi);
179              
180             # Gather variables for HTTP response
181 0         0 my $content_type = 'application/json';
182 0         0 my $http_status = '200 OK';
183              
184             # And we need content length, too (in octets)
185 6     6   1747 my $content_length = do { use bytes; length $http_body; };
  6         7  
  6         21  
  0         0  
  0         0  
186              
187             # Munge the headers passed on us
188 0         0 my @real_headers = $self->_munge_headers($content_type,
189             $http_status,
190             $content_length,
191             @headers);
192              
193             # Finally, compile HTTP response
194 0         0 my $response = $self->cgi->header(@real_headers) .
195             $http_body;
196              
197 0         0 return $response;
198             }
199              
200             ### PUBLIC INSTANCE METHOD ###
201             #
202             # Returns error HTTP header string. There is not much sense in
203             # returning HTTP body as well since Ext.Direct calls are automated
204             # and there is nobody to see error messages anyway.
205             #
206              
207             sub error_headers {
208 0     0 0 0 my ($self, @headers) = @_;
209              
210             # Get ourselves a set of brand new CGI headers
211 0         0 my @cgi_headers = $self->_munge_headers('text/html',
212             '500 Internal Server Error',
213             0,
214             @headers);
215              
216 0         0 return $self->cgi->header(@cgi_headers);
217             }
218              
219             ### PUBLIC INSTANCE METHODS ###
220             #
221             # Read-write accessors
222             #
223              
224             RPC::ExtDirect::Util::Accessor->mk_accessors(
225             simple => [qw/ config api_obj cgi /],
226             );
227              
228             ############## PRIVATE METHODS BELOW ##############
229              
230             ### PRIVATE INSTANCE METHOD ###
231             #
232             # Munges CGI headers so that they become what we need
233             #
234              
235             sub _munge_headers {
236 6     6   2316 my ($self, $content_type, $http_status,
237             $content_length, @headers) = @_;
238              
239             # Default charset is UTF-8
240 6         6 my $charset = 'utf-8';
241              
242             # First form is no additional headers passed on us, the easy one
243             # Second form includes only one parameter and that's content type
244             # Third form includes both content type and HTTP status
245             # The last form is a hash of headers but we'd better check anyway
246             return (
247 6 100 100     56 '-type' => $content_type,
      66        
      66        
      33        
      66        
248             '-status' => $http_status,
249             '-charset' => $charset,
250             '-content_length' => $content_length,
251             )
252             if @headers == 0 || @headers == 1 ||
253             (@headers == 2 && $headers[0] !~ / \A - /msx) ||
254             (@headers > 2 && ((@headers % 2) != 0));
255              
256             # Finally we've got a hash of header parameters
257 3         11 my %cgi_headers = @headers;
258              
259             # Interesting are the headers we need to deal with
260 3         18 my %interesting_item = (
261             '-type' => qr/ \A -? (content [-_])? type \z /ixms,
262             '-status' => qr/ \A -? status \z /ixms,
263             '-charset' => qr/ \A -? charset \z /ixms,
264             '-content_length' => qr/ \A -? content [-_] length \z /ixms,
265             '-nph' => qr/ \A -? nph \z /ixms,
266             );
267              
268             # Normalize them headers we need, don't touch the others
269             HEADER_ITEM:
270 3         7 for my $item ( keys %interesting_item ) {
271 15         10 my $pattern = $interesting_item{ $item };
272              
273             # First find all occurences of the interesting item
274 15         22 my @found_items = grep { /$pattern/ } keys %cgi_headers;
  104         228  
275 15 100       27 next HEADER_ITEM unless @found_items;
276              
277             # Then take the *first* value -- we don't care about duplicates
278             # and they should not have happened anyway, so there
279 13         14 my $value = $cgi_headers{ $found_items[0] };
280              
281             # Delete all occurences of the item in question
282 13         12 delete @cgi_headers{ @found_items };
283              
284             # Finally, place normalized item back in hash
285 13         21 $cgi_headers{ $item } = $value;
286             };
287              
288             # Make sure we have the required headers
289             $cgi_headers{'-type'} = $content_type
290 3 50       5 unless exists $cgi_headers{ '-type' };
291            
292             $cgi_headers{'-status'} = $http_status
293 3 50       5 unless exists $cgi_headers{ '-status' };
294            
295             # Content-length we force
296 3         4 $cgi_headers{'-content_length'} = $content_length;
297              
298             # If they passed charset, then they probably know what they're doing
299             $cgi_headers{ '-charset' } = $charset
300 3 50       5 unless exists $cgi_headers{ '-charset' };
301              
302             # Defang CGI.pm's interface idiosyncracies by ensuring that
303             # a header starting with a dash always comes first. Otherwise
304             # the hash key randomizer introduced in Perl 5.18 may screw up
305             # for us by placing a header with no dash in the first place,
306             # making CGI->header() think that it has been fed the first argument
307             # form header('content/type', 'HTTP status') instead of the hash
308             # form. This leads to CGI::ExtDirect returning a HTTP status line
309             # like "HTTP/1.1 1" instead of "HTTP/1.1 200 OK" *sometimes*.
310             # Dang.
311             return (
312 3         19 '-type' => delete $cgi_headers{ '-type' },
313             %cgi_headers,
314             );
315             }
316              
317             ### PRIVATE INSTANCE METHOD ###
318             #
319             # Deals with intricacies of POST-fu and returns something suitable to
320             # feed to the Router (string or hashref, really). Or undef if something
321             # goes too wrong to recover.
322              
323             my @STANDARD_KEYWORDS
324             = qw(action method extAction extMethod extTID extUpload extType);
325             my %STANDARD_KEYWORD = map { $_ => 1 } @STANDARD_KEYWORDS;
326              
327             sub _extract_post_data {
328 0     0     my ($self) = @_;
329              
330             # We need CGI object here real bad
331 0           my $cgi = $self->cgi;
332              
333             # The smartest way to tell if a form was submitted that *I* know of
334             # is to look for 'extAction' and 'extMethod' keywords in CGI params.
335 0           my %keyword = map { $_ => 1 } $cgi->param();
  0            
336             my $is_form = exists $keyword{ extAction } &&
337 0   0       exists $keyword{ extMethod };
338              
339             # If form is not involved, it's easy: just return POSTDATA (or undef)
340 0 0         if ( !$is_form ) {
341 0           my $postdata = $cgi->param('POSTDATA');
342 0 0         return $postdata ne '' ? $postdata
343             : undef
344             ;
345             };
346              
347             # If any files are attached, extUpload will contain 'true'
348 0           my $has_uploads = $cgi->param('extUpload') eq 'true';
349              
350             # Here file uploads data is stored
351 0           my @_uploads = ();
352              
353             # This is to suppress a really annoying warning in CGI.pm 4.08+.
354             # I am perfectly aware of what the list context is and how to
355             # use it, thank you very much. :/
356 0           local $CGI::LIST_CONTEXT_WARN = 0;
357              
358             # Now if the form IS involved, it gets a little bit complicated
359             PARAM:
360 0           for my $param ( keys %keyword ) {
361             # Defang CGI's idiosyncratic way of returning multi-valued params
362 0           my @values = $cgi->param( $param );
363 0 0         $keyword{ $param } = @values == 0 ? undef
    0          
364             : @values == 1 ? $values[0]
365             : [ @values ]
366             ;
367              
368             # Try to see if $param is a field with associated file upload
369             # Skip the standard ones first, of course
370 0 0 0       next PARAM if $STANDARD_KEYWORD{ $param } || !$has_uploads;
371              
372             # Look for file uploads in this field
373 0           my @field_uploads = $self->_parse_uploads($cgi, $param);
374              
375             # Found some, add them to the general stash and kill the field
376 0 0         if ( @field_uploads ) {
377 0           push @_uploads, @field_uploads;
378 0           delete $keyword{ $param };
379             };
380             };
381              
382             # Metadata is JSON encoded; decode_metadata lives by side effects!
383 0 0         if ( exists $keyword{metadata} ) {
384 0           RPC::ExtDirect::Util::decode_metadata($self, \%keyword);
385             }
386              
387             # Remove extType because it's meaningless later on
388 0           delete $keyword{ extType };
389              
390             # Fix up the TID so that it comes as a number (JavaScript is picky)
391 0 0         $keyword{ extTID } += 0 if exists $keyword{ extTID };
392              
393             # Now add files to hash, if any
394 0 0         $keyword{ '_uploads' } = \@_uploads if @_uploads;
395              
396 0           return \%keyword;
397             }
398              
399             ### PRIVATE INSTANCE METHOD ###
400             #
401             # Parses CGI form input field looking for file uploads
402             #
403              
404             sub _parse_uploads {
405 0     0     my ($self, $cgi, $param) = @_;
406              
407             # CGI returns "lightweight file handles", or undef
408 0           my @file_handles = $cgi->upload($param);
409              
410             # Empty list means no uploads for this field
411 0 0         return unless grep { defined $_ } @file_handles;
  0            
412              
413             # Despite what CGI documentation says, the values returned
414             # as "file names" are actually some kind of key handles
415 0           my @file_keys = $cgi->param($param);
416              
417             # Here file uploads get collected
418 0           my @uploads = ();
419              
420             # Collect the info we need to repackage it in a consistent way
421             FILE:
422 0           for my $key ( @file_keys ) {
423             # First take a closer look at this "blah-blah handle"
424 0           my $file_handle = shift @file_handles;
425              
426             # undef would mean there was an upload error (timeout perhaps)
427             # Following HTTP POST logic, when one upload breaks, that
428             # would mean all subsequent uploads in this POST are also
429             # broken.
430             # We can't recover from that so just stop trying.
431 0 0         last FILE unless defined $file_handle;
432              
433             # In CGI.pm < 3.41, "lightweight handle" object doesn't support
434             # returning IO::Handle so we do it manually to avoid problems
435 0           my $io_handle = IO::Handle->new_from_fd(fileno $file_handle, '<');
436              
437             # We also need a lot of info about the file (if provided)
438 0           my $upload_info = $cgi->uploadInfo($key);
439 0           my $temp_file = $cgi->tmpFileName($key);
440 0           my $file_type = $upload_info->{'Content-Type'};
441 0           my $file_name = $self->_get_file_name($upload_info);
442 0           my $file_size = $self->_get_file_size($io_handle);
443 0           my $base_name = basename($file_name);
444              
445             # Now instead of a "blah-blah handle" we have a normalized hashref
446 0           push @uploads, {
447             type => $file_type,
448             size => $file_size,
449             path => $temp_file,
450             handle => $io_handle,
451             basename => $base_name,
452             filename => $file_name,
453             };
454             };
455              
456 0           return @uploads;
457             }
458              
459             ### PRIVATE INSTANCE METHOD ###
460             #
461             # Tries hard to extract file name from multipart form guts
462             #
463              
464             sub _get_file_name {
465 0     0     my ($self, $upload_info) = @_;
466              
467             # Pluck file name from Content-Disposition string
468             my ($file_name)
469 0           = $upload_info->{'Content-Disposition'} =~ /filename="(.*?)"/;
470              
471             # URL unescape it
472 0           $file_name =~ s/%([\dA-Fa-f]{2})/pack("C", hex $1)/eg;
  0            
473              
474 0           return $file_name;
475             }
476              
477             ### PRIVATE INSTANCE METHOD ###
478             #
479             # Enquiries IO::Handle supplied by CGI for file size
480             #
481              
482             sub _get_file_size {
483 0     0     my ($self, $handle) = @_;
484              
485             # Fall through in case $handle is invalid
486 0 0         return unless $handle;
487              
488 0           return ($handle->stat)[7];
489             }
490              
491             1;