allow MyApp->foo methods in CGIs, release
[catagits/Catalyst-Controller-WrapCGI.git] / lib / Catalyst / Controller / CGIBin.pm
CommitLineData
21a20b7e 1package Catalyst::Controller::CGIBin;
2
9cd47364 3use Moose;
1ce18a56 4use mro 'c3';
9cd47364 5
6extends 'Catalyst::Controller::WrapCGI';
7
21a20b7e 8use File::Slurp 'slurp';
9use File::Find::Rule ();
21a20b7e 10use Catalyst::Exception ();
c264816e 11use File::Spec::Functions qw/splitdir abs2rel/;
12use IPC::Open3;
13use Symbol 'gensym';
14use List::MoreUtils 'any';
15use IO::File ();
1ce18a56 16use Carp;
e889d526 17use File::Temp 'tempfile';
16db0bfc 18
2340af9d 19use namespace::clean -except => 'meta';
21a20b7e 20
21a20b7e 21=head1 NAME
22
23Catalyst::Controller::CGIBin - Serve CGIs from root/cgi-bin
24
25=head1 VERSION
26
e889d526 27Version 0.021
21a20b7e 28
29=cut
30
e889d526 31our $VERSION = '0.021';
21a20b7e 32
33=head1 SYNOPSIS
34
35In your controller:
36
37 package MyApp::Controller::Foo;
38
39 use parent qw/Catalyst::Controller::CGIBin/;
40
21a20b7e 41In your .conf:
42
43 <Controller::Foo>
9cd47364 44 cgi_root_path cgi-bin
f410f043 45 cgi_dir cgi-bin
21a20b7e 46 <CGI>
47 username_field username # used for REMOTE_USER env var
48 pass_env PERL5LIB
49 pass_env PATH
50 pass_env /^MYAPP_/
51 </CGI>
52 </Controller::Foo>
53
54=head1 DESCRIPTION
55
c264816e 56Dispatches to CGI files in root/cgi-bin for /cgi-bin/ paths.
57
58Unlike L<ModPerl::Registry> this module does _NOT_ stat and recompile the CGI
f410f043 59for every invocation. This may be supported in the future if there's interest.
21a20b7e 60
f410f043 61CGI paths are converted into action names using L</cgi_action>.
ee75330f 62
21a20b7e 63Inherits from L<Catalyst::Controller::WrapCGI>, see the documentation for that
f410f043 64module for other configuration information.
65
66=head1 CONFIG PARAMS
67
68=head2 cgi_root_path
69
184837e7 70The global URI path prefix for CGIs, defaults to C<cgi-bin>.
f410f043 71
72=head2 cgi_dir
73
74Path from which to read CGI files. Can be relative to C<$MYAPP_HOME/root> or
75absolute. Defaults to C<$MYAPP_HOME/root/cgi-bin>.
21a20b7e 76
77=cut
78
9cd47364 79has cgi_root_path => (is => 'ro', isa => 'Str', default => 'cgi-bin');
f410f043 80has cgi_dir => (is => 'ro', isa => 'Str', default => 'cgi-bin');
9cd47364 81
21a20b7e 82sub register_actions {
ee75330f 83 my ($self, $app) = @_;
21a20b7e 84
f410f043 85 my $cgi_bin = File::Spec->file_name_is_absolute($self->cgi_dir) ?
86 $self->cgi_dir
87 : $app->path_to('root', $self->cgi_dir);
21a20b7e 88
ee75330f 89 my $namespace = $self->action_namespace($app);
21a20b7e 90
91 my $class = ref $self || $self;
92
c264816e 93 for my $file (File::Find::Rule->file->in($cgi_bin)) {
94 my $cgi_path = abs2rel($file, $cgi_bin);
95
96 next if any { $_ eq '.svn' } splitdir $cgi_path;
f410f043 97 next if $cgi_path =~ /\.swp\z/;
c264816e 98
12d29ebf 99 my $path = join '/' => splitdir($cgi_path);
100 my $action_name = $self->cgi_action($path);
9cc2dd4c 101 my $public_path = $self->cgi_path($path);
12d29ebf 102 my $reverse = $namespace ? "$namespace/$action_name" : $action_name;
f410f043 103 my $attrs = { Path => [ $public_path ] };
12d29ebf 104
21a20b7e 105 my ($cgi, $type);
21a20b7e 106
c264816e 107 if ($self->is_perl_cgi($file)) { # syntax check passed
21a20b7e 108 $type = 'Perl';
12d29ebf 109 $cgi = $self->wrap_perl_cgi($file, $action_name);
21a20b7e 110 } else {
21a20b7e 111 $type = 'Non-Perl';
12d29ebf 112 $cgi = $self->wrap_nonperl_cgi($file, $action_name);
21a20b7e 113 }
114
c264816e 115 $app->log->info("Registering root/cgi-bin/$cgi_path as a $type CGI.")
ee75330f 116 if $app->debug;
21a20b7e 117
c264816e 118 my $code = sub {
21a20b7e 119 my ($controller, $context) = @_;
120 $controller->cgi_to_response($context, $cgi)
121 };
122
123 my $action = $self->create_action(
124 name => $action_name,
125 code => $code,
126 reverse => $reverse,
127 namespace => $namespace,
128 class => $class,
129 attributes => $attrs
130 );
131
ee75330f 132 $app->dispatcher->register($app, $action);
21a20b7e 133 }
134
ee75330f 135 $self->next::method($app, @_);
2340af9d 136
f410f043 137# Tell Static::Simple to ignore cgi_dir
138 if ($cgi_bin =~ /^@{[ $app->path_to('root') ]}/) {
139 my $rel = File::Spec->abs2rel($cgi_bin, $app->path_to('root'));
140
141 if (!any { $_ eq $rel }
142 @{ $app->config->{static}{ignore_dirs}||[] }) {
143 push @{ $app->config->{static}{ignore_dirs} }, $rel;
144 }
2340af9d 145 }
21a20b7e 146}
147
148=head1 METHODS
149
f410f043 150=head2 cgi_action
151
b9548267 152C<< $self->cgi_action($cgi) >>
21a20b7e 153
154Takes a path to a CGI from C<root/cgi-bin> such as C<foo/bar.cgi> and returns
c264816e 155the action name it is registered as. See L</DESCRIPTION> for a discussion on how
156CGI actions are named.
21a20b7e 157
fbaba9dd 158A path such as C<root/cgi-bin/hlagh/bar.cgi> will get the private path
159C<foo/CGI_hlagh__bar_cgi>, for controller Foo, with the C</>s converted to C<__>
160and prepended with C<CGI_>, as well as all non-word characters converted to
161C<_>s. This is because L<Catalyst> action names can't have non-word characters
162in them.
163
164This means that C<foo/bar.cgi> and C<foo__bar.cgi> for example will both map to
165the action C<CGI_foo__bar_cgi> so B<DON'T DO THAT>.
166
21a20b7e 167=cut
168
169sub cgi_action {
170 my ($self, $cgi) = @_;
171
fbaba9dd 172 my $action_name = 'CGI_' . join '__' => split '/' => $cgi;
21a20b7e 173 $action_name =~ s/\W/_/g;
174
175 $action_name
176}
177
f410f043 178=head2 cgi_path
179
b9548267 180C<< $self->cgi_path($cgi) >>
9cc2dd4c 181
182Takes a path to a CGI from C<root/cgi-bin> such as C<foo/bar.cgi> and returns
183the public path it should be registered under.
184
184837e7 185The default is to prefix with C<$cgi_root_path/>, using the C<cgi_root_path>
186config setting, above.
9cc2dd4c 187
188=cut
189
190sub cgi_path {
191 my ($self, $cgi) = @_;
9cd47364 192
193 my $root = $self->cgi_root_path;
194 $root =~ s{/*$}{};
195 return "$root/$cgi";
9cc2dd4c 196}
197
f410f043 198=head2 is_perl_cgi
199
b9548267 200C<< $self->is_perl_cgi($path) >>
c264816e 201
202Tries to figure out whether the CGI is Perl or not.
203
204If it's Perl, it will be inlined into a sub instead of being forked off, see
f410f043 205L</wrap_perl_cgi>.
c264816e 206
207=cut
208
209sub is_perl_cgi {
210 my ($self, $cgi) = @_;
211
e889d526 212 my (undef, $tempfile) = tempfile;
c264816e 213
e889d526 214 my $pid = fork;
215 die "Cannot fork: $!" unless defined $pid;
c264816e 216
e889d526 217 if ($pid) {
218 waitpid $pid, 0;
219 my $errors = IO::File->new($tempfile)->getline;
220 unlink $tempfile;
221 return $errors ? 0 : 1;
222 }
c264816e 223
e889d526 224 # child
225 local *NULL;
c264816e 226 open NULL, '>', File::Spec->devnull;
e889d526 227 open STDOUT, '>&', \*NULL;
228 open STDERR, '>&', \*NULL;
229 close STDIN;
c264816e 230
e889d526 231 do $cgi;
232 IO::File->new(">$tempfile")->print($@);
233 exit;
c264816e 234}
235
f410f043 236=head2 wrap_perl_cgi
237
b9548267 238C<< $self->wrap_perl_cgi($path, $action_name) >>
c264816e 239
240Takes the path to a Perl CGI and returns a coderef suitable for passing to
241cgi_to_response (from L<Catalyst::Controller::WrapCGI>.)
242
fbaba9dd 243C<$action_name> is the generated name for the action representing the CGI file
244from C<cgi_action>.
c264816e 245
246This is similar to how L<ModPerl::Registry> works, but will only work for
247well-written CGIs. Otherwise, you may have to override this method to do
248something more involved (see L<ModPerl::PerlRun>.)
249
f410f043 250Scripts with C<__DATA__> sections now work too, as well as scripts that call
251C<exit()>.
fbaba9dd 252
c264816e 253=cut
254
255sub wrap_perl_cgi {
12d29ebf 256 my ($self, $cgi, $action_name) = @_;
257
1ce18a56 258 my $code = slurp $cgi;
259
fbaba9dd 260 $code =~ s/^__DATA__(?:\r?\n|\r\n?)(.*)//ms;
1ce18a56 261 my $data = $1;
262
263 my $coderef = do {
12d29ebf 264 no warnings;
bdb35995 265 # catch exit() and turn it into (effectively) a return
266 # we *must* eval STRING because the code needs to be compiled with the
267 # overridden CORE::GLOBAL::exit in view
268 #
269 # set $0 to the name of the cgi file in case it's used there
12d29ebf 270 eval '
bdb35995 271 my $cgi_exited = "EXIT\n";
272 BEGIN { *CORE::GLOBAL::exit = sub (;$) {
273 die [ $cgi_exited, $_[0] || 0 ];
274 } }
12d29ebf 275 package Catalyst::Controller::CGIBin::_CGIs_::'.$action_name.';
1ce18a56 276 sub {'
277 . 'local *DATA;'
278 . q{open DATA, '<', \$data;}
bdb35995 279 . qq{local \$0 = "\Q$cgi\E";}
280 . q/my $rv = eval {/
1ce18a56 281 . $code
bdb35995 282 . q/};/
283 . q{
284 return $rv unless $@;
285 die $@ if $@ and not (
286 ref($@) eq 'ARRAY' and
287 $@->[0] eq $cgi_exited
288 );
289 die "exited nonzero: $@->[1]" if $@->[1] != 0;
290 return $rv;
291 }
1ce18a56 292 . '}';
293 };
294
295 croak __PACKAGE__ . ": Could not compile $cgi to coderef: $@" if $@;
296
297 $coderef
c264816e 298}
299
f410f043 300=head2 wrap_nonperl_cgi
301
b9548267 302C<< $self->wrap_nonperl_cgi($path, $action_name) >>
c264816e 303
304Takes the path to a non-Perl CGI and returns a coderef for executing it.
305
12d29ebf 306C<$action_name> is the generated name for the action representing the CGI file.
307
c264816e 308By default returns:
309
310 sub { system $path }
311
312=cut
313
314sub wrap_nonperl_cgi {
12d29ebf 315 my ($self, $cgi, $action_name) = @_;
c264816e 316
317 sub { system $cgi }
318}
319
f410f043 320__PACKAGE__->meta->make_immutable;
321
c264816e 322=head1 SEE ALSO
323
324L<Catalyst::Controller::WrapCGI>, L<CatalystX::GlobalContext>,
325L<Catalyst::Controller>, L<CGI>, L<Catalyst>
326
2e6f9c85 327=head1 AUTHOR
21a20b7e 328
329Rafael Kitover, C<< <rkitover at cpan.org> >>
330
2e6f9c85 331=head1 CONTRIBUTORS
332
0d83c5de 333Hans Dieter Pearcey, C<< <hdp at cpan.org> >>
334
21a20b7e 335=head1 BUGS
336
337Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi at
338rt.cpan.org>, or through the web interface at
339L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Controller-WrapCGI>.
340I will be notified, and then you'll automatically be notified of progress on
341your bug as I make changes.
342
343=head1 SUPPORT
344
345More information at:
346
347=over 4
348
349=item * RT: CPAN's request tracker
350
351L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Controller-WrapCGI>
352
353=item * AnnoCPAN: Annotated CPAN documentation
354
355L<http://annocpan.org/dist/Catalyst-Controller-WrapCGI>
356
357=item * CPAN Ratings
358
359L<http://cpanratings.perl.org/d/Catalyst-Controller-WrapCGI>
360
361=item * Search CPAN
362
363L<http://search.cpan.org/dist/Catalyst-Controller-WrapCGI>
364
365=back
366
367=head1 COPYRIGHT & LICENSE
368
369Copyright (c) 2008 Rafael Kitover
370
371This program is free software; you can redistribute it and/or modify it
372under the same terms as Perl itself.
373
374=cut
375
3761; # End of Catalyst::Controller::CGIBin
377
378# vim: expandtab shiftwidth=4 ts=4 tw=80: