[Catalyst-commits] r8064 - in trunk/Catalyst-Controller-WrapCGI: .
lib/Catalyst lib/Catalyst/Controller lib/CatalystX t t/lib
t/lib/TestCGIBin/Controller
caelum at dev.catalyst.perl.org
caelum at dev.catalyst.perl.org
Tue Jul 1 03:16:39 BST 2008
Author: caelum
Date: 2008-07-01 03:16:38 +0100 (Tue, 01 Jul 2008)
New Revision: 8064
Added:
trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/CGIBin.pm
trunk/Catalyst-Controller-WrapCGI/t/cgibin.t
trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin.pm
trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin/
Removed:
trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Plugin/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/
trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t
Modified:
trunk/Catalyst-Controller-WrapCGI/Changes
trunk/Catalyst-Controller-WrapCGI/MANIFEST
trunk/Catalyst-Controller-WrapCGI/META.yml
trunk/Catalyst-Controller-WrapCGI/README
trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm
trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm
trunk/Catalyst-Controller-WrapCGI/t/00-load.t
trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t
trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin/Controller/CGIHandler.pm
Log:
Converted C::P::CGIBin to C::C::CGIBin, added regex env key support
Modified: trunk/Catalyst-Controller-WrapCGI/Changes
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/Changes 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/Changes 2008-07-01 02:16:38 UTC (rev 8064)
@@ -2,3 +2,6 @@
0.001 2008-06-28 15:28:46
First complete dist.
+
+0.002 2008-06-30 16:00:44
+ Converted C::P::CGIBin to C::C::CGIBin
Modified: trunk/Catalyst-Controller-WrapCGI/MANIFEST
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/MANIFEST 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/MANIFEST 2008-07-01 02:16:38 UTC (rev 8064)
@@ -1,10 +1,32 @@
Changes
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/Catalyst/Controller/CGIBin.pm
+lib/Catalyst/Controller/WrapCGI.pm
+lib/CatalystX/GlobalContext.pm
+Makefile.PL
MANIFEST
-Makefile.PL
+META.yml
README
-lib/Catalyst/Controller/WrapCGI.pm
-lib/Catalyst/Plugin/CGIBin.pm
-lib/CatalystX/GlobalContext.pm
t/00-load.t
+t/boilerplate.t
+t/cgibin.t
+t/global-context.t
+t/lib/TestApp.pm
+t/lib/TestApp/Controller/Root.pm
+t/lib/TestCGIBin.pm
+t/lib/TestCGIBin/Controller/CGIHandler.pm
+t/lib/TestCGIBin/root/cgi-bin/test.pl
+t/lib/TestCGIBin/root/cgi-bin/test.sh
t/pod-coverage.t
t/pod.t
+t/wrap-cgi.t
Modified: trunk/Catalyst-Controller-WrapCGI/META.yml
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/META.yml 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/META.yml 2008-07-01 02:16:38 UTC (rev 8064)
@@ -22,4 +22,4 @@
Task::Weaken: 0
URI: 0
parent: 0
-version: 0.001
+version: 0.002
Modified: trunk/Catalyst-Controller-WrapCGI/README
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/README 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/README 2008-07-01 02:16:38 UTC (rev 8064)
@@ -16,7 +16,7 @@
After installing, you can find documentation for these modules with the
perldoc command.
- perldoc Catalyst::Plugin::CGIBin
+ perldoc Catalyst::Controller::CGIBin
perldoc Catalyst::Controller::WrapCGI
perldoc CatalystX::GlobalContext
Added: trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/CGIBin.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/CGIBin.pm (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/CGIBin.pm 2008-07-01 02:16:38 UTC (rev 8064)
@@ -0,0 +1,192 @@
+package Catalyst::Controller::CGIBin;
+
+use strict;
+use warnings;
+
+use Class::C3;
+use URI::Escape;
+use File::Slurp 'slurp';
+use File::Find::Rule ();
+use Cwd;
+use Catalyst::Exception ();
+use File::Spec::Functions 'splitdir';
+
+use parent 'Catalyst::Controller::WrapCGI';
+
+=head1 NAME
+
+Catalyst::Controller::CGIBin - Serve CGIs from root/cgi-bin
+
+=head1 VERSION
+
+Version 0.001
+
+=cut
+
+our $VERSION = '0.001';
+
+=head1 SYNOPSIS
+
+In your controller:
+
+ package MyApp::Controller::Foo;
+
+ use parent qw/Catalyst::Controller::CGIBin/;
+
+ # example of a forward to /cgi-bin/hlagh/mtfnpy.cgi
+ sub dongs : Local Args(0) {
+ my ($self, $c) = @_;
+ $c->forward($self->cgi_action('hlagh/mtfnpy.cgi'));
+ }
+
+In your .conf:
+
+ <Controller::Foo>
+ <CGI>
+ username_field username # used for REMOTE_USER env var
+ pass_env PERL5LIB
+ pass_env PATH
+ pass_env /^MYAPP_/
+ </CGI>
+ </Controller::Foo>
+
+=head1 DESCRIPTION
+
+Dispatches to executable CGI files in root/cgi-bin for /cgi-bin/ paths.
+
+A path such as C<root/cgi-bin/hlagh/bar.cgi> will get the private path
+C<foo/CGI_hlagh_bar_cgi>, for controller Foo, with the C</>s converted to C<_>s
+and prepended with C<CGI_>, as well as all non-word characters converted to
+C<_>s. This is because L<Catalyst> action names can't have non-word characters
+in them.
+
+Inherits from L<Catalyst::Controller::WrapCGI>, see the documentation for that
+module for configuration information.
+
+=cut
+
+sub register_actions {
+ my ($self, $c) = @_;
+
+ my $cwd = getcwd;
+
+ my $cgi_bin = $c->path_to('root', 'cgi-bin');
+
+ chdir $cgi_bin ||
+ Catalyst::Exception->throw(
+ message => 'You have no root/cgi-bin directory'
+ );
+
+ my $namespace = $self->action_namespace($c);
+
+ my $class = ref $self || $self;
+
+ for my $file (File::Find::Rule->executable->file->in(".")) {
+ my ($cgi, $type);
+ my $code = do { no warnings; eval 'sub { '.slurp($file).' }' };
+
+ if (!$@) {
+ $cgi = $code;
+ $type = 'Perl';
+ } else {
+ $cgi = sub { system "$cgi_bin/$file" };
+ $type = 'Non-Perl';
+ undef $@;
+ }
+
+ $c->log->info("Registering root/cgi_bin/$file as a $type CGI.")
+ if $c->debug;
+
+ my $action_name = $self->cgi_action($file);
+ my $path = join '/' => splitdir($file);
+ my $reverse = $namespace ? "$namespace/$action_name" : $action_name;
+ my $attrs = { Path => [ "cgi-bin/$path" ], Args => [ 0 ] };
+
+ $code = sub {
+ my ($controller, $context) = @_;
+ $controller->cgi_to_response($context, $cgi)
+ };
+
+ my $action = $self->create_action(
+ name => $action_name,
+ code => $code,
+ reverse => $reverse,
+ namespace => $namespace,
+ class => $class,
+ attributes => $attrs
+ );
+
+ $c->dispatcher->register($c, $action);
+ }
+
+ chdir $cwd;
+
+ $self->next::method($c, @_);
+}
+
+=head1 METHODS
+
+=head2 $self->cgi_action($cgi_path)
+
+Takes a path to a CGI from C<root/cgi-bin> such as C<foo/bar.cgi> and returns
+the action name it is registered as.
+
+=cut
+
+sub cgi_action {
+ my ($self, $cgi) = @_;
+
+ my $action_name = 'CGI_' . join '_' => splitdir($cgi);
+ $action_name =~ s/\W/_/g;
+
+ $action_name
+}
+
+=head1 AUTHOR
+
+Rafael Kitover, C<< <rkitover at cpan.org> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-catalyst-controller-wrapcgi at
+rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Catalyst-Controller-WrapCGI>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+More information at:
+
+=over 4
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Catalyst-Controller-WrapCGI>
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/Catalyst-Controller-WrapCGI>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/Catalyst-Controller-WrapCGI>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/Catalyst-Controller-WrapCGI>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright (c) 2008 Rafael Kitover
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of Catalyst::Controller::CGIBin
+
+# vim: expandtab shiftwidth=4 ts=4 tw=80:
Modified: trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm 2008-07-01 02:16:38 UTC (rev 8064)
@@ -7,6 +7,7 @@
use HTTP::Request::AsCGI;
use HTTP::Request;
use URI;
+use Catalyst::Exception ();
=head1 NAME
@@ -14,11 +15,11 @@
=head1 VERSION
-Version 0.001
+Version 0.002
=cut
-our $VERSION = '0.001';
+our $VERSION = '0.002';
=head1 SYNOPSIS
@@ -42,9 +43,10 @@
<Controller::Foo>
<CGI>
+ username_field username # used for REMOTE_USER env var
pass_env PERL5LIB
pass_env PATH
- pass_env HLAGH
+ pass_env /^MYAPP_/
</CGI>
</Controller::Foo>
@@ -53,6 +55,21 @@
Allows you to run Perl code in a CGI environment derived from your L<Catalyst>
context.
+If you just want to run CGIs from files, see L<Catalyst::Controller::CGIBin>.
+
+=head1 CONFIGURATION
+
+C<$your_controller->{CGI}{pass_env}> should be an array of environment variables
+or regular expressions to pass through to your CGIs. Entries surrounded by C</>
+characters are considered regular expressions.
+
+Default is to pass the whole of C<%ENV>.
+
+C<{CGI}{username_field}> should be the field for your user's name, which will be
+read from C<$c->user->obj>. Defaults to 'username'.
+
+See L</SYNOPSIS> for an example.
+
=cut
# Hack-around because Catalyst::Engine::HTTP goes and changes
@@ -101,7 +118,7 @@
Controller, see L</SYNOPSIS> for an example. If you don't supply a list of
environment variables to pass, the whole of %ENV is used.
-Used by cgi_to_response, which is probably what you want to use as well.
+Used by cgi_to_response (above), which is probably what you want to use as well.
=cut
@@ -127,16 +144,30 @@
}
}
- my @env = @{ $self->{CGI}{pass_env} || [ keys %ENV ] };
+ my @env;
+ for (@{ $self->{CGI}{pass_env} }) {
+ if (m!^/(.*)/\z!) {
+ my $re = qr/$1/;
+ push @env, grep /$re/, keys %ENV;
+ } else {
+ push @env, $_;
+ }
+ }
+
+ @env = keys %ENV unless @env;
+
$req->content($body_content);
$req->content_length(length($body_content));
- my $user = (($c->can('user_exists') && $c->user_exists)
- ? eval { $c->user->obj->username }
+
+ my $username_field = $self->{CGI}{username_field} || 'username';
+
+ my $username = (($c->can('user_exists') && $c->user_exists)
+ ? eval { $c->user->obj->$username_field }
: '');
my $env = HTTP::Request::AsCGI->new(
$req,
- REMOTE_USER => $user,
+ ($username ? (REMOTE_USER => $username) : ()),
map { ($_, $ENV{$_}) } @env
);
@@ -155,8 +186,9 @@
select($old);
- warn "CGI invoke failed: $saved_error" if $saved_error;
-
+ Catalyst::Exception->throw(
+ message => "CGI invocation failed: $saved_error"
+ ) if $saved_error;
}
return $env->response;
@@ -168,7 +200,7 @@
=head1 SEE ALSO
-L<Catalyst::Plugin::CGIBin>, L<CatalystX::GlobalContext>,
+L<Catalyst::Controller::CGIBin>, L<CatalystX::GlobalContext>,
L<Catalyst::Controller>, L<CGI>, L<Catalyst>
=head1 AUTHOR
@@ -218,4 +250,4 @@
1; # End of Catalyst::Controller::WrapCGI
-# vim: expandtab shiftwidth=4 ts=4 tw=80:
+# vim: expandtab shiftwidth=2 ts=2 tw=80:
Modified: trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm 2008-07-01 02:16:38 UTC (rev 8064)
@@ -43,16 +43,17 @@
=head1 DESCRIPTION
-This module, in combination with L<Catalyst::Controller::WrapCGI> is for helping
-you run legacy mod_perl code in L<Catalyst>.
+This module, in combination with L<Catalyst::Controller::WrapCGI> or
+L<Catalyst::Controller::CGIBin> is for helping you run legacy mod_perl code in
+L<Catalyst>.
You save a copy of $c somewhere at the beginning of the request cycle, and it is
then accessible through an export where you need it.
-You can then rip out Apache:: type things, and replace them with things based on
-$c.
+You can then rip out C<Apache::> type things, and replace them with things based on
+C<$c>.
-What we really need is a set of Apache:: compatibility classes, but that doesn't
+What we really need is a set of C<Apache::> compatibility classes, but that doesn't
exist yet.
DO NOT USE THIS MODULE IN NEW CODE
@@ -71,6 +72,11 @@
weaken $c;
}
+=head1 SEE ALSO
+
+L<Catalyst::Controller::CGIBin>, L<Catalyst::Controller::WrapCGI>,
+L<Catalyst>
+
=head1 AUTHOR
Rafael Kitover, C<< <rkitover at cpan.org> >>
Modified: trunk/Catalyst-Controller-WrapCGI/t/00-load.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/00-load.t 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/t/00-load.t 2008-07-01 02:16:38 UTC (rev 8064)
@@ -4,7 +4,7 @@
BEGIN {
use_ok( 'Catalyst::Controller::WrapCGI' );
- use_ok( 'Catalyst::Plugin::CGIBin' );
+ use_ok( 'Catalyst::Controller::CGIBin' );
use_ok( 'CatalystX::GlobalContext' );
}
Modified: trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t 2008-07-01 02:16:38 UTC (rev 8064)
@@ -49,7 +49,7 @@
);
module_boilerplate_ok('lib/Catalyst/Controller/WrapCGI.pm');
- module_boilerplate_ok('lib/Catalyst/Plugin/CGIBin.pm');
+ module_boilerplate_ok('lib/Catalyst/Controller/CGIBin.pm');
module_boilerplate_ok('lib/CatalystX/GlobalContext.pm');
Copied: trunk/Catalyst-Controller-WrapCGI/t/cgibin.t (from rev 8043, trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t)
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/cgibin.t (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/cgibin.t 2008-07-01 02:16:38 UTC (rev 8064)
@@ -0,0 +1,42 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin '$Bin';
+use lib "$Bin/lib";
+
+use Test::More tests => 4;
+
+use Catalyst::Test 'TestCGIBin';
+use HTTP::Request::Common;
+
+my $response = request POST '/cgi-bin/test.pl', [
+ foo => 'bar',
+ bar => 'baz'
+];
+
+is($response->content, 'foo:bar bar:baz', 'POST to Perl CGI File');
+
+$response = request POST '/cgihandler/dongs', [
+ foo => 'bar',
+ bar => 'baz'
+];
+
+is($response->content, 'foo:bar bar:baz',
+ 'POST to Perl CGI File through a forward');
+
+$response = request POST '/cgihandler/mtfnpy', [
+ foo => 'bar',
+ bar => 'baz'
+];
+
+is($response->content, 'foo:bar bar:baz',
+ 'POST to Perl CGI File through a forward via cgi_action');
+
+SKIP: {
+ skip "Can't run shell scripts on non-*nix", 1
+ if $^O eq 'MSWin32' || $^O eq 'VMS';
+
+ is(get('/cgi-bin/test.sh'), "Hello!\n", 'Non-Perl CGI File');
+}
Copied: trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin (from rev 8043, trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin)
Modified: trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin/Controller/CGIHandler.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/Controller/CGIHandler.pm 2008-06-28 22:29:41 UTC (rev 8043)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin/Controller/CGIHandler.pm 2008-07-01 02:16:38 UTC (rev 8064)
@@ -1,5 +1,17 @@
-package TestPlugin::Controller::CGIHandler;
+package TestCGIBin::Controller::CGIHandler;
-use parent 'Catalyst::Controller::WrapCGI';
+use parent 'Catalyst::Controller::CGIBin';
+# try out a forward
+sub dongs : Local Args(0) {
+ my ($self, $c) = @_;
+ $c->forward('/cgihandler/CGI_test_pl');
+}
+
+# try resolved forward
+sub mtfnpy : Local Args(0) {
+ my ($self, $c) = @_;
+ $c->forward($self->cgi_action('test.pl'));
+}
+
1;
Copied: trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin.pm (from rev 8043, trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm)
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin.pm (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestCGIBin.pm 2008-07-01 02:16:38 UTC (rev 8064)
@@ -0,0 +1,7 @@
+package TestCGIBin;
+
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
Deleted: trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm 2008-07-01 02:16:38 UTC (rev 8064)
@@ -1,11 +0,0 @@
-package TestPlugin;
-
-use Catalyst;
-
-__PACKAGE__->config->{'Plugin::CGIBin'} = {
- controller => 'CGIHandler'
-};
-
-__PACKAGE__->setup(qw/CGIBin/);
-
-1;
Deleted: trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t 2008-06-30 19:58:08 UTC (rev 8063)
+++ trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t 2008-07-01 02:16:38 UTC (rev 8064)
@@ -1,21 +0,0 @@
-#!perl
-
-use strict;
-use warnings;
-
-use FindBin '$Bin';
-use lib "$Bin/lib";
-
-use Test::More tests => 2;
-
-use Catalyst::Test 'TestPlugin';
-use HTTP::Request::Common;
-
-my $response = request POST '/cgi-bin/test.pl', [
- foo => 'bar',
- bar => 'baz'
-];
-
-is($response->content, 'foo:bar bar:baz', 'POST to Perl CGI File');
-
-is(get('/cgi-bin/test.sh'), "Hello!\n", 'Non-Perl CGI File');
More information about the Catalyst-commits
mailing list