root/trunk/lib/Mungo/Response.pm

Revision 45, 10.9 kB (checked in by clinton, 5 years ago)

Send HTTP headers regardless of status code

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   <!-- Halt processing and jump out of the handler -->
34   <%
35      # With a 302
36      $Response->Redirect('/new/url/');
37
38      # Just end
39      $Response->End();
40   %>
41
42   <!-- Cookie facility -->
43   <%
44      # Single valued cookies
45      $Response->Cookies($cookie_name, $cookie_value);
46
47      # Multivalued cookies
48      $Response->Cookies($cookie_name, $key, $value);
49
50      # Cookie options
51      $Response->Cookies($cookie_name, 'Domain', $value);
52      $Response->Cookies($cookie_name, 'Expires', $value);
53      $Response->Cookies($cookie_name, 'Path', $value);
54      $Response->Cookies($cookie_name, 'Secure', $value);
55   %>
56
57 =head1 DESCRIPTION
58
59 Represents the response side of the Mungo request cycle.
60
61 =cut
62
63
64 use strict;
65 use IO::Handle;
66 use Mungo::Arbiter::Response;
67 use Mungo::Response::Trap;
68 use Mungo::Cookie;
69 use Mungo::Utils;
70 use HTML::Entities;
71 our $AUTOLOAD;
72
73 my $one_true_buffer = '';
74
75 sub new {
76   my $class = shift;
77   my $parent = shift;
78   my $r = $parent->{'Apache::Request'};
79   my $singleton = $r->pnotes(__PACKAGE__);
80   return $singleton if ($singleton);
81   my %core_data = (
82     'Apache::Request' => $r,
83     'ContentType' => $r->dir_config('MungoContentType') || $r->content_type || 'text/html',
84     # We don't set buffer here, we set it after it has been tied.
85     # 'Buffer' => $r->dir_config('MungoBuffer') || 0,
86     'Buffer' => 0,
87     'CacheControl' => $r->dir_config('MungoCacheControl') || 'private',
88     'Charset' => $r->dir_config('MungoCharset') || undef,
89     'Status' => 200,
90     'Mungo' => $parent,
91     'CookieClass' => $r->dir_config('MungoCookieClass') || 'Mungo::Cookie',
92     'Cookies' => undef, # placeholder for visibility
93   );
94   my %data;
95   $singleton = bless \%data, $class;
96   tie %data, 'Mungo::Arbiter::Response', $singleton, \%core_data;
97   $singleton->{Buffer} = $r->dir_config('MungoBuffer') || 0;
98   $r->pnotes(__PACKAGE__, $singleton);
99   return $singleton;
100 }
101
102 sub DESTROY {
103   my $self = shift;
104   $self->cleanse();
105 }
106
107 sub cleanse {
108   my $self = shift;
109   my $_r = tied %$self;
110   if(ref $_r->{data}->{'IO_stack'} eq 'ARRAY') {
111     while (@{$_r->{data}->{'IO_stack'}}) {
112       my $fh = pop @{$_r->{data}->{'IO_stack'}};
113       close(select($fh));
114     }
115   }
116   delete $_r->{data}->{$_} for keys %$self;
117   untie %$self if tied %$self;
118 }
119
120 sub send_http_header {
121   my $self = shift;
122   my $_r = tied %$self;
123   my $r = $_r->{data}->{'Apache::Request'};
124   return if($_r->{data}->{'__HEADERS_SENT__'});
125   $_r->{data}->{'__HEADERS_SENT__'} = 1;
126   if($_r->{data}->{CacheControl} eq 'no-cache') {
127     $r->no_cache(1);
128   }
129   else {
130     if($r->can('headers_out')) {
131       $r->err_headers_out->set('Cache-Control' => $_r->{data}->{CacheControl});
132     }
133     else {
134       $r->err_header_out('Cache-Control' => $_r->{data}->{CacheControl});
135     }
136   }
137   # Must use Internal as the tiehash is magic for cookies
138   $_r->{'__Internal__'}->{Cookies}->inject_headers($r);
139   $r->status($_r->{data}->{Status});
140   $r->can('send_http_header') ?
141     $r->send_http_header($_r->{data}->{ContentType}) :
142     $r->content_type($_r->{data}->{ContentType});;
143 }
144
145 sub start {
146   my $self = shift;
147   my $_r = tied %$self;
148   return if(exists $_r->{data}->{'IO_stack'} &&
149             scalar(@{$_r->{data}->{'IO_stack'}}) > 0);
150   $_r->{data}->{'IO_stack'} = [];
151   tie *DIRECT, ref $self, $self;
152   push @{$_r->{data}->{'IO_stack'}}, select(DIRECT);
153 }
154
155 sub finish {
156   my $self = shift;
157   my $_r = tied %$self;
158   # Unbuffer outselves, this will actually induce a flush (must go through tiehash)
159   $_r->{'__Internal__'}->{Buffer} = 0;
160   untie *DIRECT if tied *DIRECT;
161   return unless(exists $_r->{data}->{'IO_stack'});
162   my $fh = $_r->{data}->{'IO_stack'}->[0];
163   die __PACKAGE__." IO stack of wrong depth" if(scalar(@{$_r->{data}->{'IO_stack'}}) != 1);
164 }
165
166 =head2 $Response->AddHeader('header_name' => 'header_value');
167
168 Adds an HTTP header to the response.
169
170 Dies if headers (or any other output) has already been sent.
171
172 =cut
173
174 sub AddHeader {
175   my $self = shift;
176   my $_r = tied %$self;
177   my $r = $_r->{data}->{'Apache::Request'};
178   die "Headers already sent." if($_r->{data}->{'__HEADERS_SENT__'});
179   $r->can('headers_out') ? $r->err_headers_out->set(@_) : $r->err_header_out(@_);
180 }
181 sub Cookies {
182   my $self = shift;
183   my $_r = tied %$self;
184   die "Headers already sent." if($_r->{data}->{'__HEADERS_SENT__'});
185   # Must use Internal as the tiehash is magic for cookies
186   my $cookie = $_r->{'__Internal__'}->{'Cookies'};
187   $cookie->__set(@_);
188 }
189
190 =head2 $Response->Redirect($url);
191
192 Issues a 302 redirect with the new location as $url.
193
194 Dies if headers (or any other output) has already been sent.
195
196 =cut
197
198 sub Redirect {
199   my $self = shift;
200   my $url = shift;
201   my $_r = tied %$self;
202   die "Cannot redirect, headers already sent\n" if($_r->{data}->{'__HEADERS_SENT__'});
203   $_r->{data}->{Status} = shift || 302;
204   my $r = $_r->{data}->{'Apache::Request'};
205   $r->can('headers_out') ? $r->err_headers_out->set('Location', $url) :
206                            $r->err_header_out('Location', $url);
207   $self->send_http_header();
208   $self->End();
209 }
210
211
212 =head2 $res->Include($filename, $arg1, $arg2, ...);
213
214 =head2 $res->Include(\$string, $arg1, $arg2, ...);
215
216 Reads the given filename or string and interprets it as Mungo ASP code.
217
218 Any passed arguments are available in the @_ array within the ASP code.
219
220 The results of evaluating the code is printed to STDOUT.
221
222 =cut
223
224 sub Include {
225   my $self = shift;
226   my $subject = shift;
227   my $_r = tied %$self;
228   my $rv;
229   eval {
230     local $SIG{__DIE__} = \&Mungo::MungoDie;
231     if(ref $subject) {
232       $rv = $_r->{data}->{Mungo}->include_mem($subject, @_);
233     }
234     else {
235       $rv = $_r->{data}->{Mungo}->include_file($subject, @_);
236     }
237   };
238   if($@) {
239     # If we have more than 1 item in the IO stack, we should just re-raise.
240     if (scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1) {
241       local $SIG{__DIE__} = undef;
242       die $@;
243     }
244     my $hashref = $@;
245     eval {
246       if($_r->{data}->{OnError}) {
247         $_r->{data}->{OnError}->($self, $hashref, $subject);
248       }
249       else {
250         $self->defaultErrorHandler($hashref, $subject);
251       }
252     };
253     if($@) {
254       # Oh, dear lord this is bad.  We'd died trying to print out death.
255       print STDERR "Mungo::Response -> die in error renderer\n";
256       print STDERR $hashref;
257       print STDERR $@;
258     }
259     return undef;
260   }
261   return $rv;
262 }
263
264 sub defaultErrorHandler {
265   use Data::Dumper;
266   my $self = shift;
267   my $href = shift; # Our Error
268   my $subject = shift;
269   my $_r = tied %$self;
270   print "Error in Include($subject):<br />\n";
271   my $pkg = $href->{callstack}->[0]->[0];
272   my $preamble = eval "\$${pkg}::Mungo_preamble;";
273   my $postamble = eval "\$${pkg}::Mungo_postamble;";
274   my $contents = eval "\$${pkg}::Mungo_contents;";
275   print "<pre class=\"error\">$href->{error}</pre><br />\n";
276
277   unless($contents) {
278     my $filename = $href->{callstack}->[0]->[1];
279     if(open(FILE, "<$filename")) {
280       local $/ = undef;
281       $$contents = <FILE>;
282       close(FILE);
283     }
284   }
285
286   if($contents) {
287     if($_r->{data}->{'Apache::Request'}->dir_config('Debug')) {
288       print Mungo::Utils::pretty_print_code($preamble, $contents, $postamble, $href->{callstack}->[0]->[2]);
289     }
290   } else {
291     print '<pre>'.Dumper($@).'</pre>';
292   }
293 }
294
295 =head2 $output = $Response->TrapInclude($filename, @args);
296
297 Like Include(), but results are returned as a string, instead of being printed.
298
299 =cut
300
301 sub TrapInclude {
302   my $self = shift;
303   my $_r = tied %$self;
304   my $output;
305   my $handle = \do { local *HANDLE };
306   tie *{$handle}, 'Mungo::Response::Trap', \$output;
307   push @{$_r->{data}->{'IO_stack'}}, select(*{$handle});
308   eval {
309     $self->Include(@_);
310   };
311   untie *{$handle} if tied *{$handle};
312   select(pop @{$_r->{data}->{'IO_stack'}});
313   if($@) {
314     local $SIG{__DIE__} = undef;
315     die $@;
316   }
317   return $output;
318 }
319
320 =head2 $Response->End()
321
322 Stops processing the current response, shuts down the
323 output handle, and jumps out of the response handler. 
324 No further processing will occur.
325
326 =cut
327
328 sub End {
329   my $self = shift;
330   my $_r = tied %$self;
331   while(scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1) {
332     my $oldfh = select(pop @{$_r->{data}->{'IO_stack'}});
333     if(my $obj = tied *{$oldfh}) {
334       untie *{$oldfh};
335       print $$obj;
336     }
337   }
338   $self->Flush();
339   eval { goto  MUNGO_HANDLER_FINISH; }; # Jump back to Mungo::handler()
340 }
341
342 sub Flush {
343   my $self = shift;
344   my $_r = tied %$self;
345   # Flush doesn't apply unless we're immediately above STDOUT
346   return if(scalar(@{$_r->{data}->{'IO_stack'} || []}) > 1);
347   unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
348     $self->send_http_header;
349     $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
350   }
351   if (@{$_r->{data}->{'IO_stack'} || []}) {
352       $_r->{data}->{'IO_stack'}->[-1]->print($one_true_buffer);
353   } else {
354       print $one_true_buffer;
355   }
356
357   $one_true_buffer = '';
358 }
359
360 sub AUTOLOAD {
361   my $self = shift;
362   my $name = $AUTOLOAD;
363   $name =~ s/.*://;   # strip fully-qualified portion
364   die __PACKAGE__." does not implement $name";
365 }
366
367 sub TIEHANDLE {
368   my $class = shift;
369   my $self = shift;
370   return $self;
371 }
372 sub PRINT {
373   my $self = shift;
374   my $output = shift;
375   my $_r = tied %$self;
376   if(scalar(@{$_r->{data}->{'IO_stack'} || []}) == 1) {
377     # Buffering a just-in-time headers only applies if we
378     # immediately above STDOUT
379     if($_r->{data}->{Buffer}) {
380       $one_true_buffer .= $output;
381       return;
382     }
383     unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
384       $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
385       $self->send_http_header;
386     }
387   }
388   if (@{$_r->{data}->{'IO_stack'} || []}) {
389       $_r->{data}->{'IO_stack'}->[-1]->print($output);
390   } else {
391       print $output;
392   }
393 }
394 sub PRINTF {
395   my $self = shift;
396   my $_r = tied %$self;
397   if(scalar(@{$_r->{data}->{'IO_stack'} || []}) == 1) {
398     # Buffering a just-in-time headers only applies if we
399     # immediately above STDOUT
400     if($_r->{data}->{Buffer}) {
401       $one_true_buffer .= sprintf(@_);
402       return;
403     }
404     unless($_r->{data}->{'__OUTPUT_STARTED__'}) {
405       $_r->{data}->{'__OUTPUT_STARTED__'} = 1;
406       $self->send_http_header;
407     }
408   }
409   if (@{$_r->{data}->{'IO_stack'} || []}) {
410       $_r->{data}->{'IO_stack'}->[-1]->printf(@_);
411   } else {
412       printf(@_);
413   }
414 }
415 sub CLOSE {
416   my $self = shift;
417   my $_r = tied %$self;
418   # Unbuffer outselves, this will actually induce a flush (must go through tiehash)
419   $_r->{data}->{Buffer} = 0;
420 }
421 sub UNTIE { }
422
423 =head1 AUTHOR
424
425 Theo Schlossnagle
426
427 Clinton Wolfe (docs)
428
429 =cut
430
431 1;
Note: See TracBrowser for help on using the browser.