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