[Catalyst-commits] r8043 - in trunk/Catalyst-Controller-WrapCGI: .
lib/Catalyst/Controller lib/Catalyst/Plugin lib/CatalystX t
t/lib t/lib/TestApp t/lib/TestApp/Controller t/lib/TestPlugin
t/lib/TestPlugin/Controller t/lib/TestPlugin/root
t/lib/TestPlugin/root/cgi-bin
caelum at dev.catalyst.perl.org
caelum at dev.catalyst.perl.org
Sat Jun 28 23:29:41 BST 2008
Author: caelum
Date: 2008-06-28 23:29:41 +0100 (Sat, 28 Jun 2008)
New Revision: 8043
Added:
trunk/Catalyst-Controller-WrapCGI/t/
trunk/Catalyst-Controller-WrapCGI/t/00-load.t
trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t
trunk/Catalyst-Controller-WrapCGI/t/global-context.t
trunk/Catalyst-Controller-WrapCGI/t/lib/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp.pm
trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp/Controller/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp/Controller/Root.pm
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/Controller/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/Controller/CGIHandler.pm
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.pl
trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.sh
trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t
trunk/Catalyst-Controller-WrapCGI/t/pod.t
trunk/Catalyst-Controller-WrapCGI/t/wrap-cgi.t
Modified:
trunk/Catalyst-Controller-WrapCGI/Changes
trunk/Catalyst-Controller-WrapCGI/META.yml
trunk/Catalyst-Controller-WrapCGI/Makefile.PL
trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm
trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Plugin/CGIBin.pm
trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm
Log:
Finished first version of WrapCGI dist
Modified: trunk/Catalyst-Controller-WrapCGI/Changes
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/Changes 2008-06-28 14:47:11 UTC (rev 8042)
+++ trunk/Catalyst-Controller-WrapCGI/Changes 2008-06-28 22:29:41 UTC (rev 8043)
@@ -1,2 +1,4 @@
Revision history for Catalyst-Controller-WrapCGI
+0.001 2008-06-28 15:28:46
+ First complete dist.
Modified: trunk/Catalyst-Controller-WrapCGI/META.yml
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/META.yml 2008-06-28 14:47:11 UTC (rev 8042)
+++ trunk/Catalyst-Controller-WrapCGI/META.yml 2008-06-28 22:29:41 UTC (rev 8043)
@@ -17,6 +17,7 @@
- t
requires:
Catalyst: 5.7007
+ File::Find::Rule: 0
HTTP::Request::AsCGI: 0
Task::Weaken: 0
URI: 0
Modified: trunk/Catalyst-Controller-WrapCGI/Makefile.PL
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/Makefile.PL 2008-06-28 14:47:11 UTC (rev 8042)
+++ trunk/Catalyst-Controller-WrapCGI/Makefile.PL 2008-06-28 22:29:41 UTC (rev 8043)
@@ -9,6 +9,7 @@
requires 'Task::Weaken';
requires 'HTTP::Request::AsCGI';
requires 'URI';
+requires 'File::Find::Rule';
build_requires 'Test::More';
Modified: trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm 2008-06-28 14:47:11 UTC (rev 8042)
+++ trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Controller/WrapCGI.pm 2008-06-28 22:29:41 UTC (rev 8043)
@@ -38,6 +38,21 @@
});
}
+In your .conf, configure which environment variables to pass:
+
+ <Controller::Foo>
+ <CGI>
+ pass_env PERL5LIB
+ pass_env PATH
+ pass_env HLAGH
+ </CGI>
+ </Controller::Foo>
+
+=head1 DESCRIPTION
+
+Allows you to run Perl code in a CGI environment derived from your L<Catalyst>
+context.
+
=cut
# Hack-around because Catalyst::Engine::HTTP goes and changes
@@ -53,6 +68,8 @@
Does the magic of running $coderef in a CGI environment, and populating the
appropriate parts of your Catalyst context with the results.
+Calls wrap_cgi (below.)
+
=cut
sub cgi_to_response {
@@ -80,6 +97,10 @@
The CGI environment is set up based on $c.
+The environment variables to pass on are taken from the configuration for your
+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.
=cut
@@ -106,6 +127,8 @@
}
}
+ my @env = @{ $self->{CGI}{pass_env} || [ keys %ENV ] };
+
$req->content($body_content);
$req->content_length(length($body_content));
my $user = (($c->can('user_exists') && $c->user_exists)
@@ -114,7 +137,7 @@
my $env = HTTP::Request::AsCGI->new(
$req,
REMOTE_USER => $user,
- %ENV
+ map { ($_, $ENV{$_}) } @env
);
{
@@ -143,6 +166,11 @@
Original development sponsored by L<http://www.altinity.com/>
+=head1 SEE ALSO
+
+L<Catalyst::Plugin::CGIBin>, L<CatalystX::GlobalContext>,
+L<Catalyst::Controller>, L<CGI>, L<Catalyst>
+
=head1 AUTHOR
Matt S. Trout, C<< <mst at shadowcat.co.uk> >>
Modified: trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Plugin/CGIBin.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Plugin/CGIBin.pm 2008-06-28 14:47:11 UTC (rev 8042)
+++ trunk/Catalyst-Controller-WrapCGI/lib/Catalyst/Plugin/CGIBin.pm 2008-06-28 22:29:41 UTC (rev 8043)
@@ -3,9 +3,16 @@
use strict;
use warnings;
+use Class::C3;
+use URI::Escape;
+use File::Slurp 'slurp';
+use File::Find::Rule ();
+use Cwd;
+use Catalyst::Exception ();
+
=head1 NAME
-Catalyst::Plugin::CGIBin - Server CGIs from root/cgi-bin
+Catalyst::Plugin::CGIBin - Serve CGIs from root/cgi-bin
=head1 VERSION
@@ -15,30 +22,86 @@
our $VERSION = '0.001';
-
=head1 SYNOPSIS
+In MyApp.pm:
+
+ use Catalyst;
+
+ __PACKAGE__->setup(qw/CGIBin/);
+
In your .conf:
+
<Plugin::CGIBin>
- controller MyApp::Controller::Foo
+ controller Foo
</Plugin::CGIBin>
- <MyApp::Controller::Foo>
+ <Controller::Foo>
<CGI>
pass_env PERL5LIB
pass_env PATH
</CGI>
- </MyApp::Controller::Foo>
+ </Controller::Foo>
=head1 DESCRIPTION
-Dispatches to CGI files in root/cgi-bin through the configured controller, which
-must inherit from L<Catalyst::Controller::WrapCGI>.
+Dispatches to executable CGI files in root/cgi-bin through the configured
+controller, which must inherit from L<Catalyst::Controller::WrapCGI>.
-I still need to write the code :)
-
=cut
+my ($cgi_controller, $cgis);
+
+sub setup {
+ my $app = shift;
+
+ my $cwd = getcwd;
+
+ my $cgi_bin = $app->path_to('root', 'cgi-bin');
+
+ chdir $cgi_bin ||
+ Catalyst::Exception->throw(
+ message => 'You have no root/cgi-bin directory'
+ );
+
+ $cgi_controller = $app->config->{'Plugin::CGIBin'}{controller} ||
+ Catalyst::Exception->throw(
+ message => 'You must configure a controller for Plugin::CGIBin'
+ );
+
+ for my $cgi (File::Find::Rule->executable->file->in(".")) {
+ my $code = do { no warnings; eval 'sub { '.slurp($cgi).' }' };
+ if (!$@) { # Perl source
+ $cgis->{$cgi} = $code;
+ undef $@;
+ } else { # some other type of executable
+ $cgis->{$cgi} = sub { system "$cgi_bin/$cgi" };
+ }
+ }
+
+ chdir $cwd;
+
+ $app->next::method(@_);
+}
+
+sub dispatch {
+ my $c = shift;
+ my $path = uri_unescape($c->req->path);
+
+ if ($path =~ m!^cgi-bin/(.*)!) {
+ my $cgi = $cgis->{$1};
+
+ if ($cgi) {
+ $c->controller($cgi_controller)->cgi_to_response(
+ $c, $cgi
+ );
+ return;
+ }
+ }
+
+ $c->next::method(@_);
+}
+
=head1 AUTHOR
Rafael Kitover, C<< <rkitover at cpan.org> >>
Modified: trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm 2008-06-28 14:47:11 UTC (rev 8042)
+++ trunk/Catalyst-Controller-WrapCGI/lib/CatalystX/GlobalContext.pm 2008-06-28 22:29:41 UTC (rev 8043)
@@ -6,6 +6,9 @@
use Scalar::Util 'weaken';
+use vars '$c';
+our @EXPORT_OK = '$c';
+
=head1 NAME
CatalystX::GlobalContext - Export Catalyst Context
Added: trunk/Catalyst-Controller-WrapCGI/t/00-load.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/00-load.t (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/00-load.t 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,11 @@
+#!perl -T
+
+use Test::More tests => 3;
+
+BEGIN {
+ use_ok( 'Catalyst::Controller::WrapCGI' );
+ use_ok( 'Catalyst::Plugin::CGIBin' );
+ use_ok( 'CatalystX::GlobalContext' );
+}
+
+diag( "Testing Catalyst::Controller::WrapCGI $Catalyst::Controller::WrapCGI::VERSION, Perl $], $^X" );
Added: trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/boilerplate.t 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,57 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 5;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open( my $fh, '<', $filename )
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+TODO: {
+ local $TODO = "Need to replace the boilerplate text";
+
+ not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+ );
+
+ not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+ );
+
+ module_boilerplate_ok('lib/Catalyst/Controller/WrapCGI.pm');
+ module_boilerplate_ok('lib/Catalyst/Plugin/CGIBin.pm');
+ module_boilerplate_ok('lib/CatalystX/GlobalContext.pm');
+
+
+}
+
Added: trunk/Catalyst-Controller-WrapCGI/t/global-context.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/global-context.t (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/global-context.t 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,36 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+
+{
+ package TestApp;
+
+ use Catalyst;
+ use CatalystX::GlobalContext ();
+
+ sub auto : Private {
+ my ($self, $c) = @_;
+ CatalystX::GlobalContext->set_context($c);
+ 1;
+ }
+
+ sub dummy : Local {
+ my ($self, $c) = @_;
+ $c->res->body(Dongs->foo);
+ }
+
+ __PACKAGE__->setup;
+
+ package Dongs;
+
+ use CatalystX::GlobalContext '$c';
+
+ sub foo { $c->action }
+}
+
+use Catalyst::Test 'TestApp';
+
+is(get('/dummy'), 'dummy', 'global context works');
Added: trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp/Controller/Root.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp/Controller/Root.pm (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp/Controller/Root.pm 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,19 @@
+package TestApp::Controller::Root;
+
+use parent 'Catalyst::Controller::WrapCGI';
+
+__PACKAGE__->config->{namespace} = '';
+
+my $cgi = sub {
+ use CGI ':standard';
+
+ print header;
+ print 'foo:',param('foo'),' bar:',param('bar')
+};
+
+sub handle_cgi : Path('/cgi-bin/test.cgi') {
+ my ($self, $c) = @_;
+ $self->cgi_to_response($c, $cgi);
+}
+
+1;
Added: trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp.pm (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestApp.pm 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,7 @@
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
Added: trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/Controller/CGIHandler.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/Controller/CGIHandler.pm (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/Controller/CGIHandler.pm 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,5 @@
+package TestPlugin::Controller::CGIHandler;
+
+use parent 'Catalyst::Controller::WrapCGI';
+
+1;
Added: trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.pl
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.pl (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.pl 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,9 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use CGI ':standard';
+
+print header;
+print 'foo:',param('foo'),' bar:',param('bar')
Property changes on: trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.pl
___________________________________________________________________
Name: svn:executable
+ *
Added: trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.sh
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.sh (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.sh 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,5 @@
+#!/bin/sh
+
+/bin/echo -e 'Content-Type: text/html; charset=ISO-8859-1\r\n'
+
+echo "Hello!"
Property changes on: trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin/root/cgi-bin/test.sh
___________________________________________________________________
Name: svn:executable
+ *
Added: trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/lib/TestPlugin.pm 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,11 @@
+package TestPlugin;
+
+use Catalyst;
+
+__PACKAGE__->config->{'Plugin::CGIBin'} = {
+ controller => 'CGIHandler'
+};
+
+__PACKAGE__->setup(qw/CGIBin/);
+
+1;
Added: trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/plugin-cgibin.t 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,21 @@
+#!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');
Added: trunk/Catalyst-Controller-WrapCGI/t/pod.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/pod.t (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/pod.t 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,12 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More;
+
+# Ensure a recent version of Test::Pod
+my $min_tp = 1.22;
+eval "use Test::Pod $min_tp";
+plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
+
+all_pod_files_ok();
Added: trunk/Catalyst-Controller-WrapCGI/t/wrap-cgi.t
===================================================================
--- trunk/Catalyst-Controller-WrapCGI/t/wrap-cgi.t (rev 0)
+++ trunk/Catalyst-Controller-WrapCGI/t/wrap-cgi.t 2008-06-28 22:29:41 UTC (rev 8043)
@@ -0,0 +1,19 @@
+#!perl
+
+use strict;
+use warnings;
+
+use FindBin '$Bin';
+use lib "$Bin/lib";
+
+use Test::More tests => 1;
+
+use Catalyst::Test 'TestApp';
+use HTTP::Request::Common;
+
+my $response = request POST '/cgi-bin/test.cgi', [
+ foo => 'bar',
+ bar => 'baz'
+];
+
+is($response->content, 'foo:bar bar:baz', 'POST to CGI');
More information about the Catalyst-commits
mailing list