root/trunk/lib/Mungo/Response.pm

Revision 102, 15.1 kB (checked in by jesus, 4 years ago)

this addresses 500 on errors. fixes #16

Line 
1 package Mungo::Response;
2
3 # Copyright (c) 2007 OmniTI Computer Consulting, Inc. All rights reserved.
4 # For information on licensing see:
5 #   https://labs.omniti.com/zetaback/trunk/LICENSE
6
7 =head1 NAME
8
9 Mungo::Response - Represent response side of HTTP request cycle
10
11 =head1 SYNOPSIS
12
13   <!-- You get a Response object for free when you use Mungo -->
14   <% if ($Response) { ... } %>
15
16   <!-- Read and Mungo-process other files -->
17   <%
18      # Prints to browser
19      $Response->Include('/some/file.html', $arg1);
20
21      # Caputured
22      my $output = $Response->TrapInclude('/some/file.html');
23
24      # Can also print to browser via Response
25      print $Response "Hello world!";
26   %>
27
28   <!-- May also set headers -->
29   <%
30      $Response->AddHeader('header_name' => $value);
31   %>
32
33   <!-- path of the current file (handy for debugging) -->
34   <% my $file = $Response->CurrentFile(); %>
35
36
37   <!-- Halt processing and jump out of the handler -->
38   <%
39      # With a 302
40      $Response->Redirect('/new/url/');
41
42      # Just end
43      $Response->End();
44   %>
45
46   <!-- Cookie facility -->
47   <%
48      # Single valued cookies
49      $Response->Cookies($cookie_name, $cookie_value);
50
51      # Multivalued cookies
52      $Response->Cookies($cookie_name, $key, $value);
53
54      # Cookie options
55      $Response->Cookies($cookie_name, 'Domain', $value);
56      $Response->Cookies($cookie_name, 'Expires', $value);
57      $Response->Cookies($cookie_name, 'Path', $value);
58      $Response->Cookies($cookie_name, 'Secure', $value);
59
60      # See perldoc Mungo::Cookie for more details
61   %>
62
63 =head1 DESCRIPTION
64
65 Represents the response side of the Mungo request cycle.  All operations related to output are contained in this object.
66
67 =head2 OUTPUT BUFFERING
68
69 By default, output is not buffered.  Output (resulting from print() statements or <%= %> tags) is immediately sent to the browser.  Mungo does support a buffering mechanism, in which the entire contents of the response (or sub-include) are collected before the first character is output.  The buffer does not have a size limit, other than practical limits of your machine; nor is it chunked in any way.
70
71 You can enable buffering in two ways.  From within httpd.conf, you can use the MungoBuffer Perl variable:
72
73   # Can use Directory, Files, Location, etc.
74   <Directory /www/slowboat>
75      # Any Perlishly true value will work
76      SetPerlVar MungoBuffer 1
77   </Directory>
78
79 Additionally, you can enable (or disable) buffering within a particular request-response cycle:
80
81   <%
82      # Decide to turn on buffering
83      $Response->{Buffer} = 1;
84   %>
85
86 Disabling buffering (when it was previously enabled) will cause an immediate flush.
87
88 At the end of the request, the buffer is flushed in its entirety.
89
90 If you enable buffering at the top-level page, you can add headers throughout the response, even after generating output.  Without buffering, this would normally be an error.  This advantage does not apply to sub-includes.  Of course, if you generated output and then later enabled buffering, you cannot later add headers.
91
92 =head1 METHODS
93
94 =cut
95
96
97 use strict;
98 use IO::Handle;
99 use Mungo::Arbiter::Response;
100 use Mungo::Response::Trap;
101 use Mungo::Cookie;
102 use Mungo::Utils;
103 use HTML::Entities;
104 use Apache2::Const qw ( OK NOT_FOUND DECLINED SERVER_ERROR);
105
106 our $AUTOLOAD;
107
108 our $DEBUG = 0;
109 use Data::Dumper;
110
111 my $one_true_buffer = '';
112
113 sub new {
114   my $class = shift;
115   my $parent = shift;
116   my $r = $parent->{'Apache::Request'};
117   my $singleton = $r->pnotes(__PACKAGE__);
118   return $singleton if ($singleton);
119   my %core_data = (
120     'Apache::Request' => $r,
121     'ContentType' => $r->dir_config('MungoContentType') || $r->content_type || 'text/html',
122     # We don't set buffer here, we set it after it has been tied.
123     # 'Buffer' => $r->dir_config('MungoBuffer') || 0,
124     'Buffer' => 0,
125     'CacheControl' => $r->dir_config('MungoCacheControl') || 'private',
126     'Charset' => $r->dir_config('MungoCharset') || undef,
127     'Status' => 200,
128     'Mungo' => $parent,
129     'CookieClass' => $r->dir_config('MungoCookieClass') || 'Mungo::Cookie',
130     'Cookies' => undef, # placeholder for visibility
131   );
132   my %data;
133   $singleton = bless \%data, $class;
134   tie %data, 'Mungo::Arbiter::Response', $singleton, \%core_data;
135   $singleton->{Buffer} = $r->dir_config('MungoBuffer') || 0;
136   $r->pnotes(__PACKAGE__, $singleton);
137   return $singleton;
138 }
139
140 sub DESTROY {
141   my $self = shift;
142   $self->cleanse();
143 }
144
145 sub cleanse {
146   my $self = shift;
147   my $_r = tied %$self;
148   if(ref $_r->{data}->{'IO_stack'} eq 'ARRAY') {
149     while (@{$_r->{data}->{'IO_stack'}}) {
150       my $fh = pop @{$_r->{data}->{'IO_stack'}};
151       close(select($fh));
152     }
153   }
154   delete $_r->{data}->{$_} for keys %$self;
155   untie %$self if tied %$self;
156 }
157
158 sub send_http_header {
159   my $self = shift;
160   my $_r = tied %$self;
161   my $r = $_r->{data}->{'Apache::Request'};
162   return if($_r->{data}->{'__HEADERS_SENT__'});
163   $_r->{data}->{'__HEADERS_SENT__'} = 1;
164   if($_r->{data}->{CacheControl} eq 'no-cache') {
165     $r->no_cache(1);
166   }
167   else {
168     if($r->can('headers_out')) {
169       $r->err_headers_out->set('Cache-Control' => $_r->{data}->{CacheControl});
170     }
171     else {
172       $r->err_header_out('Cache-Control' => $_r->{data}->{CacheControl});
173     }
174   }
175   # Must use Internal as the tiehash is magic for cookies
176   $_r->{'__Internal__'}->{Cookies}->inject_headers($r);
177   $r->status($_r->{data}->{Status});
178   $r->can('send_http_header') ?
179     $r->send_http_header($_r->{data}->{ContentType}) :
180     $r->content_type($_r->{data}->{ContentType});;
181 }
182
183 sub start {
184   my $self = shift;
185   my $_r = tied %$self;
186   return if(exists $_r->{data}->{'IO_stack'} &&
187             scalar(@{$_r->{data}->{'IO_stack'}}) > 0);
188   $_r->{data}->{'IO_stack'} = [];
189   tie *DIRECT, ref $self, $self;
190   push @{$_r->{data}->{'IO_stack'}}, select(DIRECT);
191 }
192
193 sub finish {
194   my $self = shift;
195   my $_r = tied %$self;
196   # Unbuffer outselves, this will actually induce a flush (must go through tiehash)
197   $_r->{'__Internal__'}->{Buffer} = 0;
198   untie *DIRECT if tied *DIRECT;
199   return unless(exists $_r->{data}->{'IO_stack'});
200   my $fh = $_r->{data}->{'IO_stack'}->[0];
201   die __PACKAGE__." IO stack of wrong depth" if(scalar(@{$_r->{data}->{'IO_stack'}}) != 1);
202 }
203
204 =head2 $file = $Response->CurrentFile();
205
206 =head2 @nested_files = $Response->CurrentFile();
207
208 Returns the path on the filesystem from which the currently executing Mungo code originated.  In the second form, the call stack is unwound, and all files are returned, with the deepest-nested one first. 
209
210 If the Mungo code originated from a string reference rather than a file, the file entry will read 'ANON'.
211
212 =cut
213
214 sub CurrentFile {
215     my $self = shift;
216     return $self->{Mungo}->CurrentFile();
217 }
218
219 =head2 $Response->i18nHandler($coderef);
220
221 Sets the i18n translation handler for the output.  This is translate phases
222 (or keys) in templates annotated like I[[keyname]].  If the handler is unset
223 the default behaviour is to pass the keyname through so "I[[Firstname]]"
224 becomes "Firstname"  The handler passed in should take one argument (the key)
225 and return the replacement text.
226
227 =head2 $Response->i18n($text)
228
229 Runs the registered i18n handler on the supplied text returning the
230 translation.
231
232 =cut
233
234 sub i18nHandler {
235   my $self = shift;  my $_r = tied %$self;
236   $_r->{data}->{'i18n_handler'} = shift if (@_);
237   return $_r->{data}->{'i18n_handler'};
238 }
239
240 sub i18n {
241   my $self = shift;  my $_r = tied %$self;
242   my $key = shift;
243   my $handler = $_r->{data}->{'i18n_handler'};
244   return ($handler && ref $handler eq 'CODE') ? $handler->($key) : $key;
245 }
246
247
248 =head2 $Response->AddHeader('header_name' => 'header_value');
249
250 Adds an HTTP header to the response.
251
252 Dies if headers (or any other output) has already been sent.
253
254 =cut
255
256 sub AddHeader {
257   my $self = shift;
258   my $_r = tied %$self;
259   my $r = $_r->{data}->{'Apache::Request'};
260   die "Headers already sent." if($_r->{data}->{'__HEADERS_SENT__'});
261   $r->can('headers_out') ? $r->err_headers_out->set(@_) : $r->err_header_out(@_);
262 }
263 sub Cookies {
264   my $self = shift;
265   my $_r = tied %$self;
266   die "Headers already sent." if($_r->{data}->{'__HEADERS_SENT__'});
267   # Must use Internal as the tiehash is magic for cookies
268   my $cookie = $_r->{'__Internal__'}->{'Cookies'};
269   unless ($cookie) {
270       # Ok, use the magic version to construct one.
271       $cookie = $self->{'Cookies'};
272   }
273   $cookie->__set(@_);
274 }
275
276 =head2 $Response->Redirect($url);
277
278 Issues a 302 redirect with the new location as $url.
279
280 Dies if headers (or any other output) has already been sent.
281
282 =cut
283
284 sub Redirect {
285   my $self = shift;
286   my $url = shift;
287   my $_r = tied %$self;
288   die "Cannot redirect, headers already sent\n" if($_r->{data}->{'__HEADERS_SENT__'});
289   $_r->{data}->{Status} = shift || 302;
290   my $r = $_r->{data}->{'Apache::Request'};
291   $r->can('headers_out') ? $r->err_headers_out->set('Location', $url) :
292                            $r->err_header_out('Location', $url);
293   $self->send_http_header();
294   $self->End();
295 }
296
297
298 =head2 $res->Include($filename, $arg1, $arg2, ...);
299
300 =head2 $res->Include(\$string, $arg1, $arg2, ...);
301
302 Reads the given filename or string and interprets it as Mungo ASP code.
303
304 Any passed arguments are available in the @_ array within the ASP code.
305
306 The results of evaluating the code is printed to STDOUT.
307
308 =cut
309
310 sub Include {
311     my $self = shift;
312     my $subject = shift;
313     my $_r = tied %$self;
314     my $rv;
315
316     if ($DEBUG > 1) {
317         print STDERR __PACKAGE__ . ':' . __LINE__ . "- Have self OnError as " . $self->{data}->{OnError} . "\n";
318         print STDERR __PACKAGE__ . ':' . __LINE__ . "- Have tied OnError as " . $_r->{data}->{OnError} . "\n";
319     }
320
321     eval {
322         local $SIG{__DIE__} = \&Mungo::wrapErrorsInObjects;
323         if(ref $subject) {
324             $rv = $_r->{data}->{Mungo}->include_mem($subject, @_);
325         } else {
326             $rv = $_r->{data}->{Mungo}->include_file($subject, @_);
327         }
328     };
329     if($@) {
330         if ($DEBUG) { print STDERR __PACKAGE__ . ':' . __LINE__ . "- Have level one error: " . $@ . "\n"; }
331
332         # If we have more than 1 item in the IO stack, we should just re-raise.
333         if (scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1) {
334             local $SIG{__DIE__} = undef;
335             if ($DEBUG > 1) { print STDERR __PACKAGE__ . ':' . __LINE__ . "- rethrowing\n"; }
336             die $@;
337         }
338         my $hashref = $@;
339         eval {
340             if($_r->{data}->{OnError}) {
341                 if ($DEBUG > 1) { print STDERR __PACKAGE__ . ':' . __LINE__ . "- have custom error handler, calling\n"; }
342                 $_r->{data}->{OnError}->($self, $hashref, $subject);
343             } else {
344                 if ($DEBUG > 1) { print STDERR __PACKAGE__ . ':' . __LINE__ . "- no custom error handler, using default\n"; }
345                 $self->defaultErrorHandler($hashref, $subject);
346             }
347         };
348         if ($@) {
349             # Oh, dear lord this is bad.  We'd died trying to print out death.
350             print STDERR "Mungo::Response -> die in error renderer\n";
351             print STDERR $hashref;
352             print STDERR $@;
353         }
354         return undef;
355     }
356     return $rv;
357 }
358
359 sub defaultErrorHandler {
360   use Data::Dumper;
361   my $self = shift;
362   my $href = shift; # Our Error
363   my $subject = shift;
364   my $_r = tied %$self;
365   if ($DEBUG > 1) { print STDERR __PACKAGE__ . ':' . __LINE__ . "- in default error handler\n"; }
366
367   print "Error in Include($subject):<br />\n";
368   my $pkg = $href->{callstack}->[0]->[0];
369   my $preamble = eval "\$${pkg}::Mungo_preamble;";
370   my $postamble = eval "\$${pkg}::Mungo_postamble;";
371   my $contents = eval "\$${pkg}::Mungo_contents;";
372   print "<pre class=\"error\">$href->{error}</pre><br />\n";
373
374   unless($contents) {
375     my $filename = $href->{callstack}->[0]->[1];
376     if(open(FILE, "<$filename")) {
377       local $/ = undef;
378       $$contents = <FILE>;
379       close(FILE);
380     }
381   }
382
383   if($contents) {
384     if($_r->{data}->{'Apache::Request'}->dir_config('Debug')) {
385       print Mungo::Utils::pretty_print_code($preamble, $contents, $postamble, $href->{callstack}->[0]->[2]);
386     }
387   } else {
388     print '<pre>'.Dumper($@).'</pre>';
389   }
390
391   # Set response code to 500.  Fixes trac16
392   $_r->{data}->{Status} = SERVER_ERROR;
393   $self->{Mungo}->{data}->{ApacheResponseCode} = SERVER_ERROR;
394 }
395
396 =head2 $output = $Response->TrapInclude($filename, @args);
397
398 Like Include(), but results are returned as a string, instead of being printed.
399
400 =cut
401
402 sub TrapInclude {
403   my $self = shift;
404   my $_r = tied %$self;
405   my $output;
406   my $handle = \do { local *HANDLE };
407   tie *{$handle}, 'Mungo::Response::Trap', \$output;
408   push @{$_r->{data}->{'IO_stack'}}, select(*{$handle});
409   eval {
410     $self->Include(@_);
411   };
412   untie *{$handle} if tied *{$handle};
413   select(pop @{$_r->{data}->{'IO_stack'}});
414   if($@) {
415     local $SIG{__DIE__} = undef;
416     die $@;
417   }
418   return $output;
419 }
420
421 =head2 $Response->End()
422
423 Stops processing the current response, shuts down the
424 output handle, and jumps out of the response handler. 
425 No further processing will occur.
426
427 =cut
428
429 sub End {
430   my $self = shift;
431   my $_r = tied %$self;
432   while(scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1) {
433     my $oldfh = select(pop @{$_r->{data}->{'IO_stack'}});
434     if(my $obj = tied *{$oldfh}) {
435       untie *{$oldfh};
436       print $$obj;
437     }
438   }
439   $self->Flush();
440   eval { goto  MUNGO_HANDLER_FINISH; }; # Jump back to Mungo::handler()
441 }
442
443 sub Flush {
444   my $self = shift;
445   my $_r = tied %$self;
446   # Flush doesn't apply unless we're immediately above STDOUT
447   return if(scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1);
448   unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
449     $self->send_http_header;
450     $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
451   }
452   if (@{$_r->{data}->{'IO_stack'} || []}) {
453       $_r->{data}->{'IO_stack'}->[-1]->print($one_true_buffer);
454   } else {
455       print $one_true_buffer;
456   }
457
458   $one_true_buffer = '';
459 }
460
461 sub AUTOLOAD {
462   my $self = shift;
463   my $name = $AUTOLOAD;
464   $name =~ s/.*://;   # strip fully-qualified portion
465   die __PACKAGE__." does not implement $name";
466 }
467
468 sub TIEHANDLE {
469   my $class = shift;
470   my $self = shift;
471   return $self;
472 }
473 sub PRINT {
474   my $self = shift;
475   my $output = shift;
476   my $_r = tied %$self;
477   if(scalar(@{$_r->{data}->{'IO_stack'} || []}) == 1) {
478     # Buffering a just-in-time headers only applies if we
479     # immediately above STDOUT
480     if($_r->{data}->{Buffer}) {
481       $one_true_buffer .= $output;
482       return;
483     }
484     unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
485       $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
486       $self->send_http_header;
487     }
488   }
489   if (@{$_r->{data}->{'IO_stack'} || []}) {
490       $_r->{data}->{'IO_stack'}->[-1]->print($output);
491   } else {
492       print $output;
493   }
494 }
495 sub PRINTF {
496   my $self = shift;
497   my $_r = tied %$self;
498   if(scalar(@{$_r->{data}->{'IO_stack'} || []}) == 1) {
499     # Buffering a just-in-time headers only applies if we
500     # immediately above STDOUT
501     if($_r->{data}->{Buffer}) {
502       $one_true_buffer .= sprintf(@_);
503       return;
504     }
505     unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
506       $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
507       $self->send_http_header;
508     }
509   }
510   if (@{$_r->{data}->{'IO_stack'} || []}) {
511       $_r->{data}->{'IO_stack'}->[-1]->printf(@_);
512   } else {
513       printf(@_);
514   }
515 }
516 sub CLOSE {
517   my $self = shift;
518   my $_r = tied %$self;
519   # Unbuffer outselves, this will actually induce a flush (must go through tiehash)
520   $_r->{data}->{Buffer} = 0;
521 }
522 sub UNTIE { }
523
524 =head1 AUTHOR
525
526 Theo Schlossnagle
527
528 Clinton Wolfe (docs)
529
530 =cut
531
532 1;
Note: See TracBrowser for help on using the browser.