lib/Catalyst/Controller/CGIBin.pm

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