release 0.032

[catagits/Catalyst-Controller-WrapCGI.git] / lib / Catalyst / Controller / CGIBin.pm

diff --git a/lib/Catalyst/Controller/CGIBin.pm b/lib/Catalyst/Controller/CGIBin.pm
index 52bb1a2..93f9e48 100644 (file)
--- a/lib/Catalyst/Controller/CGIBin.pm
+++ b/lib/Catalyst/Controller/CGIBin.pm
@@ -1,12 +1,12 @@
 package Catalyst::Controller::CGIBin;
 
 use Moose;
+use Moose::Util::TypeConstraints;
 use mro 'c3';
 
 extends 'Catalyst::Controller::WrapCGI';
 
 use File::Find::Rule ();
-use Catalyst::Exception ();
 use File::Spec::Functions qw/splitdir abs2rel/;
 use IPC::Open3;
 use Symbol 'gensym';
@@ -15,20 +15,16 @@ use IO::File ();
 use File::Temp 'tempfile';
 use File::pushd;
 use CGI::Compile;
- 
+
 use namespace::clean -except => 'meta';
 
 =head1 NAME
 
 Catalyst::Controller::CGIBin - Serve CGIs from root/cgi-bin
 
-=head1 VERSION
-
-Version 0.027
-
 =cut
 
-our $VERSION = '0.027';
+our $VERSION = '0.032';
 
 =head1 SYNOPSIS
 
@@ -41,9 +37,12 @@ In your controller:
 In your .conf:
 
     <Controller::Foo>
-        cgi_root_path  cgi-bin
-        cgi_dir        cgi-bin
-        cgi_chain_root /optional/private/path/to/Chained/root
+        cgi_root_path    cgi-bin
+        cgi_dir          cgi-bin
+        cgi_chain_root   /optional/private/path/to/Chained/root
+        cgi_file_pattern *.cgi
+        # or regex
+        cgi_file_pattern /\.pl\z/
         <CGI>
             username_field username # used for REMOTE_USER env var
             pass_env PERL5LIB
@@ -88,24 +87,54 @@ the path to the CGI file.
 Path from which to read CGI files. Can be relative to C<$MYAPP_HOME/root> or
 absolute.  Defaults to C<$MYAPP_HOME/root/cgi-bin>.
 
+=head2 cgi_file_pattern
+
+By default all files in L</cgi_dir> will be loaded as CGIs, however, with this
+option you can specify either a glob or a regex to match the names of files you
+want to be loaded.
+
+Can be an array of globs/regexes as well.
+
 =cut
 
-has cgi_root_path  => (is => 'ro', isa => 'Str', default => 'cgi-bin');
-has cgi_chain_root => (is => 'ro', isa => 'Str');
-has cgi_dir        => (is => 'ro', isa => 'Str', default => 'cgi-bin');
+{ my $stringified = subtype as 'Str';
+  coerce $stringified,
+      from 'Object',
+      via { "$_" };
+
+  has cgi_root_path    => (is => 'ro', coerce => 1, isa => $stringified, default => 'cgi-bin' );
+  has cgi_chain_root   => (is => 'ro', isa => 'Str');
+  has cgi_dir          => (is => 'ro', coerce => 1, isa => $stringified, default => 'cgi-bin');
+  has cgi_file_pattern => (is => 'rw', default => sub { ['*'] });
+
+}
 
 sub register_actions {
     my ($self, $app) = @_;
 
-    my $cgi_bin = File::Spec->file_name_is_absolute($self->cgi_dir) ?
-        $self->cgi_dir
-        : $app->path_to('root', $self->cgi_dir);
+    my $cgi_bin;
+    if( File::Spec->file_name_is_absolute($self->cgi_dir) ) {
+        $cgi_bin = $self->cgi_dir;
+    } elsif( File::Spec->file_name_is_absolute( $app->config->{root} ) ) {
+        $cgi_bin = File::Spec->catdir( $app->config->{root}, $self->cgi_dir );
+    } else {
+        $cgi_bin = $app->path_to( $app->config->{root}, $self->cgi_dir);
+    }
 
     my $namespace = $self->action_namespace($app);
 
     my $class = ref $self || $self;
 
-    for my $file (File::Find::Rule->file->in($cgi_bin)) {
+    my $patterns = $self->cgi_file_pattern;
+    $patterns = [ $patterns ] if not ref $patterns;
+    for my $pat (@$patterns) {
+        if ($pat =~ m{^/(.*)/\z}) {
+            $pat = qr/$1/;
+        }
+    }
+    $self->cgi_file_pattern($patterns);
+
+    for my $file (File::Find::Rule->file->name(@$patterns)->in($cgi_bin)) {
         my $cgi_path = abs2rel($file, $cgi_bin);
 
         next if any { $_ eq '.svn' } splitdir $cgi_path;
@@ -157,7 +186,7 @@ sub register_actions {
     $self->next::method($app, @_);
 
 # Tell Static::Simple to ignore cgi_dir
-    if ($cgi_bin =~ /^@{[ $app->path_to('root') ]}/) {
+    if ($cgi_bin =~ /^\Q@{[ $app->path_to('root') ]}\E/) {
         my $rel = File::Spec->abs2rel($cgi_bin, $app->path_to('root'));
 
         if (!any { $_ eq $rel }
@@ -221,6 +250,15 @@ L</wrap_perl_cgi>.
 sub is_perl_cgi {
     my ($self, $cgi) = @_;
 
+    if ($^O eq 'MSWin32') {
+        # the fork code fails on Win32
+        eval { $self->wrap_perl_cgi($cgi, '__DUMMY__') };
+        my $success = $@ ? 0 : 1;
+        require Class::Unload;
+        Class::Unload->unload($self->cgi_package('__DUMMY__'));
+        return $success;
+    }
+
     my (undef, $tempfile) = tempfile;
 
     my $pid = fork;
@@ -269,8 +307,22 @@ C<exit()>.
 sub wrap_perl_cgi {
     my ($self, $cgi, $action_name) = @_;
 
-    return CGI::Compile->compile($cgi,
-        "Catalyst::Controller::CGIBin::_CGIs_::$action_name");
+    return CGI::Compile->compile($cgi, $self->cgi_package($action_name));
+}
+
+=head2 cgi_package
+
+C<< $self->cgi_package($action_name) >>
+
+Returns the package name a Perl CGI is compiled into for a given
+C<$action_name>.
+
+=cut
+
+sub cgi_package {
+    my ($self, $action_name) = @_;
+
+    return "Catalyst::Controller::CGIBin::_CGIs_::$action_name";
 }
 
 =head2 wrap_nonperl_cgi
@@ -365,5 +417,4 @@ under the same terms as Perl itself.
 =cut
 
 1; # End of Catalyst::Controller::CGIBin
-
-# vim: expandtab shiftwidth=4 ts=4 tw=80:
+# vim:et sw=4 sts=4 tw=0: