File Coverage

blib/lib/HTML/Mason/CGIHandler.pm
Criterion Covered Total %
statement 97 116 83.6
branch 16 34 47.0
condition 5 20 25.0
subroutine 24 27 88.8
pod 5 5 100.0
total 147 202 72.7


line stmt bran cond sub pod time code
1             package HTML::Mason::CGIHandler;
2             $HTML::Mason::CGIHandler::VERSION = '1.60';
3 2     2   101159 use strict;
  2         20  
  2         55  
4 2     2   20 use warnings;
  2         4  
  2         51  
5              
6 2     2   787 use HTML::Mason;
  2         19  
  2         247  
7 2     2   19 use HTML::Mason::Utils;
  2         6  
  2         230  
8 2     2   1243 use CGI 2.46;
  2         32879  
  2         329  
9 2     2   290 use File::Spec;
  2         16  
  2         73  
10 2     2   13 use Params::Validate qw(:all);
  2         4  
  2         790  
11 2     2   26 use HTML::Mason::Exceptions;
  2         5  
  2         59  
12 2     2   1708 use HTML::Mason::FakeApache;
  2         5  
  2         79  
13              
14 2     2   13 use Class::Container;
  2         3  
  2         48  
15 2     2   9 use base qw(Class::Container);
  2         3  
  2         389  
16              
17             use HTML::Mason::MethodMaker
18 2     2   14 ( read_write => [ qw( interp ) ] );
  2         3  
  2         9  
19              
20             __PACKAGE__->valid_params
21             (
22             interp => { isa => 'HTML::Mason::Interp' },
23             );
24              
25             __PACKAGE__->contained_objects
26             (
27             interp => 'HTML::Mason::Interp',
28             cgi_request => { class => 'HTML::Mason::FakeApache', # $r
29             delayed => 1 },
30             );
31              
32              
33             sub new {
34 7     7 1 17 my $package = shift;
35              
36 7         39 my %p = @_;
37             my $self = $package->SUPER::new(comp_root => $ENV{DOCUMENT_ROOT},
38 7         69 request_class => 'HTML::Mason::Request::CGI',
39             error_mode => 'output',
40             error_format => 'html',
41             %p);
42              
43 7 50       763 $self->{has_custom_out_method} = $p{out_method} ? 1 : 0;
44              
45 7         22 $self->interp->compiler->add_allowed_globals('$r');
46            
47 7         22 return $self;
48             }
49              
50             sub handle_request {
51 7     7 1 450 my $self = shift;
52 7         33 $self->_handler( { comp => $ENV{PATH_INFO} }, @_ );
53             }
54              
55             sub handle_comp {
56 0     0 1 0 my ($self, $comp) = (shift, shift);
57 0         0 $self->_handler( { comp => $comp }, @_ );
58             }
59              
60             sub handle_cgi_object {
61 0     0 1 0 my ($self, $cgi) = (shift, shift);
62 0         0 $self->_handler( { comp => $cgi->path_info,
63             cgi => $cgi },
64             @_);
65             }
66              
67             sub _handler {
68 7     7   19 my ($self, $p) = (shift, shift);
69              
70 7         43 my $r = $self->create_delayed_object('cgi_request', cgi => $p->{cgi});
71 7         32 $self->interp->set_global('$r', $r);
72              
73             # hack for testing
74 7 50       19 if (@_) {
    0          
75 7         25 $self->{output} = '';
76 7         18 $self->interp->out_method( \$self->{output} );
77             } elsif (! $self->{has_custom_out_method}) {
78 0         0 my $sent_headers = 0;
79              
80             my $out_method = sub {
81             # Send headers if they have not been sent by us or by user.
82             # We use instance here because if we store $request we get a
83             # circular reference and a big memory leak.
84 0 0 0 0   0 if (!$sent_headers and HTML::Mason::Request->instance->auto_send_headers) {
85 0         0 $r->send_http_header();
86 0         0 $sent_headers = 1;
87             }
88              
89             # We could perhaps install a new, faster out_method here that
90             # wouldn't have to keep checking whether headers have been
91             # sent and what the $r->method is. That would require
92             # additions to the Request interface, though.
93              
94 0         0 print STDOUT grep {defined} @_;
  0         0  
95 0         0 };
96              
97 0         0 $self->interp->out_method($out_method);
98             }
99              
100 7         21 $self->interp->delayed_object_params('request', cgi_request => $r);
101              
102 7         116 my %args = $self->request_args($r);
103              
104 7         11 my @result;
105 7 50       23 if (wantarray) {
    50          
106 0         0 @result = eval { $self->interp->exec($p->{comp}, %args) };
  0         0  
107             } elsif ( defined wantarray ) {
108 0         0 $result[0] = eval { $self->interp->exec($p->{comp}, %args) };
  0         0  
109             } else {
110 7         12 eval { $self->interp->exec($p->{comp}, %args) };
  7         17  
111             }
112              
113 7 100       101 if (my $err = $@) {
114 1 50       8 my $retval = isa_mason_exception($err, 'Abort') ? $err->aborted_value :
    50          
115             isa_mason_exception($err, 'Decline') ? $err->declined_value :
116             rethrow_exception $err;
117              
118             # Unlike under mod_perl, we cannot simply return a 301 or 302
119             # status and let Apache send headers, we need to explicitly
120             # send this header ourself.
121 0 0 0     0 $r->send_http_header if $retval && grep { $retval eq $_ } ( 200, 301, 302 );
  0         0  
122              
123 0         0 return $retval;
124             }
125              
126 6 50       20 if (@_) {
127             # This is a secret feature, and should stay secret (or go
128             # away) because it's just a hack for the test suite.
129 6         29 $_[0] .= $r->http_header . $self->{output};
130             }
131              
132 6 50       1182 return wantarray ? @result : defined wantarray ? $result[0] : undef;
    50          
133             }
134              
135             # This is broken out in order to make subclassing easier.
136             sub request_args {
137 7     7 1 15 my ($self, $r) = @_;
138              
139 7         29 return $r->params;
140             }
141              
142              
143             ###########################################################
144             package HTML::Mason::Request::CGI;
145             # Subclass for HTML::Mason::Request object $m
146             $HTML::Mason::Request::CGI::VERSION = '1.60';
147 2     2   46 use HTML::Mason::Exceptions;
  2         4  
  2         15  
148 2     2   17 use HTML::Mason::Request;
  2         8  
  2         94  
149 2     2   12 use base qw(HTML::Mason::Request);
  2         14  
  2         250  
150              
151 2     2   14 use Params::Validate qw(BOOLEAN);
  2         12  
  2         300  
152             Params::Validate::validation_options( on_fail => sub { param_error( join '', @_ ) } );
153              
154             __PACKAGE__->valid_params
155             ( cgi_request => { isa => 'HTML::Mason::FakeApache' },
156              
157             auto_send_headers => { parse => 'boolean', type => BOOLEAN, default => 1,
158             descr => "Whether HTTP headers should be auto-generated" },
159             );
160              
161             use HTML::Mason::MethodMaker
162 2         11 ( read_only => [ 'cgi_request' ],
163 2     2   15 read_write => [ 'auto_send_headers' ] );
  2         9  
164              
165             sub cgi_object {
166 1     1   3 my $self = shift;
167 1         21 return $self->{cgi_request}->query(@_);
168             }
169              
170             #
171             # Override this method to send HTTP headers if necessary.
172             #
173             sub exec
174             {
175 7     7   12 my $self = shift;
176 7         18 my $r = $self->cgi_request;
177 7         11 my $retval;
178              
179 7         11 eval { $retval = $self->SUPER::exec(@_) };
  7         46  
180              
181 7 100       59 if (my $err = $@)
182             {
183 1 50       8 $retval = isa_mason_exception($err, 'Abort') ? $err->aborted_value :
    50          
184             isa_mason_exception($err, 'Decline') ? $err->declined_value :
185             rethrow_exception $err;
186             }
187              
188             # On a success code, send headers if they have not been sent and
189             # if we are the top-level request. Since the out_method sends
190             # headers, this will typically only apply after $m->abort.
191 6 50 33     38 if (!$self->is_subrequest
      33        
      33        
      33        
192             and $self->auto_send_headers
193             and !$r->http_header_sent
194             and (!$retval or $retval==200)) {
195 6         24 $r->send_http_header();
196             }
197              
198 6         28 return $retval;
199             }
200              
201             sub redirect {
202 1     1   3 my $self = shift;
203 1         3 my $url = shift;
204 1   50     6 my $status = shift || 302;
205              
206 1         18 $self->clear_buffer;
207              
208 1         5 $self->{cgi_request}->header_out( Location => $url );
209 1         5 $self->{cgi_request}->header_out( Status => $status );
210              
211 1         8 $self->abort;
212             }
213              
214             1;
215             __END__