File Coverage

blib/lib/WebDAO/Response.pm
Criterion Covered Total %
statement 130 171 76.0
branch 18 38 47.3
condition 5 13 38.4
subroutine 27 37 72.9
pod 20 26 76.9
total 200 285 70.1


line stmt bran cond sub pod time code
1             package WebDAO::Response;
2              
3             =head1 NAME
4              
5             WebDAO::Response - Response class
6              
7             =head1 SYNOPSYS
8              
9             new WebDAO::Response:: cv => $cv
10              
11             =head1 DESCRIPTION
12              
13             Class for make HTTP response
14              
15             =cut
16              
17             our $VERSION = '0.01';
18 5     5   1519 use Data::Dumper;
  5         9  
  5         267  
19 5     5   27 use WebDAO::Base;
  5         26  
  5         332  
20 5     5   25 use IO::File;
  5         9  
  5         805  
21 5     5   6749 use DateTime;
  5         618453  
  5         201  
22 5     5   3927 use DateTime::Format::HTTP;
  5         29345  
  5         220  
23 5     5   38 use base qw( WebDAO::Base );
  5         12  
  5         569  
24              
25             __PACKAGE__->mk_attr(
26             _headers => undef,
27             _is_headers_printed =>0,
28             _cv_obj => undef,
29             _is_file_send => 0,
30             _is_need_close_fh => 0,
31             __fh => undef,
32             _is_flushed => 0,
33             _call_backs => undef,
34             _is_modal => 0,
35             _forced_want_format => undef,
36             _is_empty=>0,
37             status => 200 #default HTTP status
38             );
39              
40 5     5   28 use strict;
  5         10  
  5         112  
41 5     5   26 use warnings;
  5         9  
  5         8867  
42              
43             =head1 METHODS
44              
45             =cut
46              
47             sub new {
48 12     12 1 32 my $class = shift;
49 12         23 my $self = {};
50 12         21 my $stat;
51 12         26 bless( $self, $class );
52 12         37 $self->_init(@_);
53 12         148 return $self;
54             }
55              
56             sub _init {
57 12     12   21 my $self = shift;
58 12         38 return $self->init(@_);
59             }
60              
61             sub init {
62 12     12 0 19 my $self = shift;
63 12         40 my %par = @_;
64 12         324 $self->_headers( {} );
65 12         293 $self->_call_backs( [] );
66 12         284 $self->_cv_obj( $par{cv} );
67 12         26 return 1;
68             }
69              
70             =head2 get_request
71              
72             Return ref to request object (WebDAO::CV)
73              
74             =cut
75              
76             sub get_request {
77 7     7 1 9 my $self = shift;
78 7         157 return $self->_cv_obj;
79             }
80              
81             =head2 set_status INT
82              
83             set response HTTP status
84              
85             $r->set_status(200)
86              
87             return C<$self>
88              
89             =cut
90              
91             sub set_status {
92 2     2 1 4 my $self = shift;
93 2         49 $self->status(@_);
94 2         6 $self
95             }
96              
97              
98             =head2 set_header NAME, VALUE
99              
100             Set out header:
101              
102             $response->set_header('Location', $redirect_url);
103             $response->set_header( 'Content-Type' => 'text/html; charset=utf-8' );
104              
105             return $self reference
106              
107             =cut
108              
109             sub set_header {
110 10     10 1 20 my ( $self, $name, $par ) = @_;
111             #translate CGI headers
112 10 50       77 if ( $name =~ /^-/) {
    100          
113 0         0 my $UKey = uc $name;
114            
115 0 0       0 if ( $UKey eq '-STATUS' ) {
116 0         0 my ($status) = $par =~ m/(\d+)/;
117 0         0 $self->status($status);
118 0         0 return $self;
119             }
120 0         0 warn "Deprecated header name $name !";
121             } elsif ( $name eq 'Set-Cookie') {
122 4         7 push @{ $self->_headers->{ $name } }, $par;
  4         90  
123 4         8 return $self
124             }
125            
126 6         141 $self->_headers->{ $name } = $par;
127 6         14 $self;
128             }
129              
130              
131              
132             =head2 get_header NAME
133              
134             return value for header NAME:
135              
136             =cut
137              
138             sub get_header {
139 6     6 1 12 my ( $self, $name ) = @_;
140 6         137 return $self->_headers->{ $name };
141             }
142              
143             =head2 aliases for headers
144              
145             =head3 content_type
146              
147             $r->content_type('text/html; charset=utf-8');
148              
149             =cut
150              
151             sub content_type {
152 2     2 1 8 my $self = shift;
153 2 50       16 unless ($#_ > 0 ) {
154 2         8 $self->set_header('Content-Type', @_)
155             }
156 2         8 $self->get_header('Content-Type');
157             }
158              
159             =head3 content_length
160              
161             A decimal number indicating the size in bytes of the message content.
162              
163             =cut
164              
165             sub content_length {
166 2     2 1 7 my $self = shift;
167 2 50       8 unless ($#_ > 0 ) {
168 2         7 $self->set_header('Content-Length' , @_)
169             }
170 2         6 $self->get_header('Content-Length');
171             }
172              
173             =head3
174              
175             =head2 get_mime_for_filename
176              
177             Determine mime type for filename (Simple by ext);
178             return str
179              
180             =cut
181              
182             sub get_mime_for_filename {
183 1     1 1 2 my $self = shift;
184 1         2 my $filename = shift;
185 1         2 my $no_default_flag = shift;
186 1         33 my %types_for_ext = (
187             avi => 'video/x-msvideo',
188             bmp => 'image/bmp',
189             css => 'text/css',
190             gif => 'image/gif',
191             gz => 'application/gzip',
192             html => 'text/html',
193             htm => 'text/html',
194             jpg => 'image/jpeg',
195             jpeg => 'image/jpeg',
196             js => 'application/javascript',
197             midi => 'audio/midi',
198             mp3 => 'audio/mpeg',
199             mpeg => 'video/mpeg',
200             mpg => 'video/mpeg',
201             mov => 'video/quicktime',
202             pdf => 'application/pdf',
203             png => 'image/png',
204             ppt => 'application/vnd.ms-powerpoint',
205             rtf => 'text/rtf',
206             tif => 'image/tif',
207             tiff => 'image/tif',
208             txt => 'text/plain',
209             xls => 'application/vnd.ms-excel',
210             xml => 'appliction/xml',
211             wav => 'audio/x-wav',
212             zip => 'application/zip',
213             );
214 1         10 my ($ext) = $filename =~ /\.(\w+)$/;
215 1 50       5 if ( my $type = $types_for_ext{ lc $ext } ) {
216 1         8 return $type;
217             }
218 0 0       0 return $no_default_flag ? undef : 'application/octet-stream';
219             }
220              
221             =head2 print_header
222              
223             print header.return $self reference
224              
225             =cut
226              
227             sub print_header {
228 3     3 1 8 my $self = shift;
229 3         74 my $pnted = $self->_is_headers_printed;
230 3 50       10 return $self if $pnted;
231 3         11 my $cv = $self->get_request;
232 3         69 $cv->status($self->status);
233 3         6 $cv->print_headers(%{ $self->_headers });
  3         67  
234 3         73 $self->_is_headers_printed(1);
235 3         4 $self;
236             }
237              
238             =head2 redirect2url [, $code]
239              
240             Set headers for redirect to url.return $self reference
241              
242             =cut
243              
244             sub redirect2url {
245 1     1 1 2 my ( $self, $redirect_url, $code ) = @_;
246 1   50     5 $self->set_modal->set_status( $code || 302 );
247 1         5 $self->set_header( 'Location', $redirect_url );
248             }
249              
250             =head2 set_cookie ( name => , value=> ...)
251              
252             Set cookie.
253             return $self reference
254              
255             =cut
256              
257             sub set_cookie {
258 4     4 1 13 my $self = shift;
259 4         35 $self->set_header("Set-Cookie", { @_ });
260 4         11 $self;
261             }
262              
263              
264             =head2 set_callback(sub1{}[, sub2{} ..])
265              
266             Set callbacks for call after flush
267              
268             =cut
269              
270             sub set_callback {
271 2     2 1 5 my $self = shift;
272 2         3 push @{ $self->_call_backs }, @_;
  2         45  
273 2         9 return $self;
274             }
275              
276             =head2 send_file || [, -type=>]
277              
278             Prepare headers and save
279              
280             $respose->send_file($filename, -type=>'image/jpeg');
281              
282             =cut
283              
284             sub send_file {
285 1     1 1 3 my $self = shift;
286 1         2 my $file = shift;
287 1         4 my %args = @_;
288 1         3 my $file_handle;
289             my $file_name;
290 1 50 0     17 if ( ref $file
      33        
      33        
291             and ( UNIVERSAL::isa( $file, 'IO::Handle' ) or ( ref $file ) eq 'GLOB' )
292             or UNIVERSAL::isa( $file, 'Tie::Handle' ) )
293             {
294 0         0 $file_handle = $file;
295             }
296             else {
297 1         3 $file_name = $file;
298 1 50       11 $file_handle = new IO::File::("< $file")
299             or die "can't open file: $file" . $!;
300 1         120 $self->_is_need_close_fh(1);
301 1         24 $self->__fh($file_handle);
302             }
303              
304             #set file headers
305 1         8 my ( $size, $mtime ) = ( stat $file_handle )[ 7, 9 ];
306 1         6 $self->content_length( $size );
307 1         11 my $formated =
308             DateTime::Format::HTTP->format_datetime(
309             DateTime->from_epoch( epoch => $mtime ) );
310 1         746 $self->set_header( 'Last-Modified', $formated );
311              
312             #Determine mime tape of file
313 1 50       5 if ( my $predefined = $args{-type} ) {
314 1         3 $self->content_type( $predefined );
315             }
316             else {
317             ##
318 0 0       0 if ($file_name) {
319 0         0 $self->content_type(
320             $self->get_mime_for_filename($file_name) );
321             }
322             }
323              
324             #set modal mode and flag for send file
325 1         3 $self->set_modal->_is_file_send(1);
326 1         6 $self;
327             }
328              
329             sub print {
330 0     0 0 0 my $self = shift;
331 0         0 my $cv = $self->get_request;
332 0         0 $self->print_header;
333 0         0 $cv->print(@_);
334 0         0 return $self;
335             }
336              
337             sub _print_dep_on_context {
338 0     0   0 my ( $self, $session ) = @_;
339 0         0 my $res = $self->html;
340 0 0       0 $self->print( ref($res) eq 'CODE' ? $res->() : $res );
341             }
342              
343             =head2 flush
344              
345             Flush current state of response.
346              
347             =cut
348              
349             sub flush {
350 2     2 1 3 my $self = shift;
351 2 50       49 return $self if $self->_is_flushed;
352 2         7 $self->print_header;
353              
354             #do self print file
355 2 100       45 if ( $self->_is_file_send ) {
356 1         29 my $fd = $self->__fh;
357 1         3 $self->get_request->print(<$fd>);
358 1 50       36 close($fd) if $self->_is_need_close_fh;
359             }
360 2         45 $self->_is_flushed(1);
361              
362             #do callbacks
363 2         44 my $ref_calls = $self->_call_backs;
364 2         7 while ( my $code = pop @$ref_calls ) {
365 2         10 $code->();
366             }
367              
368             #clear callbacks
369 2         7 @{ $self->_call_backs } = ();
  2         43  
370 2         8 $self;
371             }
372              
373             =head2 set_modal
374              
375             Set modal mode for answer
376              
377             =cut
378              
379             sub set_modal {
380 2     2 1 4 my $self = shift;
381 2         44 $self->_is_modal(1);
382 2         37 $self;
383             }
384              
385             =head2 error404
386              
387             Set HTTP 404 headers
388              
389             =cut
390              
391             sub error404 {
392 0     0 1 0 my $self = shift;
393 0         0 $self->set_modal->set_status(404);
394 0 0       0 $self->print(@_) if @_;
395 0         0 return $self;
396             }
397              
398             sub html : lvalue {
399 0     0 0 0 my $self = shift;
400 0         0 $self->{__html};
401             }
402              
403             sub set_html {
404 0     0 0 0 my $self = shift;
405 0         0 my $data = shift;
406 0         0 $self->html = $data;
407 0         0 return $self;
408             }
409              
410             sub json : lvalue {
411 0     0 0 0 my $self = shift;
412 0         0 $self->{__json};
413              
414             }
415              
416             sub set_json {
417 0     0 0 0 my $self = shift;
418 0         0 my $data = shift;
419 0         0 $self->json = $data;
420 0         0 return $self;
421             }
422              
423             sub _destroy {
424 0     0   0 my $self = shift;
425 0         0 $self->{__html} = undef;
426             #destroy called from Engine::execute2
427             # destroy tests by cleared _cv_obj
428             # $self->_cv_obj( undef );
429 0         0 $self->_headers( {} );
430 0         0 $self->_call_backs( [] );
431             }
432              
433             =head2 wantformat ['format',['forse_set_format']]
434              
435             Return expected output format: defauilt html
436            
437             # return string for format
438             $r->wantformat()
439              
440             Check if desired format is expected
441              
442             #$r->wantformat('html') return boolean
443             if ($r->wantformat('html')) {
444             #
445             }
446              
447             Force set desired format:
448              
449             $r->wantformat('html'=>1); #return $response object ref
450              
451             =cut
452              
453             sub wantformat {
454 6     6 1 9 my $self = shift;
455 6 100       17 if ( @_ > 1 ) {
456 1         33 $self->_forced_want_format(shift);
457 1         4 return $self;
458             }
459 5         126 my $desired = $self->_forced_want_format();
460 5   100     19 my $default =
461             $desired
462             || $self->detect_wantformat( $self->get_request ) #call with CV object
463             || 'html';
464 5 100       12 if ( scalar(@_) == 1 ) {
465 3         14 return $default eq shift;
466             }
467 2         9 return $default;
468             }
469              
470             =head2 detect_wantformat ($cv)
471              
472             Method for detect output format when C called
473              
474             Must return :
475            
476             string - output format, i.e. 'html', 'xml'
477             undef - unknown ( use defaults )
478              
479             =cut
480              
481             sub detect_wantformat {
482             return undef #unknown by default
483 3     3 1 18 }
484              
485              
486             =head2 set_empty
487              
488             Set flag for empty response. Headers are not printed.
489             return $self
490             =cut
491              
492 0     0 1   sub set_empty { $_[0]->_is_empty(1); $_[0]}
  0            
493              
494             =head2 is_empty
495              
496             Check is response cleared.
497             Return 1|0
498              
499             =cut
500              
501 0     0 1   sub is_empty { return $_[0]->_is_empty() }
502              
503             1;
504             __DATA__