allow overriding of public cgi-bin paths
[catagits/Catalyst-Controller-WrapCGI.git] / lib / Catalyst / Controller / CGIBin.pm
CommitLineData
21a20b7e 1package Catalyst::Controller::CGIBin;
2
3use strict;
4use warnings;
5
1ce18a56 6use MRO::Compat;
7use mro 'c3';
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;
2340af9d 17use namespace::clean -except => 'meta';
21a20b7e 18
19use parent 'Catalyst::Controller::WrapCGI';
20
21=head1 NAME
22
23Catalyst::Controller::CGIBin - Serve CGIs from root/cgi-bin
24
25=head1 VERSION
26
1ce18a56 27Version 0.006
21a20b7e 28
29=cut
30
1ce18a56 31our $VERSION = '0.006';
21a20b7e 32
33=head1 SYNOPSIS
34
35In your controller:
36
37 package MyApp::Controller::Foo;
38
39 use parent qw/Catalyst::Controller::CGIBin/;
40
41 # example of a forward to /cgi-bin/hlagh/mtfnpy.cgi
42 sub dongs : Local Args(0) {
43 my ($self, $c) = @_;
44 $c->forward($self->cgi_action('hlagh/mtfnpy.cgi'));
45 }
46
47In your .conf:
48
49 <Controller::Foo>
50 <CGI>
51 username_field username # used for REMOTE_USER env var
52 pass_env PERL5LIB
53 pass_env PATH
54 pass_env /^MYAPP_/
55 </CGI>
56 </Controller::Foo>
57
58=head1 DESCRIPTION
59
c264816e 60Dispatches to CGI files in root/cgi-bin for /cgi-bin/ paths.
61
62Unlike L<ModPerl::Registry> this module does _NOT_ stat and recompile the CGI
63for every invocation. If this is something you need, let me know.
21a20b7e 64
ee75330f 65CGI paths are converted into action names using cgi_action (below.)
66
21a20b7e 67A path such as C<root/cgi-bin/hlagh/bar.cgi> will get the private path
68C<foo/CGI_hlagh_bar_cgi>, for controller Foo, with the C</>s converted to C<_>s
69and prepended with C<CGI_>, as well as all non-word characters converted to
70C<_>s. This is because L<Catalyst> action names can't have non-word characters
71in them.
72
73Inherits from L<Catalyst::Controller::WrapCGI>, see the documentation for that
74module for configuration information.
75
76=cut
77
78sub register_actions {
ee75330f 79 my ($self, $app) = @_;
21a20b7e 80
ee75330f 81 my $cgi_bin = $app->path_to('root', 'cgi-bin');
21a20b7e 82
ee75330f 83 my $namespace = $self->action_namespace($app);
21a20b7e 84
85 my $class = ref $self || $self;
86
c264816e 87 for my $file (File::Find::Rule->file->in($cgi_bin)) {
88 my $cgi_path = abs2rel($file, $cgi_bin);
89
90 next if any { $_ eq '.svn' } splitdir $cgi_path;
91
12d29ebf 92 my $path = join '/' => splitdir($cgi_path);
93 my $action_name = $self->cgi_action($path);
9cc2dd4c 94 my $public_path = $self->cgi_path($path);
12d29ebf 95 my $reverse = $namespace ? "$namespace/$action_name" : $action_name;
9cc2dd4c 96 my $attrs = { Path => [ $public_path ], Args => [ 0 ] };
12d29ebf 97
21a20b7e 98 my ($cgi, $type);
21a20b7e 99
c264816e 100 if ($self->is_perl_cgi($file)) { # syntax check passed
21a20b7e 101 $type = 'Perl';
12d29ebf 102 $cgi = $self->wrap_perl_cgi($file, $action_name);
21a20b7e 103 } else {
21a20b7e 104 $type = 'Non-Perl';
12d29ebf 105 $cgi = $self->wrap_nonperl_cgi($file, $action_name);
21a20b7e 106 }
107
c264816e 108 $app->log->info("Registering root/cgi-bin/$cgi_path as a $type CGI.")
ee75330f 109 if $app->debug;
21a20b7e 110
c264816e 111 my $code = sub {
21a20b7e 112 my ($controller, $context) = @_;
113 $controller->cgi_to_response($context, $cgi)
114 };
115
116 my $action = $self->create_action(
117 name => $action_name,
118 code => $code,
119 reverse => $reverse,
120 namespace => $namespace,
121 class => $class,
122 attributes => $attrs
123 );
124
ee75330f 125 $app->dispatcher->register($app, $action);
21a20b7e 126 }
127
ee75330f 128 $self->next::method($app, @_);
2340af9d 129
130# Tell Static::Simple to ignore the cgi-bin dir.
131 if (!any{ $_ eq 'cgi-bin' } @{ $app->config->{static}{ignore_dirs}||[] }) {
132 push @{ $app->config->{static}{ignore_dirs} }, 'cgi-bin';
133 }
21a20b7e 134}
135
136=head1 METHODS
137
9cc2dd4c 138=head2 $self->cgi_action($cgi)
21a20b7e 139
140Takes a path to a CGI from C<root/cgi-bin> such as C<foo/bar.cgi> and returns
c264816e 141the action name it is registered as. See L</DESCRIPTION> for a discussion on how
142CGI actions are named.
21a20b7e 143
144=cut
145
146sub cgi_action {
147 my ($self, $cgi) = @_;
148
c264816e 149 my $action_name = 'CGI_' . join '_' => split '/' => $cgi;
21a20b7e 150 $action_name =~ s/\W/_/g;
151
152 $action_name
153}
154
9cc2dd4c 155=head2 $self->cgi_path($cgi)
156
157Takes a path to a CGI from C<root/cgi-bin> such as C<foo/bar.cgi> and returns
158the public path it should be registered under.
159
160The default is C<cgi-bin/$cgi>.
161
162=cut
163
164sub cgi_path {
165 my ($self, $cgi) = @_;
166 return "cgi-bin/$cgi";
167}
168
c264816e 169=head2 $self->is_perl_cgi($path)
170
171Tries to figure out whether the CGI is Perl or not.
172
173If it's Perl, it will be inlined into a sub instead of being forked off, see
174wrap_perl_cgi (below.)
175
176If it's not doing what you expect, you might want to override it, and let me
177know as well!
178
179=cut
180
181sub is_perl_cgi {
182 my ($self, $cgi) = @_;
183
184 my $shebang = IO::File->new($cgi)->getline;
185
2369e5a4 186 return 0 if $shebang !~ /perl/ && $cgi !~ /\.pl\z/;
c264816e 187
188 my $taint_check = $shebang =~ /-T/ ? '-T' : '';
189
190 open NULL, '>', File::Spec->devnull;
191 my $pid = open3(gensym, '&>NULL', '&>NULL', "$^X $taint_check -c $cgi");
192 close NULL;
193 waitpid $pid, 0;
194
195 $? >> 8 == 0
196}
197
12d29ebf 198=head2 $self->wrap_perl_cgi($path, $action_name)
c264816e 199
200Takes the path to a Perl CGI and returns a coderef suitable for passing to
201cgi_to_response (from L<Catalyst::Controller::WrapCGI>.)
202
12d29ebf 203C<$action_name> is the generated name for the action representing the CGI file.
c264816e 204
205This is similar to how L<ModPerl::Registry> works, but will only work for
206well-written CGIs. Otherwise, you may have to override this method to do
207something more involved (see L<ModPerl::PerlRun>.)
208
209=cut
210
211sub wrap_perl_cgi {
12d29ebf 212 my ($self, $cgi, $action_name) = @_;
213
1ce18a56 214 my $code = slurp $cgi;
215
216 $code =~ s/^__DATA__\r?\n(.*)//ms;
217 my $data = $1;
218
219 my $coderef = do {
12d29ebf 220 no warnings;
12d29ebf 221 eval '
222 package Catalyst::Controller::CGIBin::_CGIs_::'.$action_name.';
1ce18a56 223 sub {'
224 . 'local *DATA;'
225 . q{open DATA, '<', \$data;}
226 . $code
227 . '}';
228 };
229
230 croak __PACKAGE__ . ": Could not compile $cgi to coderef: $@" if $@;
231
232 $coderef
c264816e 233}
234
12d29ebf 235=head2 $self->wrap_nonperl_cgi($path, $action_name)
c264816e 236
237Takes the path to a non-Perl CGI and returns a coderef for executing it.
238
12d29ebf 239C<$action_name> is the generated name for the action representing the CGI file.
240
c264816e 241By default returns:
242
243 sub { system $path }
244
245=cut
246
247sub wrap_nonperl_cgi {
12d29ebf 248 my ($self, $cgi, $action_name) = @_;
c264816e 249
250 sub { system $cgi }
251}
252
253=head1 SEE ALSO
254
255L<Catalyst::Controller::WrapCGI>, L<CatalystX::GlobalContext>,
256L<Catalyst::Controller>, L<CGI>, L<Catalyst>
257
21a20b7e 258=head1 AUTHOR
259
260Rafael Kitover, C<< <rkitover at cpan.org> >>
261
262=head1 BUGS
263
264Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi at
265rt.cpan.org>, or through the web interface at
266L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Controller-WrapCGI>.
267I will be notified, and then you'll automatically be notified of progress on
268your bug as I make changes.
269
270=head1 SUPPORT
271
272More information at:
273
274=over 4
275
276=item * RT: CPAN's request tracker
277
278L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Controller-WrapCGI>
279
280=item * AnnoCPAN: Annotated CPAN documentation
281
282L<http://annocpan.org/dist/Catalyst-Controller-WrapCGI>
283
284=item * CPAN Ratings
285
286L<http://cpanratings.perl.org/d/Catalyst-Controller-WrapCGI>
287
288=item * Search CPAN
289
290L<http://search.cpan.org/dist/Catalyst-Controller-WrapCGI>
291
292=back
293
294=head1 COPYRIGHT & LICENSE
295
296Copyright (c) 2008 Rafael Kitover
297
298This program is free software; you can redistribute it and/or modify it
299under the same terms as Perl itself.
300
301=cut
302
3031; # End of Catalyst::Controller::CGIBin
304
305# vim: expandtab shiftwidth=4 ts=4 tw=80: