File Coverage

blib/lib/HTML/Mason/FakeApache.pm
Criterion Covered Total %
statement 149 192 77.6
branch 58 88 65.9
condition 14 29 48.2
subroutine 48 71 67.6
pod 0 41 0.0
total 269 421 63.9


line stmt bran cond sub pod time code
1             package HTML::Mason::FakeApache;
2             $HTML::Mason::FakeApache::VERSION = '1.58';
3 2     2   11 use strict;
  2         3  
  2         49  
4 2     2   9 use warnings;
  2         3  
  2         53  
5              
6             # We need to define an Apache package or we might get strange errors
7             # like "Can't locate package Apache for
8             # @HTML::Mason::FakeApache::ISA". We do the BEGIN/eval thing so that
9             # the CPAN indexer doesn't pick it up, which would be ugly.
10 2     2   106 BEGIN { eval "package Apache" }
11              
12             @HTML::Mason::FakeApache::ISA = qw(Apache);
13             # Analogous to Apache request object $r (but not an actual Apache subclass)
14             # In the future we'll probably want to switch this to Apache::Fake or similar
15              
16 2     2   10 use HTML::Mason::MethodMaker(read_write => [qw(query)]);
  2         4  
  2         12  
17              
18             sub new {
19 8     8 0 245 my $class = shift;
20 8         21 my %p = @_;
21             return bless {
22 8   33     52 query => $p{cgi} || CGI->new,
23             headers_out => HTML::Mason::FakeTable->new,
24             err_headers_out => HTML::Mason::FakeTable->new,
25             pnotes => {},
26             }, $class;
27             }
28              
29             # CGI request are _always_ main, and there is never a previous or a next
30             # internal request.
31       0 0   sub main {}
32       0 0   sub prev {}
33       0 0   sub next {}
34 0     0 0 0 sub is_main {1}
35 0     0 0 0 sub is_initial_req {1}
36              
37             # What to do with this?
38             # sub allowed {}
39              
40             sub method {
41 1     1 0 6 $_[0]->query->request_method;
42             }
43              
44             # There mut be a mapping for this.
45             # sub method_number {}
46              
47             # Can CGI.pm tell us this?
48             # sub bytes_sent {0}
49              
50             # The request line sent by the client." Poached from Apache::Emulator.
51             sub the_request {
52 0     0 0 0 my $self = shift;
53             $self->{the_request} ||= join ' ', $self->method,
54             ( $self->{query}->query_string
55             ? $self->uri . '?' . $self->{query}->query_string
56             : $self->uri ),
57 0 0 0     0 $self->{query}->server_protocol;
58             }
59              
60             # Is CGI ever a proxy request?
61             # sub proxy_req {}
62              
63 0     0 0 0 sub header_only { $_[0]->method eq 'HEAD' }
64              
65 0 0   0 0 0 sub protocol { $ENV{SERVER_PROTOCOL} || 'HTTP/1.0' }
66              
67 0     0 0 0 sub hostname { $_[0]->{query}->server_name }
68              
69             # CGI says "use this when using virtual hosts". It falls back to
70             # CGI->server_port.
71 0     0 0 0 sub get_server_port { $_[0]->{query}->virtual_port }
72              
73             # Fake it by just giving the current time.
74 0     0 0 0 sub request_time { time }
75              
76             sub uri {
77 1     1 0 3955 my $self = shift;
78              
79 1   50     10 $self->{uri} ||= $self->{query}->script_name . $self->path_info || '';
      33        
80             }
81              
82             # Is this available in CGI?
83             # sub filename {}
84              
85             # "The $r->location method will return the path of the
86             # section from which the current "Perl*Handler"
87             # is being called." This is irrelevant, I think.
88             # sub location {}
89              
90 2     2 0 97 sub path_info { $_[0]->{query}->path_info }
91              
92             sub args {
93 0     0 0 0 my $self = shift;
94 0 0       0 if (@_) {
95             # Assign args here.
96             }
97 0 0       0 return $self->{query}->Vars unless wantarray;
98             # Do more here to return key => arg values.
99             }
100              
101             sub headers_in {
102 2     2 0 4 my $self = shift;
103              
104             # Create the headers table if necessary. Decided how to build it based on
105             # information here:
106             # http://cgi-spec.golux.com/draft-coar-cgi-v11-03-clean.html#6.1
107             #
108             # Try to get as much info as possible from CGI.pm, which has
109             # workarounds for things like the IIS PATH_INFO bug.
110             #
111             $self->{headers_in} ||= HTML::Mason::FakeTable->new
112             ( 'Authorization' => $self->{query}->auth_type, # No credentials though.
113             'Content-Length' => $ENV{CONTENT_LENGTH},
114             'Content-Type' =>
115             ( $self->{query}->can('content_type') ?
116             $self->{query}->content_type :
117             $ENV{CONTENT_TYPE}
118             ),
119             # Convert HTTP environment variables back into their header names.
120             map {
121 11         148 my $k = ucfirst lc;
122 11         33 $k =~ s/_(.)/-\u$1/g;
123 11         28 ( $k => $self->{query}->http($_) )
124 2 50 66     18 } grep { s/^HTTP_// } keys %ENV
  20         61  
125             );
126              
127              
128             # Give 'em the hash list of the hash table.
129 2 50       10 return wantarray ? %{$self->{headers_in}} : $self->{headers_in};
  0         0  
130             }
131              
132             sub header_in {
133 1     1 0 4 my ($self, $header) = (shift, shift);
134 1         6 my $h = $self->headers_in;
135 1 50       5 return @_ ? $h->set($header, shift) : $h->get($header);
136             }
137              
138              
139             # The $r->content method will return the entity body
140             # read from the client, but only if the request content
141             # type is "application/x-www-form-urlencoded". When
142             # called in a scalar context, the entire string is
143             # returned. When called in a list context, a list of
144             # parsed key => value pairs are returned. *NOTE*: you
145             # can only ask for this once, as the entire body is read
146             # from the client.
147             # Not sure what to do with this one.
148             # sub content {}
149              
150             # I think this may be irrelevant under CGI.
151             # sub read {}
152              
153             # Use LWP?
154       0 0   sub get_remote_host {}
155       0 0   sub get_remote_logname {}
156              
157             sub http_header {
158 13     13 0 17 my $self = shift;
159 13         24 my $h = $self->headers_out;
160 13         25 my $e = $self->err_headers_out;
161             my $method = exists $h->{Location} || exists $e->{Location} ?
162 13 100 100     51 'redirect' : 'header';
163 13         42 return $self->query->$method(tied(%$h)->cgi_headers,
164             tied(%$e)->cgi_headers);
165             }
166              
167             sub send_http_header {
168 6     6 0 7 my $self = shift;
169              
170 6 50       9 return if $self->http_header_sent;
171              
172 6         14 print STDOUT $self->http_header;
173              
174 6         2080 $self->{http_header_sent} = 1;
175             }
176              
177 12     12 0 36 sub http_header_sent { shift->{http_header_sent} }
178              
179             # How do we know this under CGI?
180             # sub get_basic_auth_pw {}
181             # sub note_basic_auth_failure {}
182              
183             # I think that this just has to be empty.
184       0 0   sub handler {}
185              
186             sub notes {
187 4     4 0 9 my ($self, $key) = (shift, shift);
188 4   66     16 $self->{notes} ||= HTML::Mason::FakeTable->new;
189 0         0 return wantarray ? %{$self->{notes}} : $self->{notes}
190 4 50       15 unless defined $key;
    100          
191 3 100       12 return $self->{notes}{$key} = "$_[0]" if @_;
192 2         8 return $self->{notes}{$key};
193             }
194              
195             sub pnotes {
196 3     3 0 9 my ($self, $key) = (shift, shift);
197 0         0 return wantarray ? %{$self->{pnotes}} : $self->{pnotes}
198 3 50       12 unless defined $key;
    100          
199 2 100       10 return $self->{pnotes}{$key} = $_[0] if @_;
200 1         6 return $self->{pnotes}{$key};
201             }
202              
203             sub subprocess_env {
204 10     10 0 22 my ($self, $key) = (shift, shift);
205 10 100       24 unless (defined $key) {
206 3         17 $self->{subprocess_env} = HTML::Mason::FakeTable->new(%ENV);
207 0         0 return wantarray ? %{$self->{subprocess_env}} :
208 3 50       19 $self->{subprocess_env};
209              
210             }
211 7   66     23 $self->{subprocess_env} ||= HTML::Mason::FakeTable->new(%ENV);
212 7 100       19 return $self->{subprocess_env}{$key} = "$_[0]" if @_;
213 6         25 return $self->{subprocess_env}{$key};
214             }
215              
216             sub content_type {
217 2     2 0 544 shift->header_out('Content-Type', @_);
218             }
219              
220             sub content_encoding {
221 0     0 0 0 shift->header_out('Content-Encoding', @_);
222             }
223              
224             sub content_languages {
225 0     0 0 0 my ($self, $langs) = @_;
226 0 0       0 return unless $langs;
227 0         0 my $h = shift->headers_out;
228 0         0 for my $l (@$langs) {
229 0         0 $h->add('Content-Language', $l);
230             }
231             }
232              
233             sub status {
234 0     0 0 0 shift->header_out('Status', @_);
235             }
236              
237             sub status_line {
238             # What to do here? Should it be managed differently than status?
239 0     0 0 0 my $self = shift;
240 0 0       0 if (@_) {
241 0         0 my $status = shift =~ /^(\d+)/;
242 0         0 return $self->header_out('Status', $status);
243             }
244 0         0 return $self->header_out('Status');
245             }
246              
247             sub headers_out {
248 25     25 0 35 my $self = shift;
249 25 100       67 return wantarray ? %{$self->{headers_out}} : $self->{headers_out};
  1         6  
250             }
251              
252             sub header_out {
253 8     8 0 17 my ($self, $header) = (shift, shift);
254 8         20 my $h = $self->headers_out;
255 8 100       27 return @_ ? $h->set($header, shift) : $h->get($header);
256             }
257              
258             sub err_headers_out {
259 15     15 0 24 my $self = shift;
260 15 50       32 return wantarray ? %{$self->{err_headers_out}} : $self->{err_headers_out};
  0         0  
261             }
262              
263             sub err_header_out {
264 1     1 0 3 my ($self, $err_header) = (shift, shift);
265 1         3 my $h = $self->err_headers_out;
266 1 50       6 return @_ ? $h->set($err_header, shift) : $h->get($err_header);
267             }
268              
269             sub no_cache {
270 0     0 0 0 my $self = shift;
271 0         0 $self->header_out(Pragma => 'no-cache');
272 0         0 $self->header_out('Cache-Control' => 'no-cache');
273             }
274              
275             sub print {
276 0     0 0 0 shift;
277 0         0 print @_;
278             }
279              
280             sub send_fd {
281 0     0 0 0 my ($self, $fd) = @_;
282 0         0 local $_;
283              
284 0         0 print STDOUT while defined ($_ = <$fd>);
285             }
286              
287             # Should this perhaps throw an exception?
288             # sub internal_redirect {}
289             # sub internal_redirect_handler {}
290              
291             # Do something with ErrorDocument?
292             # sub custom_response {}
293              
294             # I think we've made this essentially the same thing.
295             BEGIN {
296 2     2   13 local $^W;
297 2         195 *send_cgi_header = \&send_http_header;
298             }
299              
300             # Does CGI support logging?
301             # sub log_reason {}
302             # sub log_error {}
303             sub warn {
304 0     0 0 0 shift;
305 0         0 print STDERR @_, "\n";
306             }
307              
308             sub params {
309 8     8 0 11 my $self = shift;
310 8         23 return HTML::Mason::Utils::cgi_request_args($self->query,
311             $self->query->request_method);
312             }
313              
314             1;
315              
316             ###########################################################
317             package HTML::Mason::FakeTable;
318             $HTML::Mason::FakeTable::VERSION = '1.58';
319             # Analogous to Apache::Table.
320 2     2   12 use strict;
  2         4  
  2         34  
321 2     2   7 use warnings;
  2         3  
  2         539  
322              
323             sub new {
324 23     23   2573 my $class = shift;
325 23         35 my $self = {};
326 23         31 tie %{$self}, 'HTML::Mason::FakeTableHash';
  23         72  
327 23 100       70 %$self = @_ if @_;
328 23   33     146 return bless $self, ref $class || $class;
329             }
330              
331             sub set {
332 7     7   14 my ($self, $header, $value) = @_;
333 7 50       36 defined $value ? $self->{$header} = $value : delete $self->{$header};
334             }
335              
336             sub unset {
337 2     2   5 my $self = shift;
338 2         9 delete $self->{shift()};
339             }
340              
341             sub add {
342 3     3   7 tied(%{shift()})->add(@_);
  3         10  
343             }
344              
345             sub clear {
346 1     1   3 %{shift()} = ();
  1         4  
347             }
348              
349             sub get {
350 14     14   22 tied(%{shift()})->get(@_);
  14         38  
351             }
352              
353             sub merge {
354 1     1   4 my ($self, $key, $value) = @_;
355 1 50       5 if (defined $self->{$key}) {
356 1         5 $self->{$key} .= ',' . $value;
357             } else {
358 0         0 $self->{$key} = "$value";
359             }
360             }
361              
362             sub do {
363 2     2   6 my ($self, $code) = @_;
364 2         8 while (my ($k, $val) = each %$self) {
365 2 50       6 for my $v (ref $val ? @$val : $val) {
366 2 100       5 return unless $code->($k => $v);
367             }
368             }
369             }
370              
371             ###########################################################
372             package HTML::Mason::FakeTableHash;
373             $HTML::Mason::FakeTableHash::VERSION = '1.58';
374             # Used by HTML::Mason::FakeTable.
375 2     2   11 use strict;
  2         5  
  2         34  
376 2     2   8 use warnings;
  2         7  
  2         1081  
377              
378             sub TIEHASH {
379 23     23   37 my $class = shift;
380 23   33     91 return bless {}, ref $class || $class;
381             }
382              
383             sub _canonical_key {
384 196     196   287 my $key = lc shift;
385             # CGI really wants a - before each header
386 196 50       750 return substr( $key, 0, 1 ) eq '-' ? $key : "-$key";
387             }
388              
389             sub STORE {
390 108     108   180 my ($self, $key, $value) = @_;
391 108 100       233 $self->{_canonical_key $key} = [ $key => ref $value ? "$value" : $value ];
392             }
393              
394             sub add {
395 3     3   7 my ($self, $key) = (shift, shift);
396 3 50       8 return unless defined $_[0];
397 3 50       10 my $value = ref $_[0] ? "$_[0]" : $_[0];
398 3         6 my $ckey = _canonical_key $key;
399 3 100       9 if (exists $self->{$ckey}) {
400 2 50       7 if (ref $self->{$ckey}[1]) {
401 0         0 push @{$self->{$ckey}[1]}, $value;
  0         0  
402             } else {
403 2         11 $self->{$ckey}[1] = [ $self->{$ckey}[1], $value ];
404             }
405             } else {
406 1         7 $self->{$ckey} = [ $key => $value ];
407             }
408             }
409              
410             sub DELETE {
411 3     3   10 my ($self, $key) = @_;
412 3         7 my $ret = delete $self->{_canonical_key $key};
413 3         17 return $ret->[1];
414             }
415              
416             sub FETCH {
417 42     42   299 my ($self, $key) = @_;
418             # Grab the values first so that we don't autovivicate the key.
419 42 100       73 my $val = $self->{_canonical_key $key} or return;
420 39 100       98 if (my $ref = ref $val->[1]) {
421 2 50       9 return unless $val->[1][0];
422             # Return the first value only.
423 2         7 return $val->[1][0];
424             }
425 37         139 return $val->[1];
426             }
427              
428             sub get {
429 14     14   26 my ($self, $key) = @_;
430 14         24 my $ckey = _canonical_key $key;
431 14 100       37 return unless exists $self->{$ckey};
432 13 100       61 return $self->{$ckey}[1] unless ref $self->{$ckey}[1];
433 2 100       8 return wantarray ? @{$self->{$ckey}[1]} : $self->{$ckey}[1][0];
  1         11  
434             }
435              
436             sub CLEAR {
437 6     6   9 %{shift()} = ();
  6         21  
438             }
439              
440             sub EXISTS {
441 26     26   44 my ($self, $key)= @_;
442 26         71 return exists $self->{_canonical_key $key};
443             }
444              
445             sub FIRSTKEY {
446 5     5   31 my $self = shift;
447             # Reset perl's iterator.
448 5         12 keys %$self;
449             # Get the first key via perl's iterator.
450 5         7 my $first_key = each %$self;
451 5 100       18 return undef unless defined $first_key;
452 3         13 return $self->{$first_key}[0];
453             }
454              
455             sub NEXTKEY {
456 2     2   1051 my ($self, $nextkey) = @_;
457             # Get the next key via perl's iterator.
458 2         7 my $next_key = each %$self;
459 2 50       9 return undef unless defined $next_key;
460 0         0 return $self->{$next_key}[0];
461             }
462              
463             sub cgi_headers {
464 26     26   35 my $self = shift;
465 26         91 map { _map_header_key_to_cgi_key($_) => $self->{$_}[1] } keys %$self;
  9         16  
466             }
467              
468             sub _map_header_key_to_cgi_key {
469 9 100   9   42 return $_[0] eq '-set-cookie' ? '-cookies' : $_[0];
470             }
471              
472             1;
473              
474             __END__