File Coverage

blib/lib/Catalyst/Controller/CGIBin.pm
Criterion Covered Total %
statement 126 136 92.6
branch 28 44 63.6
condition 1 3 33.3
subroutine 24 25 96.0
pod 7 7 100.0
total 186 215 86.5


line stmt bran cond sub pod time code
1 16     16   51701946 use utf8;
  16         53  
  16         191  
2             package Catalyst::Controller::CGIBin;
3             our $AUTHORITY = 'cpan:RKITOVER';
4             $Catalyst::Controller::CGIBin::VERSION = '0.038';
5 16     16   1936 use Moose;
  16         54  
  16         190  
6 16     16   139322 use Moose::Util::TypeConstraints;
  16         44  
  16         190  
7 16     16   37101 use mro 'c3';
  16         33  
  16         154  
8              
9             extends 'Catalyst::Controller::WrapCGI';
10              
11 16     16   17826 use File::Find::Rule ();
  16         165751  
  16         586  
12 16     16   944 use File::Spec::Functions qw/splitdir abs2rel/;
  16         797  
  16         1289  
13 16     16   15625 use IPC::Open3;
  16         53773  
  16         995  
14 16     16   117 use Symbol 'gensym';
  16         43  
  16         727  
15 16     16   111 use List::MoreUtils 'any';
  16         36  
  16         249  
16 16     16   7878 use IO::File ();
  16         35  
  16         339  
17 16     16   83 use File::Temp 'tempfile';
  16         30  
  16         1295  
18 16     16   12804 use File::pushd;
  16         34400  
  16         1189  
19 16     16   13620 use CGI::Compile;
  16         35056  
  16         666  
20              
21 16     16   123 use namespace::clean -except => 'meta';
  16         25  
  16         218  
22              
23             =head1 NAME
24              
25             Catalyst::Controller::CGIBin - Serve CGIs from root/cgi-bin
26              
27             =head1 SYNOPSIS
28              
29             In your controller:
30              
31             package MyApp::Controller::Foo;
32              
33             use parent qw/Catalyst::Controller::CGIBin/;
34              
35             In your .conf:
36              
37             <Controller::Foo>
38             cgi_root_path cgi-bin
39             cgi_dir cgi-bin
40             cgi_chain_root /optional/private/path/to/Chained/root
41             cgi_file_pattern *.cgi
42             # or regex
43             cgi_file_pattern /\.pl\z/
44             <CGI>
45             username_field username # used for REMOTE_USER env var
46             pass_env PERL5LIB
47             pass_env PATH
48             pass_env /^MYAPP_/
49             </CGI>
50             </Controller::Foo>
51              
52             =head1 DESCRIPTION
53              
54             Dispatches to CGI files in root/cgi-bin for /cgi-bin/ paths.
55              
56             Unlike L<ModPerl::Registry> this module does _NOT_ stat and recompile the CGI
57             for every invocation. This may be supported in the future if there's interest.
58              
59             CGI paths are converted into action names using L</cgi_action>.
60              
61             Inherits from L<Catalyst::Controller::WrapCGI>, see the documentation for that
62             module for other configuration information.
63              
64             =head1 CONFIG PARAMS
65              
66             =head2 cgi_root_path
67              
68             The global URI path prefix for CGIs, defaults to C<cgi-bin>.
69              
70             =head2 cgi_chain_root
71              
72             By default L<Path|Catalyst::DispatchType::Path> actions are created for CGIs,
73             but if you specify this option, the actions will be created as
74             L<Chained|Catalyst::DispatchType::Chained> end-points, chaining off the
75             specified private path.
76              
77             If this option is used, the L</cgi_root_path> option is ignored. The root path
78             will be determined by your chain.
79              
80             The L<PathPart|Catalyst::DispatchType::Chained/PathPart> of the action will be
81             the path to the CGI file.
82              
83             =head2 cgi_dir
84              
85             Path from which to read CGI files. Can be relative to C<$MYAPP_HOME/root> or
86             absolute. Defaults to C<$MYAPP_HOME/root/cgi-bin>.
87              
88             =head2 cgi_file_pattern
89              
90             By default all files in L</cgi_dir> will be loaded as CGIs, however, with this
91             option you can specify either a glob or a regex to match the names of files you
92             want to be loaded.
93              
94             Can be an array of globs/regexes as well.
95              
96             =cut
97              
98             { my $stringified = subtype as 'Str';
99             coerce $stringified,
100             from 'Object',
101             via { "$_" };
102              
103             has cgi_root_path => (is => 'ro', coerce => 1, isa => $stringified, default => 'cgi-bin' );
104             has cgi_chain_root => (is => 'ro', isa => 'Str');
105             has cgi_dir => (is => 'ro', coerce => 1, isa => $stringified, default => 'cgi-bin');
106             has cgi_file_pattern => (is => 'rw', default => sub { ['*'] });
107              
108             }
109              
110             sub register_actions {
111 20     20 1 402715 my ($self, $app) = @_;
112              
113 20         58 my $cgi_bin;
114 20 100       948 if( File::Spec->file_name_is_absolute($self->cgi_dir) ) {
    100          
115 2         184 $cgi_bin = $self->cgi_dir;
116             } elsif( File::Spec->file_name_is_absolute( $app->config->{root} ) ) {
117 15         2318 $cgi_bin = File::Spec->catdir( $app->config->{root}, $self->cgi_dir );
118             } else {
119 3         279 $cgi_bin = $app->path_to( $app->config->{root}, $self->cgi_dir);
120             }
121              
122 20         1454 my $namespace = $self->action_namespace($app);
123              
124 20   33     6209 my $class = ref $self || $self;
125              
126 20         1039 my $patterns = $self->cgi_file_pattern;
127 20 50       104 $patterns = [ $patterns ] if not ref $patterns;
128 20         69 for my $pat (@$patterns) {
129 29 50       137 if ($pat =~ m{^/(.*)/\z}) {
130 0         0 $pat = qr/$1/;
131             }
132             }
133 20         871 $self->cgi_file_pattern($patterns);
134              
135 20         636 for my $file (File::Find::Rule->file->name(@$patterns)->in($cgi_bin)) {
136 55         68389 my $cgi_path = abs2rel($file, $cgi_bin);
137              
138 55 50   71   8509 next if any { $_ eq '.svn' } splitdir $cgi_path;
  71         871  
139 55 50       435 next if $cgi_path =~ /\.swp\z/;
140              
141 55         192 my $path = join '/' => splitdir($cgi_path);
142 55         763 my $action_name = $self->cgi_action($path);
143 55 50       303 my $reverse = $namespace ? "$namespace/$action_name" : $action_name;
144              
145 55         85 my $attrs = do {
146 55 100       3451 if (my $chain_root = $self->cgi_chain_root) {
147 2         14 { Chained => [ $chain_root ], PathPart => [ $path ], Args => [] };
148             }
149             else {
150 53         540 { Path => [ $self->cgi_path($path) ] };
151             }
152             };
153              
154 55         496 my ($cgi, $type);
155              
156 55 100       260 if ($self->is_perl_cgi($file)) { # syntax check passed
157 30         213 $type = 'Perl';
158 30         713 $cgi = $self->wrap_perl_cgi($file, $action_name);
159             } else {
160 13         175 $type = 'Non-Perl';
161 13         668 $cgi = $self->wrap_nonperl_cgi($file, $action_name);
162             }
163              
164 43 50       543715 $app->log->info("Registering root/cgi-bin/$cgi_path as a $type CGI.")
165             if $app->debug;
166              
167             my $code = sub {
168 16     16   1795121 my ($controller, $context) = @_;
169 16         166 $controller->cgi_to_response($context, $cgi)
170 43         721 };
171              
172 43         903 my $action = $self->create_action(
173             name => $action_name,
174             code => $code,
175             reverse => $reverse,
176             namespace => $namespace,
177             class => $class,
178             attributes => $attrs
179             );
180              
181 43         31670 $app->dispatcher->register($app, $action);
182             }
183              
184 8         77341 $self->next::method($app, @_);
185              
186             # Tell Static::Simple to ignore cgi_dir
187 8 100       235136 if ($cgi_bin =~ /^\Q@{[ $app->path_to('root') ]}\E/) {
  8         151  
188 6         2648 my $rel = File::Spec->abs2rel($cgi_bin, $app->path_to('root'));
189              
190 6 50   0   1864 if (!any { $_ eq $rel }
  0         0  
191 6 50       34 @{ $app->config->{'Plgin::Static::Simple'}{ignore_dirs}||[] }) {
192 6         578 push @{ $app->config->{'Plugin::Static::Simple'}{ignore_dirs} }, $rel;
  6         27  
193             }
194             }
195             }
196              
197             =head1 METHODS
198              
199             =head2 cgi_action
200              
201             C<< $self->cgi_action($cgi) >>
202              
203             Takes a path to a CGI from C<root/cgi-bin> such as C<foo/bar.cgi> and returns
204             the action name it is registered as.
205              
206             =cut
207              
208             sub cgi_action {
209 56     56 1 44122 my ($self, $cgi) = @_;
210              
211 56         169 my $action_name = 'CGI_' . $cgi;
212 56         464 $action_name =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
  73         783  
213              
214 56         229 return $action_name;
215             }
216              
217             =head2 cgi_path
218              
219             C<< $self->cgi_path($cgi) >>
220              
221             Takes a path to a CGI from C<root/cgi-bin> such as C<foo/bar.cgi> and returns
222             the public path it should be registered under.
223              
224             The default is to prefix with C<$cgi_root_path/>, using the C<cgi_root_path>
225             config setting, above.
226              
227             =cut
228              
229             sub cgi_path {
230 9     9 1 26 my ($self, $cgi) = @_;
231              
232 9         462 my $root = $self->cgi_root_path;
233 9         65 $root =~ s{/*$}{};
234 9         56 return "$root/$cgi";
235             }
236              
237             =head2 is_perl_cgi
238              
239             C<< $self->is_perl_cgi($path) >>
240              
241             Tries to figure out whether the CGI is Perl or not.
242              
243             If it's Perl, it will be inlined into a sub instead of being forked off, see
244             L</wrap_perl_cgi>.
245              
246             =cut
247              
248             sub is_perl_cgi {
249 55     55 1 124 my ($self, $cgi) = @_;
250              
251 55 50       335 if ($^O eq 'MSWin32') {
252             # the fork code fails on Win32
253 0         0 eval { $self->wrap_perl_cgi($cgi, '__DUMMY__') };
  0         0  
254 0 0       0 my $success = $@ ? 0 : 1;
255 0         0 require Class::Unload;
256 0         0 Class::Unload->unload($self->cgi_package('__DUMMY__'));
257 0         0 return $success;
258             }
259              
260 55         401 my (undef, $tempfile) = tempfile;
261              
262 55         206747 my $pid = fork;
263 55 50       2061 die "Cannot fork: $!" unless defined $pid;
264              
265 55 100       2369 if ($pid) {
266 43         176554715 waitpid $pid, 0;
267 43         2696 my $errors = IO::File->new($tempfile)->getline;
268 43         24362 unlink $tempfile;
269 43 100       779 return $errors ? 0 : 1;
270             }
271              
272             # child
273 12         1233 local *NULL;
274 12         5703 open NULL, '>', File::Spec->devnull;
275 12         1846 open STDOUT, '>&', \*NULL;
276 12         733 open STDERR, '>&', \*NULL;
277 12         293 close STDIN;
278              
279 12         537 eval { $self->wrap_perl_cgi($cgi, '__DUMMY__') };
  12         1093  
280              
281 12         2406166 IO::File->new(">$tempfile")->print($@);
282              
283 12         4572 exit;
284             }
285              
286             =head2 wrap_perl_cgi
287              
288             C<< $self->wrap_perl_cgi($path, $action_name) >>
289              
290             Takes the path to a Perl CGI and returns a coderef suitable for passing to
291             cgi_to_response (from L<Catalyst::Controller::WrapCGI>) using L<CGI::Compile>.
292              
293             C<$action_name> is the generated name for the action representing the CGI file
294             from C<cgi_action>.
295              
296             This is similar to how L<ModPerl::Registry> works, but will only work for
297             well-written CGIs. Otherwise, you may have to override this method to do
298             something more involved (see L<ModPerl::PerlRun>.)
299              
300             Scripts with C<__DATA__> sections now work too, as well as scripts that call
301             C<exit()>.
302              
303             =cut
304              
305             sub wrap_perl_cgi {
306 42     42 1 509 my ($self, $cgi, $action_name) = @_;
307              
308 42         625 return CGI::Compile->compile($cgi, $self->cgi_package($action_name));
309             }
310              
311             =head2 cgi_package
312              
313             C<< $self->cgi_package($action_name) >>
314              
315             Returns the package name a Perl CGI is compiled into for a given
316             C<$action_name>.
317              
318             =cut
319              
320             sub cgi_package {
321 42     42 1 122 my ($self, $action_name) = @_;
322              
323 42         2222 return "Catalyst::Controller::CGIBin::_CGIs_::$action_name";
324             }
325              
326             =head2 wrap_nonperl_cgi
327              
328             C<< $self->wrap_nonperl_cgi($path, $action_name) >>
329              
330             Takes the path to a non-Perl CGI and returns a coderef for executing it.
331              
332             C<$action_name> is the generated name for the action representing the CGI file.
333              
334             By default returns something like:
335              
336             sub { system $path }
337              
338             =cut
339              
340             sub wrap_nonperl_cgi {
341 13     13 1 67 my ($self, $cgi, $action_name) = @_;
342              
343             return sub {
344 2     2   18851 system $cgi;
345              
346 2 50       225 if ($? == -1) {
    50          
347 0         0 die "failed to execute CGI '$cgi': $!";
348             }
349             elsif ($? & 127) {
350 0 0       0 die sprintf "CGI '$cgi' died with signal %d, %s coredump",
351             ($? & 127), ($? & 128) ? 'with' : 'without';
352             }
353             else {
354 2         36 my $exit_code = $? >> 8;
355              
356 2 100       65 return 0 if $exit_code == 0;
357              
358 1         92 die "CGI '$cgi' exited non-zero with: $exit_code";
359             }
360 13         577 };
361             }
362              
363             __PACKAGE__->meta->make_immutable;
364              
365             =head1 SEE ALSO
366              
367             L<Catalyst::Controller::WrapCGI>, L<CatalystX::GlobalContext>,
368             L<Catalyst::Controller>, L<CGI>, L<CGI::Compile>, L<Catalyst>
369              
370             =head1 BUGS
371              
372             Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi at
373             rt.cpan.org>, or through the web interface at
374             L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Controller-WrapCGI>.
375             I will be notified, and then you'll automatically be notified of progress on
376             your bug as I make changes.
377              
378             =head1 AUTHOR
379              
380             Rafael Kitover <rkitover@gmail.com>
381              
382             =head1 COPYRIGHT & LICENSE
383              
384             Copyright (c) 2008-2015 Rafael Kitover <rkitover@gmail.com> and
385             L<Catalyst::Controller::WrapCGI/CONTRIBUTORS>.
386              
387             This program is free software; you can redistribute it and/or modify it
388             under the same terms as Perl itself.
389              
390             =cut
391              
392             __PACKAGE__; # End of Catalyst::Controller::CGIBin
393              
394             # vim:et sw=4 sts=4 tw=0: