root/trunk/lib/Mungo/Response.pm

Revision 15, 7.0 kB (checked in by jesus, 7 years ago)

Properly unwind the IO stack and do cleaner re-throws of errors. This makes complicate OnError? subroutines work with errors that occur in TrapIncludes?, refs #7

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 use strict;
8 use IO::Handle;
9 use Mungo::Arbiter::Response;
10 use Mungo::Response::Trap;
11 use Mungo::Cookie;
12 use Mungo::Utils;
13 use HTML::Entities;
14 our $AUTOLOAD;
15
16 my $one_true_buffer = '';
17
18 sub new {
19   my $class = shift;
20   my $parent = shift;
21   my $r = $parent->{'Apache::Request'};
22   my $singleton = $r->pnotes(__PACKAGE__);
23   return $singleton if ($singleton);
24   my %core_data = (
25     'Apache::Request' => $r,
26     'ContentType' => $r->dir_config('MungoContentType') || $r->content_type || 'text/html',
27     # We don't set buffer here, we set it after it has been tied.
28     # 'Buffer' => $r->dir_config('MungoBuffer') || 0,
29     'Buffer' => 0,
30     'CacheControl' => $r->dir_config('MungoCacheControl') || 'private',
31     'Charset' => $r->dir_config('MungoCharset') || undef,
32     'Status' => 200,
33     'Mungo' => $parent,
34     'CookieClass' => $r->dir_config('MungoCookieClass') || 'Mungo::Cookie',
35     'Cookies' => undef, # placeholder for visibility
36   );
37   my %data;
38   $singleton = bless \%data, $class;
39   tie %data, 'Mungo::Arbiter::Response', $singleton, \%core_data;
40   $singleton->{Buffer} = $r->dir_config('MungoBuffer') || 0;
41   $r->pnotes(__PACKAGE__, $singleton);
42   return $singleton;
43 }
44
45 sub DESTROY {
46   my $self = shift;
47   $self->cleanse();
48 }
49
50 sub cleanse {
51   my $self = shift;
52   if(ref $self->{'IO_stack'} eq 'ARRAY') {
53     while (@{$self->{'IO_stack'}}) {
54       my $fh = pop @{$self->{'IO_stack'}};
55       close(select($fh));
56     }
57   }
58   delete $self->{$_} for keys %$self;
59   untie %$self if tied %$self;
60 }
61
62 sub send_http_header {
63   my $self = shift;
64   my $r = $self->{'Apache::Request'};
65   return if($self->{'__HEADERS_SENT__'});
66   $self->{'__HEADERS_SENT__'} = 1;
67   if($self->{CacheControl} eq 'no-cache') {
68     $r->no_cache(1);
69   }
70   else {
71     $r->header_out('Cache-Control', $self->{CacheControl});
72   }
73   $self->{Cookies}->inject_headers($r);
74   $r->status($self->{Status});
75   $r->send_http_header($self->{ContentType});
76 }
77
78 sub start {
79   my $self = shift;
80   return if(exists $self->{'IO_stack'} &&
81             scalar(@{$self->{'IO_stack'}}) > 0);
82   $self->{'IO_stack'} = [];
83   tie *DIRECT, ref $self, $self;
84   push @{$self->{'IO_stack'}}, select(DIRECT);
85 }
86
87 sub finish {
88   my $self = shift;
89   # Unbuffer outselves, this will actually induce a flush
90   $self->{Buffer} = 0;
91   untie *DIRECT if tied *DIRECT;
92   return unless(exists $self->{'IO_stack'});
93   my $fh = $self->{'IO_stack'}->[0];
94   delete $self->{'IO_stack'};
95   die __PACKAGE__." IO stack of wrong depth" if(scalar(@{$self->{'IO_stack'}}) != 1);
96 }
97
98 sub AddHeader {
99   my $self = shift;
100   my $r = $self->{'Apache::Request'};
101   die "Headers already sent." if($self->{'__HEADERS_SENT__'});
102   $r->header_out(@_);
103 }
104 sub Cookies {
105   my $self = shift;
106   die "Headers already sent." if($self->{'__HEADERS_SENT__'});
107   my $cookie = $self->{'Cookies'};
108   $cookie->__set(@_);
109 }
110 sub Redirect {
111   my $self = shift;
112   my $url = shift;
113   die "Cannot redirect, headers already sent\n" if($self->{'__HEADERS_SENT__'});
114   $self->{Status} = shift || 302;
115   $self->{'Apache::Request'}->header_out('Location', $url);
116   $self->send_http_header();
117   $self->End();
118 }
119 sub Include {
120   my $self = shift;
121   my $subject = shift;
122   my $rv;
123   eval {
124     if(ref $subject) {
125       $rv = $self->{'Mungo'}->include_mem($subject, @_);
126     }
127     else {
128       $rv = $self->{'Mungo'}->include_file($subject, @_);
129     }
130   };
131   if($@) {
132     # If we have more than 1 item in the IO stack, we should just re-raise.
133     if (scalar(@{$self->{'IO_stack'}}) > 1) {
134       local $SIG{__DIE__} = undef;
135       die $@;
136     }
137     my $href = $@;
138     eval {
139       if($self->{OnError}) {
140         $self->{OnError}->($self, $href, $subject);
141       }
142       else {
143         $self->defaultErrorHandler($href, $subject);
144       }
145     };
146     if($@) {
147       # Oh, dear lord this is bad.  We'd died trying to print out death.
148       print STDERR "Mungo::Response -> die in error renderer\n";
149       print STDERR $href;
150       print STDERR $@;
151     }
152     return undef;
153   }
154   return $rv;
155 }
156
157 sub defaultErrorHandler {
158   use Data::Dumper;
159   my $self = shift;
160   my $href = shift; # Our Error
161   my $subject = shift;
162   print "Error in Include($subject):<br />\n";
163   my $pkg = $href->{callstack}->[0]->[0];
164   my $preamble = eval "\$${pkg}::Mungo_preamble;";
165   my $postamble = eval "\$${pkg}::Mungo_postamble;";
166   my $contents = eval "\$${pkg}::Mungo_contents;";
167   print "<pre class=\"error\">$href->{error}</pre><br />\n";
168
169   unless($contents) {
170     my $filename = $href->{callstack}->[0]->[1];
171     if(open(FILE, "<$filename")) {
172       local $/ = undef;
173       $$contents = <FILE>;
174       close(FILE);
175     }
176   }
177
178   if($contents) {
179     if($self->{'Apache::Request'}->dir_config('Debug')) {
180       print Mungo::Utils::pretty_print_code($preamble, $contents, $postamble, $href->{callstack}->[0]->[2]);
181     }
182   } else {
183     print '<pre>'.Dumper($@).'</pre>';
184   }
185 }
186
187 sub TrapInclude {
188   my $self = shift;
189   my $output;
190   my $handle = \do { local *HANDLE };
191   tie *{$handle}, 'Mungo::Response::Trap', \$output;
192   push @{$self->{'IO_stack'}}, select(*{$handle});
193   eval {
194     $self->Include(@_);
195   };
196   untie *{$handle} if tied *{$handle};
197   select(pop @{$self->{'IO_stack'}});
198   if($@) {
199     local $SIG{__DIE__} = undef;
200     die $@;
201   }
202   return $output;
203 }
204
205 sub End {
206   my $self = shift;
207   while(scalar(@{$self->{'IO_stack'}}) > 1) {
208     my $oldfh = select(pop @{$self->{'IO_stack'}});
209     if(my $obj = tied *{$oldfh}) {
210       untie *{$oldfh};
211       print $$obj;
212     }
213   }
214   $self->Flush();
215   eval { goto  MUNGO_HANDLER_FINISH; };
216 }
217
218 sub Flush {
219   my $self = shift;
220   # Flush doesn't apply unless we're immediately above STDOUT
221   return if(scalar(@{$self->{'IO_stack'}}) > 1);
222   unless($self->{'__OUTPUT_STARTED__'}) {
223     $self->send_http_header;
224     $self->{'__OUTPUT_STARTED__'} = 1;
225   }
226   $self->{'IO_stack'}->[-1]->print($one_true_buffer);
227   $one_true_buffer = '';
228 }
229
230 sub AUTOLOAD {
231   my $self = shift;
232   my $name = $AUTOLOAD;
233   $name =~ s/.*://;   # strip fully-qualified portion
234   die __PACKAGE__." does not implement $name";
235 }
236
237 sub TIEHANDLE {
238   my $class = shift;
239   my $self = shift;
240   return $self;
241 }
242 sub PRINT {
243   my $self = shift;
244   my $output = shift;
245   if(scalar(@{$self->{'IO_stack'}}) == 1) {
246     # Buffering a just-in-time headers only applies if we
247     # immediately above STDOUT
248     if($self->{Buffer}) {
249       $one_true_buffer .= $output;
250       return;
251     }
252     unless($self->{'__OUTPUT_STARTED__'}) {
253       $self->{'__OUTPUT_STARTED__'} = 1;
254       $self->send_http_header;
255     }
256   }
257   $self->{'IO_stack'}->[-1]->print($output);
258 }
259 sub PRINTF {
260   my $self = shift;
261   if(scalar(@{$self->{'IO_stack'}}) == 1) {
262     # Buffering a just-in-time headers only applies if we
263     # immediately above STDOUT
264     if($self->{Buffer}) {
265       $one_true_buffer .= sprintf(@_);
266       return;
267     }
268     unless($self->{'__OUTPUT_STARTED__'}) {
269       $self->{'__OUTPUT_STARTED__'} = 1;
270       $self->send_http_header;
271     }
272   }
273   $self->{'IO_stack'}->[-1]->printf(@_);
274 }
275 sub CLOSE {
276   my $self = shift;
277   $self->{Buffer} = 0;
278 }
279 sub UNTIE { }
280
281 1;
Note: See TracBrowser for help on using the browser.