Revision history for Catalyst-Controller-WrapCGI
+0.001 2008-06-28 15:28:46
+ First complete dist.
- t
requires:
Catalyst: 5.7007
+ File::Find::Rule: 0
HTTP::Request::AsCGI: 0
Task::Weaken: 0
URI: 0
requires 'Task::Weaken';
requires 'HTTP::Request::AsCGI';
requires 'URI';
+requires 'File::Find::Rule';
build_requires 'Test::More';
});
}
+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
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 {
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
}
}
+ 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)
my $env = HTTP::Request::AsCGI->new(
$req,
REMOTE_USER => $user,
- %ENV
+ map { ($_, $ENV{$_}) } @env
);
{
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> >>
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
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>.
-
-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<Catalyst::Controller::WrapCGI>.
=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> >>
use Scalar::Util 'weaken';
+use vars '$c';
+our @EXPORT_OK = '$c';
+
=head1 NAME
CatalystX::GlobalContext - Export Catalyst Context
--- /dev/null
+#!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" );
--- /dev/null
+#!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');
+
+
+}
+
--- /dev/null
+#!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');
--- /dev/null
+package TestApp;
+
+use Catalyst;
+
+__PACKAGE__->setup;
+
+1;
--- /dev/null
+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;
--- /dev/null
+package TestPlugin;
+
+use Catalyst;
+
+__PACKAGE__->config->{'Plugin::CGIBin'} = {
+ controller => 'CGIHandler'
+};
+
+__PACKAGE__->setup(qw/CGIBin/);
+
+1;
--- /dev/null
+package TestPlugin::Controller::CGIHandler;
+
+use parent 'Catalyst::Controller::WrapCGI';
+
+1;
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use CGI ':standard';
+
+print header;
+print 'foo:',param('foo'),' bar:',param('bar')
--- /dev/null
+#!/bin/sh
+
+/bin/echo -e 'Content-Type: text/html; charset=ISO-8859-1\r\n'
+
+echo "Hello!"
--- /dev/null
+#!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');
--- /dev/null
+#!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();
--- /dev/null
+#!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');