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   32949248 use utf8;
  16         41  
  16         134  
2             package Catalyst::Controller::CGIBin;
3             our $AUTHORITY = 'cpan:RKITOVER';
4             $Catalyst::Controller::CGIBin::VERSION = '0.037';
5 16     16   1109 use Moose;
  16         50  
  16         114  
6 16     16   103958 use Moose::Util::TypeConstraints;
  16         32  
  16         139  
7 16     16   32913 use mro 'c3';
  16         42  
  16         128  
8              
9             extends 'Catalyst::Controller::WrapCGI';
10              
11 16     16   14632 use File::Find::Rule ();
  16         132597  
  16         447  
12 16     16   860 use File::Spec::Functions qw/splitdir abs2rel/;
  16         823  
  16         973  
13 16     16   12931 use IPC::Open3;
  16         44958  
  16         856  
14 16     16   109 use Symbol 'gensym';
  16         42  
  16         702  
15 16     16   94 use List::MoreUtils 'any';
  16         21  
  16         206  
16 16     16   12118 use IO::File ();
  16         32  
  16         308  
17 16     16   82 use File::Temp 'tempfile';
  16         32  
  16         1143  
18 16     16   11227 use File::pushd;
  16         28255  
  16         928  
19 16     16   11488 use CGI::Compile;
  16         29931  
  16         580  
20              
21 16     16   106 use namespace::clean -except => 'meta';
  16         36  
  16         185  
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 379378 my ($self, $app) = @_;
112              
113 20         54 my $cgi_bin;
114 20 100       909 if( File::Spec->file_name_is_absolute($self->cgi_dir) ) {
    100          
115 2         80 $cgi_bin = $self->cgi_dir;
116             } elsif( File::Spec->file_name_is_absolute( $app->config->{root} ) ) {
117 15         2011 $cgi_bin = File::Spec->catdir( $app->config->{root}, $self->cgi_dir );
118             } else {
119 3         312 $cgi_bin = $app->path_to( $app->config->{root}, $self->cgi_dir);
120             }
121              
122 20         1308 my $namespace = $self->action_namespace($app);
123              
124 20   33     5762 my $class = ref $self || $self;
125              
126 20         979 my $patterns = $self->cgi_file_pattern;
127 20 50       83 $patterns = [ $patterns ] if not ref $patterns;
128 20         60 for my $pat (@$patterns) {
129 29 50       131 if ($pat =~ m{^/(.*)/\z}) {
130 0         0 $pat = qr/$1/;
131             }
132             }
133 20         842 $self->cgi_file_pattern($patterns);
134              
135 20         654 for my $file (File::Find::Rule->file->name(@$patterns)->in($cgi_bin)) {
136 55         68680 my $cgi_path = abs2rel($file, $cgi_bin);
137              
138 55 50   71   8993 next if any { $_ eq '.svn' } splitdir $cgi_path;
  71         875  
139 55 50       534 next if $cgi_path =~ /\.swp\z/;
140              
141 55         229 my $path = join '/' => splitdir($cgi_path);
142 55         740 my $action_name = $self->cgi_action($path);
143 55 50       290 my $reverse = $namespace ? "$namespace/$action_name" : $action_name;
144              
145 55         91 my $attrs = do {
146 55 100       3341 if (my $chain_root = $self->cgi_chain_root) {
147 2         14 { Chained => [ $chain_root ], PathPart => [ $path ], Args => [] };
148             }
149             else {
150 53         574 { Path => [ $self->cgi_path($path) ] };
151             }
152             };
153              
154 55         618 my ($cgi, $type);
155              
156 55 100       305 if ($self->is_perl_cgi($file)) { # syntax check passed
157 30         228 $type = 'Perl';
158 30         686 $cgi = $self->wrap_perl_cgi($file, $action_name);
159             } else {
160 13         177 $type = 'Non-Perl';
161 13         661 $cgi = $self->wrap_nonperl_cgi($file, $action_name);
162             }
163              
164 43 50       531158 $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   1422247 my ($controller, $context) = @_;
169 16         149 $controller->cgi_to_response($context, $cgi)
170 43         738 };
171              
172 43         928 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         35071 $app->dispatcher->register($app, $action);
182             }
183              
184 8         71143 $self->next::method($app, @_);
185              
186             # Tell Static::Simple to ignore cgi_dir
187 8 100       225890 if ($cgi_bin =~ /^\Q@{[ $app->path_to('root') ]}\E/) {
  8         167  
188 6         2389 my $rel = File::Spec->abs2rel($cgi_bin, $app->path_to('root'));
189              
190 6 50   0   1907 if (!any { $_ eq $rel }
  0         0  
191 6 50       32 @{ $app->config->{'Plgin::Static::Simple'}{ignore_dirs}||[] }) {
192 6         524 push @{ $app->config->{'Plugin::Static::Simple'}{ignore_dirs} }, $rel;
  6         25  
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 41555 my ($self, $cgi) = @_;
210              
211 56         186 my $action_name = 'CGI_' . $cgi;
212 56         449 $action_name =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;
  73         763  
213              
214 56         211 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 22 my ($self, $cgi) = @_;
231              
232 9         456 my $root = $self->cgi_root_path;
233 9         45 $root =~ s{/*$}{};
234 9         50 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 184 my ($self, $cgi) = @_;
250              
251 55 50       339 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         449 my (undef, $tempfile) = tempfile;
261              
262 55         186570 my $pid = fork;
263 55 50       2266 die "Cannot fork: $!" unless defined $pid;
264              
265 55 100       2229 if ($pid) {
266 43         58644509 waitpid $pid, 0;
267 43         3008 my $errors = IO::File->new($tempfile)->getline;
268 43         26542 unlink $tempfile;
269 43 100       796 return $errors ? 0 : 1;
270             }
271              
272             # child
273 12         1623 local *NULL;
274 12         6421 open NULL, '>', File::Spec->devnull;
275 12         2040 open STDOUT, '>&', \*NULL;
276 12         990 open STDERR, '>&', \*NULL;
277 12         210 close STDIN;
278              
279 12         563 eval { $self->wrap_perl_cgi($cgi, '__DUMMY__') };
  12         1267  
280              
281 12         223071 IO::File->new(">$tempfile")->print($@);
282              
283 12         4028 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 583 my ($self, $cgi, $action_name) = @_;
307              
308 42         734 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 189 my ($self, $action_name) = @_;
322              
323 42         2447 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 143 my ($self, $cgi, $action_name) = @_;
342              
343             return sub {
344 2     2   18219 system $cgi;
345              
346 2 50       115 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         25 my $exit_code = $? >> 8;
355              
356 2 100       49 return 0 if $exit_code == 0;
357              
358 1         89 die "CGI '$cgi' exited non-zero with: $exit_code";
359             }
360 13         504 };
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: