From: Rafael Kitover Date: Sat, 28 Jun 2008 22:29:41 +0000 (+0000) Subject: Finished first version of WrapCGI dist X-Git-Tag: 0.030~66 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Controller-WrapCGI.git;a=commitdiff_plain;h=457c1d76ed6730ef07a1ab35b1ec1c47d6c4f19d Finished first version of WrapCGI dist --- diff --git a/Changes b/Changes index 39811e5..5cddccb 100644 --- a/Changes +++ b/Changes @@ -1,2 +1,4 @@ Revision history for Catalyst-Controller-WrapCGI +0.001 2008-06-28 15:28:46 + First complete dist. diff --git a/META.yml b/META.yml index fc28bc7..8c7d190 100644 --- a/META.yml +++ b/META.yml @@ -17,6 +17,7 @@ no_index: - t requires: Catalyst: 5.7007 + File::Find::Rule: 0 HTTP::Request::AsCGI: 0 Task::Weaken: 0 URI: 0 diff --git a/Makefile.PL b/Makefile.PL index eea901c..32104d0 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -9,6 +9,7 @@ requires 'parent'; requires 'Task::Weaken'; requires 'HTTP::Request::AsCGI'; requires 'URI'; +requires 'File::Find::Rule'; build_requires 'Test::More'; diff --git a/lib/Catalyst/Controller/WrapCGI.pm b/lib/Catalyst/Controller/WrapCGI.pm index 3e9d117..7338efe 100644 --- a/lib/Catalyst/Controller/WrapCGI.pm +++ b/lib/Catalyst/Controller/WrapCGI.pm @@ -38,6 +38,21 @@ our $VERSION = '0.001'; }); } +In your .conf, configure which environment variables to pass: + + + + pass_env PERL5LIB + pass_env PATH + pass_env HLAGH + + + +=head1 DESCRIPTION + +Allows you to run Perl code in a CGI environment derived from your L +context. + =cut # Hack-around because Catalyst::Engine::HTTP goes and changes @@ -53,6 +68,8 @@ open my $REAL_STDOUT, ">>&=".fileno(*STDOUT); 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 @@ L. 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 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 @@ sub wrap_cgi { } } + 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 @@ sub wrap_cgi { my $env = HTTP::Request::AsCGI->new( $req, REMOTE_USER => $user, - %ENV + map { ($_, $ENV{$_}) } @env ); { @@ -143,6 +166,11 @@ sub wrap_cgi { Original development sponsored by L +=head1 SEE ALSO + +L, L, +L, L, L + =head1 AUTHOR Matt S. Trout, C<< >> diff --git a/lib/Catalyst/Plugin/CGIBin.pm b/lib/Catalyst/Plugin/CGIBin.pm index a926bd7..611c5e9 100644 --- a/lib/Catalyst/Plugin/CGIBin.pm +++ b/lib/Catalyst/Plugin/CGIBin.pm @@ -3,9 +3,16 @@ package Catalyst::Plugin::CGIBin; 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 @@ Version 0.001 our $VERSION = '0.001'; - =head1 SYNOPSIS +In MyApp.pm: + + use Catalyst; + + __PACKAGE__->setup(qw/CGIBin/); + In your .conf: + - controller MyApp::Controller::Foo + controller Foo - + pass_env PERL5LIB pass_env PATH - + =head1 DESCRIPTION -Dispatches to CGI files in root/cgi-bin through the configured controller, which -must inherit from L. - -I still need to write the code :) +Dispatches to executable CGI files in root/cgi-bin through the configured +controller, which must inherit from L. =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<< >> diff --git a/lib/CatalystX/GlobalContext.pm b/lib/CatalystX/GlobalContext.pm index 579e08e..f76d8d3 100644 --- a/lib/CatalystX/GlobalContext.pm +++ b/lib/CatalystX/GlobalContext.pm @@ -6,6 +6,9 @@ use parent 'Exporter'; use Scalar::Util 'weaken'; +use vars '$c'; +our @EXPORT_OK = '$c'; + =head1 NAME CatalystX::GlobalContext - Export Catalyst Context diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..08510b8 --- /dev/null +++ b/t/00-load.t @@ -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" ); diff --git a/t/boilerplate.t b/t/boilerplate.t new file mode 100644 index 0000000..93ddf47 --- /dev/null +++ b/t/boilerplate.t @@ -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'); + + +} + diff --git a/t/global-context.t b/t/global-context.t new file mode 100644 index 0000000..d925502 --- /dev/null +++ b/t/global-context.t @@ -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'); diff --git a/t/lib/TestApp.pm b/t/lib/TestApp.pm new file mode 100644 index 0000000..7214e95 --- /dev/null +++ b/t/lib/TestApp.pm @@ -0,0 +1,7 @@ +package TestApp; + +use Catalyst; + +__PACKAGE__->setup; + +1; diff --git a/t/lib/TestApp/Controller/Root.pm b/t/lib/TestApp/Controller/Root.pm new file mode 100644 index 0000000..5f479bb --- /dev/null +++ b/t/lib/TestApp/Controller/Root.pm @@ -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; diff --git a/t/lib/TestPlugin.pm b/t/lib/TestPlugin.pm new file mode 100644 index 0000000..110bab9 --- /dev/null +++ b/t/lib/TestPlugin.pm @@ -0,0 +1,11 @@ +package TestPlugin; + +use Catalyst; + +__PACKAGE__->config->{'Plugin::CGIBin'} = { + controller => 'CGIHandler' +}; + +__PACKAGE__->setup(qw/CGIBin/); + +1; diff --git a/t/lib/TestPlugin/Controller/CGIHandler.pm b/t/lib/TestPlugin/Controller/CGIHandler.pm new file mode 100644 index 0000000..043e748 --- /dev/null +++ b/t/lib/TestPlugin/Controller/CGIHandler.pm @@ -0,0 +1,5 @@ +package TestPlugin::Controller::CGIHandler; + +use parent 'Catalyst::Controller::WrapCGI'; + +1; diff --git a/t/lib/TestPlugin/root/cgi-bin/test.pl b/t/lib/TestPlugin/root/cgi-bin/test.pl new file mode 100755 index 0000000..5af6521 --- /dev/null +++ b/t/lib/TestPlugin/root/cgi-bin/test.pl @@ -0,0 +1,9 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use CGI ':standard'; + +print header; +print 'foo:',param('foo'),' bar:',param('bar') diff --git a/t/lib/TestPlugin/root/cgi-bin/test.sh b/t/lib/TestPlugin/root/cgi-bin/test.sh new file mode 100755 index 0000000..bcaf85f --- /dev/null +++ b/t/lib/TestPlugin/root/cgi-bin/test.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +/bin/echo -e 'Content-Type: text/html; charset=ISO-8859-1\r\n' + +echo "Hello!" diff --git a/t/plugin-cgibin.t b/t/plugin-cgibin.t new file mode 100644 index 0000000..0062080 --- /dev/null +++ b/t/plugin-cgibin.t @@ -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'); diff --git a/t/pod.t b/t/pod.t new file mode 100644 index 0000000..ee8b18a --- /dev/null +++ b/t/pod.t @@ -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(); diff --git a/t/wrap-cgi.t b/t/wrap-cgi.t new file mode 100644 index 0000000..fbf5891 --- /dev/null +++ b/t/wrap-cgi.t @@ -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');