root/trunk/lib/Mungo/Response.pm

Revision 33, 7.7 kB (checked in by clinton, 6 years ago)

First stabs at documentation

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
129
130 =head2 $res->Include($filename, $arg1, $arg2, ...);
131
132 =head2 $res->Include(\$string, $arg1, $arg2, ...);
133
134 Reads the given filename or string and interprets it as Mungo ASP code.
135
136 Any passed arguments are available in the @_ array within the ASP code.
137
138 The results of evaluating the code is printed to STDOUT.
139
140 =cut
141
142 sub Include {
143   my $self = shift;
144   my $subject = shift;
145   my $rv;
146   eval {
147     if(ref $subject) {
148       $rv = $self->{'Mungo'}->include_mem($subject, @_);
149     }
150     else {
151       $rv = $self->{'Mungo'}->include_file($subject, @_);
152     }
153   };
154   if($@) {
155     # If we have more than 1 item in the IO stack, we should just re-raise.
156     if (scalar(@{$self->{'IO_stack'}}) > 1) {
157       local $SIG{__DIE__} = undef;
158       die $@;
159     }
160     my $href = $@;
161     eval {
162       if($self->{OnError}) {
163         $self->{OnError}->($self, $href, $subject);
164       }
165       else {
166         $self->defaultErrorHandler($href, $subject);
167       }
168     };
169     if($@) {
170       # Oh, dear lord this is bad.  We'd died trying to print out death.
171       print STDERR "Mungo::Response -> die in error renderer\n";
172       print STDERR $href;
173       print STDERR $@;
174     }
175     return undef;
176   }
177   return $rv;
178 }
179
180 sub defaultErrorHandler {
181   use Data::Dumper;
182   my $self = shift;
183   my $href = shift; # Our Error
184   my $subject = shift;
185   print "Error in Include($subject):<br />\n";
186   my $pkg = $href->{callstack}->[0]->[0];
187   my $preamble = eval "\$${pkg}::Mungo_preamble;";
188   my $postamble = eval "\$${pkg}::Mungo_postamble;";
189   my $contents = eval "\$${pkg}::Mungo_contents;";
190   print "<pre class=\"error\">$href->{error}</pre><br />\n";
191
192   unless($contents) {
193     my $filename = $href->{callstack}->[0]->[1];
194     if(open(FILE, "<$filename")) {
195       local $/ = undef;
196       $$contents = <FILE>;
197       close(FILE);
198     }
199   }
200
201   if($contents) {
202     if($self->{'Apache::Request'}->dir_config('Debug')) {
203       print Mungo::Utils::pretty_print_code($preamble, $contents, $postamble, $href->{callstack}->[0]->[2]);
204     }
205   } else {
206     print '<pre>'.Dumper($@).'</pre>';
207   }
208 }
209
210 sub TrapInclude {
211   my $self = shift;
212   my $output;
213   my $handle = \do { local *HANDLE };
214   tie *{$handle}, 'Mungo::Response::Trap', \$output;
215   push @{$self->{'IO_stack'}}, select(*{$handle});
216   eval {
217     $self->Include(@_);
218   };
219   untie *{$handle} if tied *{$handle};
220   select(pop @{$self->{'IO_stack'}});
221   if($@) {
222     local $SIG{__DIE__} = undef;
223     die $@;
224   }
225   return $output;
226 }
227
228 sub End {
229   my $self = shift;
230   while(scalar(@{$self->{'IO_stack'}}) > 1) {
231     my $oldfh = select(pop @{$self->{'IO_stack'}});
232     if(my $obj = tied *{$oldfh}) {
233       untie *{$oldfh};
234       print $$obj;
235     }
236   }
237   $self->Flush();
238   eval { goto  MUNGO_HANDLER_FINISH; }; # Jump back to Mungo::handler()
239 }
240
241 sub Flush {
242   my $self = shift;
243   # Flush doesn't apply unless we're immediately above STDOUT
244   return if(scalar(@{$self->{'IO_stack'}}) > 1);
245   unless($self->{'__OUTPUT_STARTED__'}) {
246     $self->send_http_header;
247     $self->{'__OUTPUT_STARTED__'} = 1;
248   }
249   $self->{'IO_stack'}->[-1]->print($one_true_buffer);
250   $one_true_buffer = '';
251 }
252
253 sub AUTOLOAD {
254   my $self = shift;
255   my $name = $AUTOLOAD;
256   $name =~ s/.*://;   # strip fully-qualified portion
257   die __PACKAGE__." does not implement $name";
258 }
259
260 sub TIEHANDLE {
261   my $class = shift;
262   my $self = shift;
263   return $self;
264 }
265 sub PRINT {
266   my $self = shift;
267   my $output = shift;
268   if(scalar(@{$self->{'IO_stack'}}) == 1) {
269     # Buffering a just-in-time headers only applies if we
270     # immediately above STDOUT
271     if($self->{Buffer}) {
272       $one_true_buffer .= $output;
273       return;
274     }
275     unless($self->{'__OUTPUT_STARTED__'}) {
276       $self->{'__OUTPUT_STARTED__'} = 1;
277       $self->send_http_header;
278     }
279   }
280   $self->{'IO_stack'}->[-1]->print($output);
281 }
282 sub PRINTF {
283   my $self = shift;
284   if(scalar(@{$self->{'IO_stack'}}) == 1) {
285     # Buffering a just-in-time headers only applies if we
286     # immediately above STDOUT
287     if($self->{Buffer}) {
288       $one_true_buffer .= sprintf(@_);
289       return;
290     }
291     unless($self->{'__OUTPUT_STARTED__'}) {
292       $self->{'__OUTPUT_STARTED__'} = 1;
293       $self->send_http_header;
294     }
295   }
296   $self->{'IO_stack'}->[-1]->printf(@_);
297 }
298 sub CLOSE {
299   my $self = shift;
300   $self->{Buffer} = 0;
301 }
302 sub UNTIE { }
303
304 1;
Note: See TracBrowser for help on using the browser.