root/trunk/lib/Mungo/Response.pm

Revision 17, 7.4 kB (checked in by jesus, 6 years ago)

first whack at resolving mod_perl2 support. refs #8

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     if($r->can('headers_out')) {
72       $r->headers_out->set('Cache-Control' => $self->{CacheControl});
73     }
74     else {
75       $r->header_out('Cache-Control' => $self->{CacheControl});
76     }
77   }
78   $self->{Cookies}->inject_headers($r);
79   $r->status($self->{Status});
80   $r->can('send_http_header') ?
81     $r->send_http_header($self->{ContentType}) :
82     $r->content_type($self->{ContentType});;
83 }
84
85 sub start {
86   my $self = shift;
87   return if(exists $self->{'IO_stack'} &&
88             scalar(@{$self->{'IO_stack'}}) > 0);
89   $self->{'IO_stack'} = [];
90   tie *DIRECT, ref $self, $self;
91   push @{$self->{'IO_stack'}}, select(DIRECT);
92 }
93
94 sub finish {
95   my $self = shift;
96   # Unbuffer outselves, this will actually induce a flush
97   $self->{Buffer} = 0;
98   untie *DIRECT if tied *DIRECT;
99   return unless(exists $self->{'IO_stack'});
100   my $fh = $self->{'IO_stack'}->[0];
101   delete $self->{'IO_stack'};
102   die __PACKAGE__." IO stack of wrong depth" if(scalar(@{$self->{'IO_stack'}}) != 1);
103 }
104
105 sub AddHeader {
106   my $self = shift;
107   my $r = $self->{'Apache::Request'};
108   die "Headers already sent." if($self->{'__HEADERS_SENT__'});
109   $r->can('headers_out') ? $r->headers_out->set(@_) : $r->header_out(@_);
110 }
111 sub Cookies {
112   my $self = shift;
113   die "Headers already sent." if($self->{'__HEADERS_SENT__'});
114   my $cookie = $self->{'Cookies'};
115   $cookie->__set(@_);
116 }
117 sub Redirect {
118   my $self = shift;
119   my $url = shift;
120   die "Cannot redirect, headers already sent\n" if($self->{'__HEADERS_SENT__'});
121   $self->{Status} = shift || 302;
122   my $r = $self->{'Apache::Request'};
123   $r->can('headers_out') ? $r->headers_out->set('Location', $url) :
124                            $r->header_out('Location', $url);
125   $self->send_http_header();
126   $self->End();
127 }
128 sub Include {
129   my $self = shift;
130   my $subject = shift;
131   my $rv;
132   eval {
133     if(ref $subject) {
134       $rv = $self->{'Mungo'}->include_mem($subject, @_);
135     }
136     else {
137       $rv = $self->{'Mungo'}->include_file($subject, @_);
138     }
139   };
140   if($@) {
141     # If we have more than 1 item in the IO stack, we should just re-raise.
142     if (scalar(@{$self->{'IO_stack'}}) > 1) {
143       local $SIG{__DIE__} = undef;
144       die $@;
145     }
146     my $href = $@;
147     eval {
148       if($self->{OnError}) {
149         $self->{OnError}->($self, $href, $subject);
150       }
151       else {
152         $self->defaultErrorHandler($href, $subject);
153       }
154     };
155     if($@) {
156       # Oh, dear lord this is bad.  We'd died trying to print out death.
157       print STDERR "Mungo::Response -> die in error renderer\n";
158       print STDERR $href;
159       print STDERR $@;
160     }
161     return undef;
162   }
163   return $rv;
164 }
165
166 sub defaultErrorHandler {
167   use Data::Dumper;
168   my $self = shift;
169   my $href = shift; # Our Error
170   my $subject = shift;
171   print "Error in Include($subject):<br />\n";
172   my $pkg = $href->{callstack}->[0]->[0];
173   my $preamble = eval "\$${pkg}::Mungo_preamble;";
174   my $postamble = eval "\$${pkg}::Mungo_postamble;";
175   my $contents = eval "\$${pkg}::Mungo_contents;";
176   print "<pre class=\"error\">$href->{error}</pre><br />\n";
177
178   unless($contents) {
179     my $filename = $href->{callstack}->[0]->[1];
180     if(open(FILE, "<$filename")) {
181       local $/ = undef;
182       $$contents = <FILE>;
183       close(FILE);
184     }
185   }
186
187   if($contents) {
188     if($self->{'Apache::Request'}->dir_config('Debug')) {
189       print Mungo::Utils::pretty_print_code($preamble, $contents, $postamble, $href->{callstack}->[0]->[2]);
190     }
191   } else {
192     print '<pre>'.Dumper($@).'</pre>';
193   }
194 }
195
196 sub TrapInclude {
197   my $self = shift;
198   my $output;
199   my $handle = \do { local *HANDLE };
200   tie *{$handle}, 'Mungo::Response::Trap', \$output;
201   push @{$self->{'IO_stack'}}, select(*{$handle});
202   eval {
203     $self->Include(@_);
204   };
205   untie *{$handle} if tied *{$handle};
206   select(pop @{$self->{'IO_stack'}});
207   if($@) {
208     local $SIG{__DIE__} = undef;
209     die $@;
210   }
211   return $output;
212 }
213
214 sub End {
215   my $self = shift;
216   while(scalar(@{$self->{'IO_stack'}}) > 1) {
217     my $oldfh = select(pop @{$self->{'IO_stack'}});
218     if(my $obj = tied *{$oldfh}) {
219       untie *{$oldfh};
220       print $$obj;
221     }
222   }
223   $self->Flush();
224   eval { goto  MUNGO_HANDLER_FINISH; };
225 }
226
227 sub Flush {
228   my $self = shift;
229   # Flush doesn't apply unless we're immediately above STDOUT
230   return if(scalar(@{$self->{'IO_stack'}}) > 1);
231   unless($self->{'__OUTPUT_STARTED__'}) {
232     $self->send_http_header;
233     $self->{'__OUTPUT_STARTED__'} = 1;
234   }
235   $self->{'IO_stack'}->[-1]->print($one_true_buffer);
236   $one_true_buffer = '';
237 }
238
239 sub AUTOLOAD {
240   my $self = shift;
241   my $name = $AUTOLOAD;
242   $name =~ s/.*://;   # strip fully-qualified portion
243   die __PACKAGE__." does not implement $name";
244 }
245
246 sub TIEHANDLE {
247   my $class = shift;
248   my $self = shift;
249   return $self;
250 }
251 sub PRINT {
252   my $self = shift;
253   my $output = shift;
254   if(scalar(@{$self->{'IO_stack'}}) == 1) {
255     # Buffering a just-in-time headers only applies if we
256     # immediately above STDOUT
257     if($self->{Buffer}) {
258       $one_true_buffer .= $output;
259       return;
260     }
261     unless($self->{'__OUTPUT_STARTED__'}) {
262       $self->{'__OUTPUT_STARTED__'} = 1;
263       $self->send_http_header;
264     }
265   }
266   $self->{'IO_stack'}->[-1]->print($output);
267 }
268 sub PRINTF {
269   my $self = shift;
270   if(scalar(@{$self->{'IO_stack'}}) == 1) {
271     # Buffering a just-in-time headers only applies if we
272     # immediately above STDOUT
273     if($self->{Buffer}) {
274       $one_true_buffer .= sprintf(@_);
275       return;
276     }
277     unless($self->{'__OUTPUT_STARTED__'}) {
278       $self->{'__OUTPUT_STARTED__'} = 1;
279       $self->send_http_header;
280     }
281   }
282   $self->{'IO_stack'}->[-1]->printf(@_);
283 }
284 sub CLOSE {
285   my $self = shift;
286   $self->{Buffer} = 0;
287 }
288 sub UNTIE { }
289
290 1;
Note: See TracBrowser for help on using the browser.