File Coverage

blib/lib/Catalyst/Controller/WrapCGI.pm
Criterion Covered Total %
statement 110 117 94.0
branch 26 34 76.4
condition 7 16 43.7
subroutine 14 14 100.0
pod 2 2 100.0
total 159 183 86.8


line stmt bran cond sub pod time code
1 18     18   2261724 use utf8;
  18         117  
  18         154  
2             package Catalyst::Controller::WrapCGI;
3             our $AUTHORITY = 'cpan:RKITOVER';
4             $Catalyst::Controller::WrapCGI::VERSION = '0.039';
5 18     18   1538 use 5.008_001;
  18         63  
6 18     18   1166 use Moose;
  18         958926  
  18         201  
7 18     18   129629 use mro 'c3';
  18         57  
  18         155  
8              
9             extends 'Catalyst::Controller';
10              
11 18     18   2423 use Catalyst::Exception ();
  18         189266  
  18         416  
12 18     18   11269 use HTTP::Request::AsCGI ();
  18         253238  
  18         512  
13 18     18   1059 use HTTP::Request ();
  18         2187  
  18         539  
14 18     18   143 use URI ();
  18         51  
  18         393  
15 18     18   118 use URI::Escape;
  18         47  
  18         1196  
16 18     18   2722 use HTTP::Request::Common;
  18         11814  
  18         1388  
17              
18 18     18   141 use namespace::clean -except => 'meta';
  18         57  
  18         183  
19              
20             =head1 NAME
21              
22             Catalyst::Controller::WrapCGI - Run CGIs in Catalyst
23              
24             =head1 SYNOPSIS
25              
26             package MyApp::Controller::Foo;
27              
28             use parent qw/Catalyst::Controller::WrapCGI/;
29             use CGI ();
30              
31             sub hello : Path('cgi-bin/hello.cgi') {
32             my ($self, $c) = @_;
33              
34             $self->cgi_to_response($c, sub {
35             my $q = CGI->new;
36             print $q->header, $q->start_html('Hello'),
37             $q->h1('Catalyst Rocks!'),
38             $q->end_html;
39             });
40             }
41              
42             In your .conf, configure which environment variables to pass:
43              
44             <Controller::Foo>
45             <CGI>
46             username_field username # used for REMOTE_USER env var
47             pass_env PERL5LIB
48             pass_env PATH
49             pass_env /^MYAPP_/
50             kill_env MYAPP_BAD
51             </CGI>
52             </Controller::Foo>
53              
54             =head1 DESCRIPTION
55              
56             Allows you to run Perl code in a CGI environment derived from your L<Catalyst>
57             context.
58              
59             B<*WARNING*>: do not export L<CGI> functions into a Controller, it will break
60             with L<Catalyst> 5.8 onward.
61              
62             If you just want to run CGIs from files, see L<Catalyst::Controller::CGIBin>.
63              
64             C<REMOTE_USER> will be set to C<< $c->user->obj->$username_field >> if
65             available, or to C<< $c->req->remote_user >> otherwise.
66              
67             =head1 CONFIGURATION
68              
69             =head2 pass_env
70              
71             C<< $your_controller->{CGI}{pass_env} >> should be an array of environment variables
72             or regular expressions to pass through to your CGIs. Entries surrounded by C</>
73             characters are considered regular expressions.
74              
75             =head2 kill_env
76              
77             C<< $your_controller->{CGI}{kill_env} >> should be an array of environment
78             variables or regular expressions to remove from the environment before passing
79             it to your CGIs. Entries surrounded by C</> characters are considered regular
80             expressions.
81              
82             Default is to pass the whole of C<%ENV>, except for entries listed in
83             L</FILTERED ENVIRONMENT> below.
84              
85             =head2 username_field
86              
87             C<< $your_controller->{CGI}{username_field} >> should be the field for your
88             user's name, which will be read from C<< $c->user->obj >>. Defaults to
89             'username'.
90              
91             See L</SYNOPSIS> for an example.
92              
93             =cut
94              
95             # Hack-around because Catalyst::Engine::HTTP goes and changes
96             # them to be the remote socket, and FCGI.pm does even dumber things.
97              
98             open my $REAL_STDIN, "<&=".fileno(*STDIN);
99             open my $REAL_STDOUT, ">>&=".fileno(*STDOUT);
100              
101             =head1 METHODS
102              
103             =head2 cgi_to_response
104              
105             C<< $self->cgi_to_response($c, $coderef) >>
106              
107             Does the magic of running $coderef in a CGI environment, and populating the
108             appropriate parts of your Catalyst context with the results.
109              
110             Calls L</wrap_cgi>.
111              
112             =cut
113              
114             sub cgi_to_response {
115 25     25 1 205793 my ($self, $c, $script) = @_;
116              
117 25         109 my $res = $self->wrap_cgi($c, $script);
118              
119             # if the CGI doesn't set the response code but sets location they were
120             # probably trying to redirect so set 302 for them
121              
122 23         41790 my $location = $res->headers->header('Location');
123              
124 23 50 33     1093 if (defined $location && length $location && $res->code == 200) {
      33        
125 0         0 $c->res->status(302);
126             } else {
127 23         116 $c->res->status($res->code);
128             }
129 23         3973 $c->res->body($res->content);
130 23         1799 $c->res->headers($res->headers);
131             }
132              
133             =head2 wrap_cgi
134              
135             C<< $self->wrap_cgi($c, $coderef) >>
136              
137             Runs C<$coderef> in a CGI environment using L<HTTP::Request::AsCGI>, returns an
138             L<HTTP::Response>.
139              
140             The CGI environment is set up based on C<$c>.
141              
142             The environment variables to pass on are taken from the configuration for your
143             Controller, see L</SYNOPSIS> for an example. If you don't supply a list of
144             environment variables to pass, the whole of %ENV is used (with exceptions listed
145             in L</FILTERED ENVIRONMENT>.
146              
147             Used by L</cgi_to_response>, which is probably what you want to use as well.
148              
149             =cut
150              
151             sub wrap_cgi {
152 25     25 1 72 my ($self, $c, $call) = @_;
153             my $req = HTTP::Request->new(
154 25         66 map { $c->req->$_ } qw/method uri headers/
  75         2908  
155             );
156 25         4180 my $body = $c->req->body;
157 25         3376 my $body_content = '';
158              
159 25         85 $req->content_type($c->req->content_type); # set this now so we can override
160              
161 25 100       3102 if ($body) { # Slurp from body filehandle
162 2         33 seek $body, 0, 0;
163 2         11 local $/; $body_content = <$body>;
  2         44  
164 2         30 seek $body, 0, 0; # reset for anyone else down the chain
165             } else {
166 23   50     95 my $body_params = $c->req->body_parameters || {};
167              
168 23 100       1526 if (my %uploads = %{ $c->req->uploads }) {
  23 100       76  
169             my $post = POST 'http://localhost/',
170             Content_Type => 'form-data',
171             Content => [
172             %$body_params,
173             map {
174 1         64 my $upl = $uploads{$_};
  2         4  
175             $_ => [
176             undef,
177             $upl->filename,
178             Content => $upl->slurp,
179             map {
180 2         60 my $header = $_;
  4         754  
181 4         110 map { $header => $_ } $upl->headers->header($header)
  4         174  
182             } $upl->headers->header_field_names
183             ]
184             } keys %uploads
185             ];
186 1         1168 $body_content = $post->content;
187 1         16 $req->content_type($post->header('Content-Type'));
188             } elsif (%$body_params) {
189 10         754 my $encoder = URI->new;
190 10         515 $encoder->query_form(%$body_params);
191 10         913 $body_content = $encoder->query;
192 10         122 $req->content_type('application/x-www-form-urlencoded');
193             }
194             }
195              
196 25         1167 $req->content($body_content);
197 25         633 $req->content_length(length($body_content));
198              
199 25   50     1274 my $username_field = $self->{CGI}{username_field} || 'username';
200              
201             my $username = (($c->can('user_exists') && $c->user_exists)
202 25 50 33     229 ? eval { $c->user->obj->$username_field }
  0         0  
203             : '');
204              
205 25 50 66     99 $username ||= $c->req->remote_user if $c->req->can('remote_user');
206              
207             my $path_info = '/'.join '/' => map {
208 10 50       422 utf8::is_utf8($_) ? uri_escape_utf8($_) : uri_escape($_)
209 25         2633 } @{ $c->req->args };
  25         70  
210              
211 25 100       1860 my $env = HTTP::Request::AsCGI->new(
212             $req,
213             ($username ? (REMOTE_USER => $username) : ()),
214             PATH_INFO => $path_info,
215             # eww, this is likely broken:
216             FILEPATH_INFO => '/'.$c->action.$path_info,
217             SCRIPT_NAME => $c->uri_for($c->action, $c->req->captures)->path
218             );
219              
220             {
221 25         59515 local *STDIN = $REAL_STDIN; # restore the real ones so the filenos
  25         151  
222 25         74 local *STDOUT = $REAL_STDOUT; # are 0 and 1 for the env setup
223              
224 25         82 my $old = select($REAL_STDOUT); # in case somebody just calls 'print'
225              
226 25         46 my $saved_error;
227              
228 25         56 local %ENV = %{ $self->_filtered_env(\%ENV) };
  25         174  
229              
230 25         293 $env->setup;
231 25         16884 eval { $call->() };
  25         125  
232 25         27520 $saved_error = $@;
233 25         175 $env->restore;
234              
235 25         7093 select($old);
236              
237 25 100       720 if( $saved_error ) {
238 2 50       12 die $saved_error if ref $saved_error;
239 2         66 Catalyst::Exception->throw(
240             message => "CGI invocation failed: $saved_error"
241             );
242             }
243             }
244              
245 23         138 return $env->response;
246             }
247              
248             =head1 FILTERED ENVIRONMENT
249              
250             If you don't use the L</pass_env> option to restrict which environment variables
251             are passed in, the default is to pass the whole of C<%ENV> except the variables
252             listed below.
253              
254             MOD_PERL
255             SERVER_SOFTWARE
256             SERVER_NAME
257             GATEWAY_INTERFACE
258             SERVER_PROTOCOL
259             SERVER_PORT
260             REQUEST_METHOD
261             PATH_INFO
262             PATH_TRANSLATED
263             SCRIPT_NAME
264             QUERY_STRING
265             REMOTE_HOST
266             REMOTE_ADDR
267             AUTH_TYPE
268             REMOTE_USER
269             REMOTE_IDENT
270             CONTENT_TYPE
271             CONTENT_LENGTH
272             HTTP_ACCEPT
273             HTTP_USER_AGENT
274              
275             C<%ENV> can be further trimmed using L</kill_env>.
276              
277             =cut
278              
279             my $DEFAULT_KILL_ENV = [qw/
280             MOD_PERL SERVER_SOFTWARE SERVER_NAME GATEWAY_INTERFACE SERVER_PROTOCOL
281             SERVER_PORT REQUEST_METHOD PATH_INFO PATH_TRANSLATED SCRIPT_NAME QUERY_STRING
282             REMOTE_HOST REMOTE_ADDR AUTH_TYPE REMOTE_USER REMOTE_IDENT CONTENT_TYPE
283             CONTENT_LENGTH HTTP_ACCEPT HTTP_USER_AGENT
284             /];
285              
286             sub _filtered_env {
287 28     28   1915 my ($self, $env) = @_;
288 28         54 my @ok;
289              
290 28         74 my $pass_env = $self->{CGI}{pass_env};
291 28 100       112 $pass_env = [] if not defined $pass_env;
292 28 100       109 $pass_env = [ $pass_env ] unless ref $pass_env;
293              
294 28         59 my $kill_env = $self->{CGI}{kill_env};
295 28 100       90 $kill_env = $DEFAULT_KILL_ENV unless defined $kill_env;
296 28 50       103 $kill_env = [ $kill_env ] unless ref $kill_env;
297              
298 28 100       80 if (@$pass_env) {
299 1         4 for (@$pass_env) {
300 1 50       4 if (m!^/(.*)/\z!) {
301 0         0 my $re = qr/$1/;
302 0         0 push @ok, grep /$re/, keys %$env;
303             } else {
304 1         4 push @ok, $_;
305             }
306             }
307             } else {
308 27         294 @ok = keys %$env;
309             }
310              
311 28         106 for my $k (@$kill_env) {
312 540 50       1134 if ($k =~ m!^/(.*)/\z!) {
313 0         0 my $re = qr/$1/;
314 0         0 @ok = grep { ! /$re/ } @ok;
  0         0  
315             } else {
316 540         856 @ok = grep { $_ ne $k } @ok;
  17709         29804  
317             }
318             }
319 28         78 return { map {; $_ => $env->{$_} } @ok };
  919         3789  
320             }
321              
322             __PACKAGE__->meta->make_immutable;
323              
324             =head1 DIRECT SOCKET/NPH SCRIPTS
325              
326             This currently won't work:
327              
328             #!/usr/bin/perl
329              
330             use CGI ':standard';
331              
332             $| = 1;
333              
334             print header;
335              
336             for (0..1000) {
337             print $_, br, "\n";
338             sleep 1;
339             }
340              
341             because the coderef is executed synchronously with C<STDOUT> pointing to a temp
342             file.
343              
344             =head1 ACKNOWLEDGEMENTS
345              
346             Original development sponsored by L<http://www.altinity.com/>
347              
348             =head1 SEE ALSO
349              
350             L<Catalyst::Controller::CGIBin>, L<CatalystX::GlobalContext>,
351             L<Catalyst::Controller>, L<CGI>, L<Catalyst>
352              
353             =head1 BUGS
354              
355             Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi
356             at rt.cpan.org>, or through the web interface at
357             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Controller-WrapCGI>.
358             I will be notified, and then you'll automatically be notified of progress on
359             your bug as I make changes.
360              
361             =head1 AUTHOR
362              
363             Matt S. Trout C<< <mst at shadowcat.co.uk> >>
364              
365             =head1 CONTRIBUTORS
366              
367             Caelum: Rafael Kitover <rkitover@cpan.org>
368              
369             confound: Hans Dieter Pearcey <hdp@cpan.org>
370              
371             rbuels: Robert Buels <rbuels@gmail.com>
372              
373             Some code stolen from Tatsuhiko Miyagawa's L<CGI::Compile>.
374              
375             =head1 COPYRIGHT & LICENSE
376              
377             Copyright (c) 2008-2015 L<Catalyst::Controller::WrapCGI/AUTHOR> and
378             L<Catalyst::Controller::WrapCGI/CONTRIBUTORS>.
379              
380             This program is free software; you can redistribute it and/or modify it
381             under the same terms as Perl itself.
382              
383             =cut
384              
385             __PACKAGE__; # End of Catalyst::Controller::WrapCGI
386              
387             # vim: expandtab shiftwidth=2 ts=2 tw=80: