File Coverage

blib/lib/CatalystX/ASP/Response.pm
Criterion Covered Total %
statement 114 121 94.2
branch 19 26 73.0
condition 7 11 63.6
subroutine 25 26 96.1
pod 10 13 76.9
total 175 197 88.8


line stmt bran cond sub pod time code
1             package CatalystX::ASP::Response;
2              
3 9     9   4571 use namespace::autoclean;
  9         23  
  9         86  
4 9     9   762 use Moose;
  9         16  
  9         57  
5 9     9   55630 use CatalystX::ASP::Exception::End;
  9         38  
  9         343  
6 9     9   3506 use Tie::Handle;
  9         11929  
  9         223  
7 9     9   57 use List::Util qw(all);
  9         20  
  9         497  
8 9     9   3173 use Data::Dumper;
  9         44682  
  9         4068  
9              
10             has 'asp' => (
11             is => 'ro',
12             isa => 'CatalystX::ASP',
13             required => 1,
14             weak_ref => 1,
15             );
16              
17             has '_flushed_offset' => (
18             is => 'rw',
19             isa => 'Int',
20             default => 0,
21             );
22              
23             =head1 NAME
24              
25             CatalystX::ASP::Response - $Response Object
26              
27             =head1 SYNOPSIS
28              
29             use CatalystX::ASP::Response;
30              
31             my $resp = CatalystX::ASP::Response->new(asp => $asp);
32             $resp->Write('<h1>Hello World!</h1>');
33             my $body = $resp->Body;
34              
35             =head1 DESCRIPTION
36              
37             This object manages the output from the ASP Application and the client web
38             browser. It does not store state information like the $Session object but does
39             have a wide array of methods to call.
40              
41             =cut
42              
43             =head1 ATTRIBUTES
44              
45             =over
46              
47             =item $Response->{BinaryRef}
48              
49             API extension. This is a perl reference to the buffered output of the
50             C<$Response> object, and can be used in the C<Script_OnFlush> F<global.asa>
51             event to modify the buffered output at runtime to apply global changes to
52             scripts output without having to modify all the scripts. These changes take
53             place before content is flushed to the client web browser.
54              
55             sub Script_OnFlush {
56             my $ref = $Response->{BinaryRef};
57             $$ref =~ s/\s+/ /sg; # to strip extra white space
58             }
59              
60             =cut
61              
62             has 'BinaryRef' => (
63             is => 'rw',
64             isa => 'ScalarRef',
65             default => sub { \( shift->Body ) }
66             );
67              
68             has 'Body' => (
69             is => 'rw',
70             isa => 'Str',
71             traits => ['String'],
72             handles => {
73             Write => 'append',
74             BodyLength => 'length',
75             BodySubstr => 'substr',
76             },
77             );
78              
79             # This attribute has no effect
80             has 'Buffer' => (
81             is => 'rw',
82             isa => 'Bool',
83             default => 1,
84             );
85              
86             =item $Response->{CacheControl}
87              
88             Default C<"private">, when set to public allows proxy servers to cache the
89             content. This setting controls the value set in the HTTP header C<Cache-Control>
90              
91             =cut
92              
93             has 'CacheControl' => (
94             is => 'rw',
95             isa => 'Str',
96             default => 'private',
97             );
98              
99             =item $Response->{Charset}
100              
101             This member when set appends itself to the value of the Content-Type HTTP
102             header. If C<< $Response->{Charset} = 'ISO-LATIN-1' >> is set, the
103             corresponding header would look like:
104              
105             Content-Type: text/html; charset=ISO-LATIN-1
106              
107             =cut
108              
109             has 'Charset' => (
110             is => 'rw',
111             isa => 'Str',
112             default => '',
113             );
114              
115             # This attribute has no effect
116             has 'Clean' => (
117             is => 'rw',
118             isa => 'Int',
119             default => 0,
120             );
121              
122             =item $Response->{ContentType}
123              
124             Default C<"text/html">. Sets the MIME type for the current response being sent
125             to the client. Sent as an HTTP header.
126              
127             =cut
128              
129             has 'ContentType' => (
130             is => 'rw',
131             isa => 'Str',
132             default => 'text/html',
133             );
134              
135             # For some reason, for attributes that start with a capital letter, Moose seems
136             # to load the default value before the object is fully initialized. lazy => 1 is
137             # a workaround to build the defaults later
138             has 'Cookies' => (
139             is => 'rw',
140             isa => 'HashRef',
141             reader => '_get_Cookies',
142             writer => '_set_Cookies',
143             lazy => 1,
144             default => sub {
145             my ( $self ) = @_;
146             my $c = $self->asp->c;
147             my %cookies;
148             for my $name ( keys %{ $c->response->cookies } ) {
149             my $cookie = $c->response->cookies->{$name};
150             for my $attr ( keys %$cookie ) {
151             $cookies{$name}{ ucfirst( $attr ) } = ref $cookie eq 'HASH'
152             ? $cookie->{$attr}
153             : $cookie->$attr;
154             }
155             if ( ref $cookies{$name}{Value} eq 'ARRAY'
156             && all {/.=./} @{ $cookies{$name}{Value} } ) {
157             for ( @{ delete $cookies{$name}{Value} } ) {
158             my ( $key, $val ) = split '=';
159             $cookies{$name}{Value}{$key} = $val;
160             }
161             }
162             }
163             return \%cookies;
164             },
165             traits => ['Hash'],
166             handles => {
167             _get_Cookie => 'get',
168             _set_Cookie => 'set',
169             },
170             );
171              
172             # This attribute currently has no effect
173             has 'Debug' => (
174             is => 'ro',
175             isa => 'Bool',
176             default => 0,
177             reader => '_Debug',
178             );
179              
180             =item $Response->{Expires}
181              
182             Sends a response header to the client indicating the $time in SECONDS in which
183             the document should expire. A time of C<0> means immediate expiration. The
184             header generated is a standard HTTP date like: "Wed, 09 Feb 1994 22:23:32 GMT".
185              
186             =cut
187              
188             has 'Expires' => (
189             is => 'rw',
190             isa => 'Int',
191             default => 0,
192             );
193              
194             # This attribute has no effect
195             has 'ExpiresAbsolute' => (
196             is => 'rw',
197             isa => 'Str',
198             default => '',
199             );
200              
201             # This attribute has no effect
202             has 'FormFill' => (
203             is => 'rw',
204             isa => 'Bool',
205             default => 0,
206             );
207              
208             =item $Response->{IsClientConnected}
209              
210             1 if web client is connected, C<0> if not. This value starts set to 1, and will
211             be updated whenever a C<< $Response->Flush() >> is called.
212              
213             As of Apache::ASP version 2.23 this value is updated correctly before
214             F<global.asa> C<Script_OnStart> is called, so global script termination may be
215             correctly handled during that event, which one might want to do with excessive
216             user STOP/RELOADS when the web server is very busy.
217              
218             An API extension C<< $Response->IsClientConnected >> may be called for refreshed
219             connection status without calling first a C<< $Response->Flush >>
220              
221             =cut
222              
223             # This attribute has no effect
224             has 'IsClientConnected' => (
225             is => 'rw',
226             isa => 'Bool',
227             default => 1,
228             );
229              
230             # This attribute has no effect
231             has 'PICS' => (
232             is => 'rw',
233             isa => 'Str',
234             default => '',
235             );
236              
237             =item $Response->{Status}
238              
239             Sets the status code returned by the server. Can be used to set messages like
240             500, internal server error
241              
242             =cut
243              
244             has 'Status' => (
245             is => 'rw',
246             isa => 'Int',
247             default => 0,
248             );
249              
250             sub BUILD {
251 15     15 0 42 my ( $self ) = @_;
252              
253 9     9   70 no warnings 'redefine';
  9         20  
  9         8095  
254 15     33   134 *TIEHANDLE = sub {$self};
  33         133  
255 15         177 $self->{out} = $self->{BinaryRef} = \( $self->{Body} );
256              
257             # Don't initiate below attributes unless past setup phase
258 15 100       469 return unless $self->asp->_setup_finished;
259              
260             # Due to problem mentioned above in the builder methods, we are calling
261             # these attributes to populate the values for the hash key to be available
262 14         68 $self->Cookies;
263             }
264              
265             =back
266              
267             =head1 METHODS
268              
269             =over
270              
271             =item $Response->AddHeader($name, $value)
272              
273             Adds a custom header to a web page. Headers are sent only before any text from
274             the main page is sent.
275              
276             =cut
277              
278             sub AddHeader {
279 4     4 1 18 my ( $self, $name, $value ) = @_;
280 4         127 $self->asp->c->response->header( $name => $value );
281             }
282              
283 3     3   921 sub PRINT { my $self = shift; $self->Write( $_ ) for @_ }
  3         99  
284              
285             sub PRINTF {
286 1     1   3 my ( $self, $format, @list ) = @_;
287 1         37 $self->Write( sprintf( $format, @list ) );
288             }
289              
290             =item $Response->AppendToLog($message)
291              
292             Adds $message to the server log. Useful for debugging.
293              
294             =cut
295              
296             sub AppendToLog {
297 2     2 1 84 my ( $self, $message ) = @_;
298 2         62 $self->asp->c->log->debug( $message );
299             }
300              
301             =item $Response->BinaryWrite($data)
302              
303             Writes binary data to the client. The only difference from
304             C<< $Response->Write() >> is that C<< $Response->Flush() >> is called internally
305             first, so the data cannot be parsed as an html header. Flushing flushes the
306             header if has not already been written.
307              
308             If you have set the C<< $Response->{ContentType} >> to something other than
309             C<text/html>, cgi header parsing (see CGI notes), will be automatically be
310             turned off, so you will not necessarily need to use C<BinaryWrite> for writing
311             binary data.
312              
313             =cut
314              
315             *BinaryWrite = *Write;
316              
317             sub WriteRef {
318 18     18 0 54 my ( $self, $dataref ) = @_;
319 18         579 $self->Write( $$dataref );
320             }
321              
322             =item $Response->Clear()
323              
324             Erases buffered ASP output.
325              
326             =cut
327              
328             sub Clear {
329 6     6 1 17 my ( $self ) = @_;
330 6 50       162 $self->Body && $self->Body( $self->BodySubstr( 0, $self->_flushed_offset ) );
331 6         20 $self->{out} = $self->{BinaryRef} = \( $self->{Body} );
332 6         12 return;
333             }
334              
335             =item $Response->Cookies($name, [$key,] $value)
336              
337             Sets the key or attribute of cookie with name C<$name> to the value C<$value>.
338             If C<$key> is not defined, the Value of the cookie is set. ASP CookiePath is
339             assumed to be / in these examples.
340              
341             $Response->Cookies('name', 'value');
342             # Set-Cookie: name=value; path=/
343              
344             $Response->Cookies("Test", "data1", "test value");
345             $Response->Cookies("Test", "data2", "more test");
346             $Response->Cookies(
347             "Test", "Expires",
348             HTTP::Date::time2str(time+86400)
349             );
350             $Response->Cookies("Test", "Secure", 1);
351             $Response->Cookies("Test", "Path", "/");
352             $Response->Cookies("Test", "Domain", "host.com");
353             # Set-Cookie:Test=data1=test%20value&data2=more%20test; \
354             # expires=Fri, 23 Apr 1999 07:19:52 GMT; \
355             # path=/; domain=host.com; secure
356              
357             The latter use of C<$key> in the cookies not only sets cookie attributes such as
358             Expires, but also treats the cookie as a hash of key value pairs which can later
359             be accesses by
360              
361             $Request->Cookies('Test', 'data1');
362             $Request->Cookies('Test', 'data2');
363              
364             Because this is perl, you can (though it's not portable!) reference the cookies
365             directly through hash notation. The same 5 commands above could be compressed
366             to:
367              
368             $Response->{Cookies}{Test} = {
369             Secure => 1,
370             Value => {
371             data1 => 'test value',
372             data2 => 'more test'
373             },
374             Expires => 86400, # not portable, see above
375             Domain => 'host.com',
376             Path => '/'
377             };
378              
379             and the first command would be:
380              
381             # you don't need to use hash notation when you are only setting
382             # a simple value
383             $Response->{Cookies}{'Test Name'} = 'Test Value';
384              
385             I prefer the hash notation for cookies, as this looks nice, and is quite
386             perl-ish. It is here to stay. The C<Cookie()> routine is very complex and does
387             its best to allow access to the underlying hash structure of the data. This is
388             the best emulation I could write trying to match the Collections functionality
389             of cookies in IIS ASP.
390              
391             For more information on Cookies, please go to the source at
392             http://home.netscape.com/newsref/std/cookie_spec.html
393              
394             =cut
395              
396             sub Cookies {
397 19     19 1 1280 my ( $self, $name, @cookie ) = @_;
398              
399 19 100       81 if ( @cookie == 0 ) {
    100          
400 14         416 return $self->_get_Cookies;
401             } elsif ( @cookie == 1 ) {
402 2         5 my $value = $cookie[0];
403 2         75 $self->_set_Cookie( $name => { Value => $value } );
404 2         20 return $value;
405             } else {
406 3         9 my ( $key, $value ) = @cookie;
407 3 50       11 if ( $key =~ m/secure|value|expires|domain|path|httponly/i ) {
408 0 0       0 if ( my $existing = $self->_get_Cookie( $name ) ) {
409 0         0 return $existing->{$key} = $value;
410             } else {
411 0         0 $self->_set_Cookie( $name => { $key => $value } );
412 0         0 return $value;
413             }
414             } else {
415 3 100       106 if ( my $existing = $self->_get_Cookie( $name ) ) {
416 1         5 return $existing->{Value}{$key} = $value;
417             } else {
418 2         64 $self->_set_Cookie( $name => { Value => { $key => $value } } );
419 2         20 return $value;
420             }
421             }
422             }
423             }
424              
425             =item $Response->Debug(@args)
426              
427             API Extension. If the Debug config option is set greater than C<0>, this routine
428             will write C<@args> out to server error log. Refs in C<@args> will be expanded
429             one level deep, so data in simple data structures like one-level hash refs and
430             array refs will be displayed. CODE refs like
431              
432             $Response->Debug(sub { "some value" });
433              
434             will be executed and their output added to the debug output. This extension
435             allows the user to tie directly into the debugging capabilities of this module.
436              
437             While developing an app on a production server, it is often useful to have a
438             separate error log for the application to catch debugging output separately.
439              
440             If you want further debugging support, like stack traces in your code, consider
441             doing things like:
442              
443             $Response->Debug( sub { Carp::longmess('debug trace') };
444             $SIG{__WARN__} = \&Carp::cluck; # then warn() will stack trace
445              
446             The only way at present to see exactly where in your script an error occurred is
447             to set the Debug config directive to 2, and match the error line number to perl
448             script generated from your ASP script.
449              
450             However, as of version C<0.10>, the perl script generated from the asp script
451             should match almost exactly line by line, except in cases of inlined includes,
452             which add to the text of the original script, pod comments which are entirely
453             yanked out, and C<< <% # comment %> >> style comments which have a C<\n> added
454             to them so they still work.
455              
456             =cut
457              
458             sub Debug {
459 1     1 1 590 my ( $self, @args ) = @_;
460 1         3 local $Data::Dumper::Maxdepth = 1;
461 1         8 $self->AppendToLog( Dumper( \@args ) );
462             }
463              
464             =item $Response->End()
465              
466             Sends result to client, and immediately exits script. Automatically called at
467             end of script, if not already called.
468              
469             =cut
470              
471             sub End {
472 2     2 1 73 shift->Clear;
473 2         26 CatalystX::ASP::Exception::End->throw;
474             }
475              
476             # TODO to implement or not to implement?
477             sub ErrorDocument {
478 1     1 0 501 my ( $self, $code, $uri ) = @_;
479 1         31 $self->asp->c->log->warn( "\$Reponse->ErrorDocument has not been implemented!" );
480 1         15 return;
481             }
482              
483             =item $Response->Flush()
484              
485             Sends buffered output to client and clears buffer.
486              
487             =cut
488              
489             sub Flush {
490 2     2 1 6 my ( $self ) = @_;
491 2         54 $self->asp->GlobalASA->Script_OnFlush;
492 2         90 $self->_flushed_offset( $self->BodyLength );
493             }
494              
495             =item $Response->Include($filename, @args)
496              
497             This API extension calls the routine compiled from asp script in C<$filename>
498             with the args @args. This is a direct translation of the SSI tag
499              
500             <!--#include file=$filename args=@args-->
501              
502             Please see the SSI section for more on SSI in general.
503              
504             This API extension was created to allow greater modularization of code by
505             allowing includes to be called with runtime arguments. Files included are
506             compiled once, and the anonymous code ref from that compilation is cached, thus
507             including a file in this manner is just like calling a perl subroutine. The
508             C<@args> can be found in C<@_> in the includes like:
509              
510             # include.inc
511             <% my @args = @_; %>
512              
513             As of C<2.23>, multiple return values can be returned from an include like:
514              
515             my @rv = $Response->Include($filename, @args);
516              
517             =item $Response->Include(\$script_text, @args)
518              
519             Added in Apache::ASP C<2.11>, this method allows for executing ASP scripts that
520             are generated dynamically by passing in a reference to the script data instead
521             of the file name. This works just like the normal C<< $Response->Include() >>
522             API, except a string reference is passed in instead of a filename. For example:
523              
524             <%
525             my $script = "<\% print 'TEST'; %\>";
526             $Response->Include(\$script);
527             %>
528              
529             This include would output C<TEST>. Note that tokens like C<< <% >> and C<< %> >>
530             must be escaped so Apache::ASP does not try to compile those code blocks
531             directly when compiling the original script. If the C<$script> data were fetched
532             directly from some external resource like a database, then these tokens would
533             not need to be escaped at all as in:
534              
535             <%
536             my $script = $dbh->selectrow_array(
537             "select script_text from scripts where script_id = ?",
538             undef, $script_id
539             );
540             $Response->Include(\$script);
541             %>
542              
543             This method could also be used to render other types of dynamic scripts, like
544             XML docs using XMLSubs for example, though for complex runtime XML rendering,
545             one should use something better suited like XSLT.
546              
547             =cut
548              
549             sub Include {
550 9     9 1 169 my ( $self, $include, @args ) = @_;
551 9         259 my $asp = $self->asp;
552 9         244 my $c = $asp->c;
553              
554 9         19 my $compiled;
555 9 100 66     46 if ( ref( $include ) && ref( $include ) eq 'SCALAR' ) {
556 2         4 my $scriptref = $include;
557 2         8 my $parsed_object = $asp->parse( $c, $scriptref );
558             $compiled = {
559             mtime => time(),
560             perl => $parsed_object->{data},
561 2         8 };
562 2   100     9 my $caller = [ caller( 1 ) ]->[3] || 'main';
563 2         97 my $id = join( '', '__ASP_', $caller, 'x', $asp->_compile_checksum );
564 2         45 my $subid = join( '', $asp->GlobalASA->package, '::', $id, 'xREF' );
565 2 50 33     17 if ( $parsed_object->{is_perl}
566             && ( my $code = $asp->compile( $c, $parsed_object->{data}, $subid ) ) ) {
567 2         5 $compiled->{is_perl} = 1;
568 2         6 $compiled->{code} = $code;
569             } else {
570 0         0 $compiled->{is_raw} = 1;
571 0         0 $compiled->{code} = $parsed_object->{data};
572             }
573             } else {
574 7         49 $compiled = $asp->compile_include( $c, $include );
575 7 50       27 return unless $compiled;
576             }
577              
578 9         26 my $code = $compiled->{code};
579              
580             # exit early for cached static file
581 9 100       30 if ( $compiled->{is_raw} ) {
582 1         5 $self->WriteRef( $code );
583 1         26 return;
584             }
585              
586 8         38 $asp->execute( $c, $code, @args );
587             }
588              
589             =item $Response->IsClientConnected()
590              
591             API Extension. C<1> for web client still connected, C<0> if disconnected which
592             might happen if the user hits the stop button. The original API for this
593             C<< $Response->{IsClientConnected} >> is only updated after a
594             C<< $Response->Flush >> is called, so this method may be called for a refreshed
595             status.
596              
597             Note C<< $Response->Flush >> calls C<< $Response->IsClientConnected >> to
598             update C<< $Response->{IsClientConnected} >> so to use this you are going
599             straight to the source! But if you are doing a loop like:
600              
601             while(@data) {
602             $Response->End if ! $Response->{IsClientConnected};
603             my $row = shift @data;
604             %> <%= $row %> <%
605             $Response->Flush;
606             }
607              
608             Then its more efficient to use the member instead of the method since
609             C<< $Response->Flush() >> has already updated that value for you.
610              
611             =item $Response->Redirect($url)
612              
613             Sends the client a command to go to a different url C<$url>. Script immediately
614             ends.
615              
616             =cut
617              
618             sub Redirect {
619 3     3 1 55 my ( $self, $url ) = @_;
620 3         80 my $c = $self->asp->c;
621              
622 3         17 $self->_flush_Cookies( $c );
623 3         123 $self->Status( 302 );
624 3         51 $c->response->redirect( $url );
625 3         397 $c->detach;
626             }
627              
628             =item $Response->TrapInclude($file, @args)
629              
630             Calls $Response->Include() with same arguments as passed to it, but instead
631             traps the include output buffer and returns it as as a perl string reference.
632             This allows one to postprocess the output buffer before sending to the client.
633              
634             my $string_ref = $Response->TrapInclude('file.inc');
635             $$string_ref =~ s/\s+/ /sg; # squash whitespace like Clean 1
636             print $$string_ref;
637              
638             The data is returned as a referenece to save on what might be a large string
639             copy. You may dereference the data with the $$string_ref notation.
640              
641             =cut
642              
643             sub TrapInclude {
644 3     3 1 1160 my ( $self, $include, @args ) = @_;
645              
646 3         103 my $saved = $self->Body;
647 3         19 $self->Clear;
648              
649 9     9   68 no warnings 'redefine';
  9         17  
  9         2279  
650 3     0   25 local *CatalystX::ASP::Response::Flush = sub { };
651 3         41 local $self->{out} = local $self->{BinaryRef} = \( $self->{Body} );
652              
653 3         15 $self->Include( $include, @args );
654 3         75 my $trapped = $self->Body;
655              
656 3         67 $self->Body( $saved );
657              
658 3         54 return \$trapped;
659             }
660              
661             =item $Response->Write($data)
662              
663             Write output to the HTML page. C<< <%=$data%> >> syntax is shorthand for a
664             C<< $Response->Write($data) >>. All final output to the client must at some
665             point go through this method.
666              
667             =cut
668              
669             sub _flush_Cookies {
670 13     13   56 my ( $self, $c ) = @_;
671 13         416 my $cookies = $self->_get_Cookies;
672 13         58 for my $name ( keys %$cookies ) {
673 9         64 my $cookie = $cookies->{$name};
674 9 50       25 if ( ref $cookie eq 'HASH' ) {
675 9         19 for my $key ( keys %$cookie ) {
676              
677             # This is really to support Apache::ASP's support hashes in cookies
678 9 100 66     53 if ( $key =~ m/value/i && ref( $cookie->{$key} ) eq 'HASH' ) {
679             $c->response->cookies->{$name}{value} =
680 4         9 [ map { "$_=" . $cookie->{$key}{$_} } keys %{ $cookie->{$key} } ];
  6         53  
  4         14  
681             } else {
682              
683             # Thankfully, don't need to make 'value' an arrayref for CGI::Simple::Cookie
684 5         33 $c->response->cookies->{$name}{ lc( $key ) } = $cookie->{$key};
685             }
686             }
687             } else {
688 0           $c->response->cookies->{$name}{value} = $cookie;
689             }
690             }
691             }
692              
693             __PACKAGE__->meta->make_immutable;
694              
695             =back
696              
697             =head1 SEE ALSO
698              
699             =over
700              
701             =item * L<CatalystX::ASP::Session>
702              
703             =item * L<CatalystX::ASP::Request>
704              
705             =item * L<CatalystX::ASP::Application>
706              
707             =item * L<CatalystX::ASP::Server>
708              
709             =back