[cgiapp] CGI::Application::Server enhancements (for Dispatch)
Ricardo SIGNES
rjbs-perl-cgiapp at lists.manxome.org
Mon Oct 22 21:42:34 EDT 2007
I didn't notice CA::Dispatch::Server when I was doing some poking at some code
the other day so instead I patched CGI::Application::Server to handle
::Dispatch modules.
I think this was a good mistake: CADS doesn't really strike me as being as good
a design as CAServer. In CADS, you say:
* here is a doc root
* here is a Dispatch class
* if you can't find static content, try Dispatch
With CAS, you say:
* here is docroot
* here is a mapping of paths to CA classes
* if it isn't mapped to CA, try looking in the docroot
So, there's already some ability to point to multiple CA classes with CAS.
With my patch (which will shortly be available in a new release of CAS), you
can use CA::Dispatch classes as mapping destinations, and the URL will be
mapped correctly (that is: the way I want) and sent to the dispatch class.
Feedback would be adored!
--
rjbs
-------------- next part --------------
diff -Nur CGI-Application-Server-0.03/Build.PL CGI-Application-Server-0.04/Build.PL
--- CGI-Application-Server-0.03/Build.PL 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/Build.PL 2007-10-21 10:03:01.000000000 -0400
@@ -10,7 +10,6 @@
'Carp' => '0.01',
'HTTP::Request' => '0',
'HTTP::Status' => '0',
- 'IO::Capture::Stdout' => '0',
'CGI::Application' => '0',
'HTTP::Server::Simple' => '0.18',
'HTTP::Server::Simple::Static' => '0.02',
diff -Nur CGI-Application-Server-0.03/ChangeLog CGI-Application-Server-0.04/ChangeLog
--- CGI-Application-Server-0.03/ChangeLog 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/ChangeLog 2007-10-21 08:56:44.000000000 -0400
@@ -1,5 +1,8 @@
Changes for CGI::Application::Server
+0.04 Sun. Oct 21, 2007
+ - add support for CGI::Application::Dispatch classes
+
0.03 Tues. Feb 20, 2007
- Fixed is_valid_entry_point to be more strict
in how it matched URIs
diff -Nur CGI-Application-Server-0.03/MANIFEST CGI-Application-Server-0.04/MANIFEST
--- CGI-Application-Server-0.03/MANIFEST 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/MANIFEST 2007-10-21 09:45:53.000000000 -0400
@@ -1,16 +1,18 @@
Build.PL
ChangeLog
+lib/CGI/Application/Server.pm
+Makefile.PL
MANIFEST
+META.yml
README
-lib/CGI/Application/Server.pm
t/000_load.t
t/001_basic.t
t/002_valid_entry_points.t
-t/pod.t
-t/pod_coverage.t
+t/003_dispatch.t
t/htdocs/index.html
t/htdocs/test.css
t/htdocs/test.js
t/lib/MyCGIApp.pm
-Makefile.PL
-META.yml
+t/lib/MyCGIApp/Dispatch.pm
+t/pod.t
+t/pod_coverage.t
diff -Nur CGI-Application-Server-0.03/META.yml CGI-Application-Server-0.04/META.yml
--- CGI-Application-Server-0.03/META.yml 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/META.yml 2007-10-21 10:03:04.000000000 -0400
@@ -15,7 +15,6 @@
HTTP::Server::Simple: 0.18
HTTP::Server::Simple::Static: 0.02
HTTP::Status: 0
- IO::Capture::Stdout: 0
Scalar::Util: 1.18
build_requires:
CGI::Application::Plugin::Redirect: 0
diff -Nur CGI-Application-Server-0.03/Makefile.PL CGI-Application-Server-0.04/Makefile.PL
--- CGI-Application-Server-0.03/Makefile.PL 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/Makefile.PL 2007-10-21 10:02:58.000000000 -0400
@@ -9,7 +9,6 @@
'VERSION_FROM' => 'lib/CGI/Application/Server.pm',
'PREREQ_PM' => {
'Scalar::Util' => '1.18',
- 'IO::Capture::Stdout' => '0',
'Test::Exception' => '0.21',
'Test::HTTP::Server::Simple' => '0.02',
'CGI::Application::Plugin::Redirect' => '0',
diff -Nur CGI-Application-Server-0.03/README CGI-Application-Server-0.04/README
--- CGI-Application-Server-0.03/README 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/README 2007-10-21 10:03:11.000000000 -0400
@@ -18,7 +18,6 @@
HTTP::Request
HTTP::Status
- IO::Capture::Stdout
CGI::Application
HTTP::Server::Simple
HTTP::Server::Simple::Static
diff -Nur CGI-Application-Server-0.03/lib/CGI/Application/Server.pm CGI-Application-Server-0.04/lib/CGI/Application/Server.pm
--- CGI-Application-Server-0.03/lib/CGI/Application/Server.pm 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/lib/CGI/Application/Server.pm 2007-10-21 10:03:07.000000000 -0400
@@ -9,9 +9,8 @@
use Scalar::Util qw( blessed reftype );
use HTTP::Response;
use HTTP::Status;
-use IO::Capture::Stdout;
-our $VERSION = '0.03';
+our $VERSION = '0.04';
use base qw(
HTTP::Server::Simple::CGI
@@ -61,7 +60,7 @@
while ( $uri ) {
# Check to see if this is an exact match
if (exists $self->{entry_points}{$uri}) {
- return $self->{entry_points}{$uri};
+ return ($uri, $self->{entry_points}{$uri});
}
# Remove the rightmost path element
@@ -74,14 +73,19 @@
sub handle_request {
my ($self, $cgi) = @_;
- if (my $entry_point = $self->is_valid_entry_point($ENV{REQUEST_URI})) {
- warn "$ENV{REQUEST_URI} ($entry_point)\n";
+ if (my ($path, $target) = $self->is_valid_entry_point($ENV{REQUEST_URI})) {
+ warn "$ENV{REQUEST_URI} ($target)\n";
warn "\t$_ => " . param( $_ ) . "\n" for param();
- my $capture = IO::Capture::Stdout->new;
- $capture->start;
- $entry_point->new->run;
- $capture->stop;
- my $stdout = join "", $capture->read;
+
+ my $stdout;
+ local $ENV{CGI_APP_RETURN_ONLY} = 1;
+ if ($target->isa('CGI::Application::Dispatch')) {
+ (local $ENV{PATH_INFO} = $ENV{PATH_INFO}) =~ s/\A\Q$path//;
+ $stdout = $target->dispatch;
+ } else {
+ $stdout = $target->new->run;
+ }
+
my $response = $self->_build_response( $stdout );
print $response->as_string;
}
@@ -161,7 +165,8 @@
$server->document_root('./htdocs');
$server->entry_points({
'/index.cgi' => 'MyCGIApp',
- '/admin' => 'MyCGIApp::Admin'
+ '/admin' => 'MyCGIApp::Admin',
+ '/account' => 'MyCGIApp::Account::Dispatch',
});
$server->run();
@@ -190,9 +195,9 @@
=item B<entry_points (?$entry_points)>
-This accepts a HASH reference in C<$entry_points>, which maps
-server entry points (uri) to L<CGI::Application> class names.
-See the L<SYNOPSIS> above for an example.
+This accepts a HASH reference in C<$entry_points>, which maps server entry
+points (uri) to L<CGI::Application> or L<CGI::Application::Dispatch> class
+names. See the L<SYNOPSIS> above for an example.
=item B<is_valid_entry_point ($uri)>
@@ -224,9 +229,8 @@
---------------------------- ------ ------ ------ ------ ------ ------ ------
File stmt bran cond sub pod time total
---------------------------- ------ ------ ------ ------ ------ ------ ------
- CGI/Application/Server.pm 95.1 79.2 53.3 100.0 100.0 100.0 88.5
- ---------------------------- ------ ------ ------ ------ ------ ------ ------
- Total 95.1 79.2 53.3 100.0 100.0 100.0 88.5
+ ...CGI/Application/Server.pm 95.6 80.8 53.3 100.0 100.0 100.0 89.4
+ Total 95.6 80.8 53.3 100.0 100.0 100.0 89.4
---------------------------- ------ ------ ------ ------ ------ ------ ------
=head1 ACKNOWLEDGEMENTS
diff -Nur CGI-Application-Server-0.03/t/003_dispatch.t CGI-Application-Server-0.04/t/003_dispatch.t
--- CGI-Application-Server-0.03/t/003_dispatch.t 1969-12-31 19:00:00.000000000 -0500
+++ CGI-Application-Server-0.04/t/003_dispatch.t 2007-10-21 09:52:26.000000000 -0400
@@ -0,0 +1,81 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use lib 't/lib/';
+
+use Test::More;
+
+use Test::Exception;
+use Test::HTTP::Server::Simple;
+use Test::WWW::Mechanize;
+
+unless (eval "require CGI::Application::Dispatch; 1") {
+ plan skip_all => "CGI::Application::Dispatch required for these tests";
+} else {
+ plan tests => 19;
+}
+
+use_ok('CGI::Application::Server');
+use_ok('MyCGIApp');
+use_ok('MyCGIApp::Dispatch');
+
+{
+ package TestServer;
+ use base qw/
+ Test::HTTP::Server::Simple
+ CGI::Application::Server
+ /;
+}
+
+my $server = TestServer->new();
+isa_ok($server, 'CGI::Application::Server');
+isa_ok($server, 'HTTP::Server::Simple');
+
+is_deeply($server->entry_points, {}, '... no entry-point yet');
+$server->entry_points({
+ '/index.cgi' => 'MyCGIApp',
+ '/bar' => 'MyCGIApp::Dispatch',
+});
+
+is_deeply(
+ $server->entry_points,
+ {
+ '/index.cgi' => 'MyCGIApp',
+ '/bar' => 'MyCGIApp::Dispatch',
+ },
+ '... we have an entry point now',
+);
+
+$server->document_root('./t/htdocs');
+is($server->document_root, './t/htdocs', '... got the new server root');
+
+# ignore the warnings for now,
+# they are too hard to test really
+local $SIG{__WARN__} = sub { 1 };
+
+my $url_root = $server->started_ok("start up my web server");
+
+my $mech = Test::WWW::Mechanize->new();
+
+# test our static index page
+
+$mech->get_ok($url_root.'/index.html', '... got the index.html page okay');
+$mech->title_is('Test Static Index Page', '... got the right page title for index.html');
+
+# test out entry point page
+
+$mech->get_ok($url_root.'/index.cgi', '... got the index.cgi page start-point okay');
+$mech->title_is('Hello', '... got the right page title for index.cgi');
+
+# test with query params
+
+$mech->get_ok($url_root.'/bar/foo/mode1', '... got mode1 via dispatch');
+$mech->title_is('Hello', '... got the right page title for mode1 (hello)');
+
+$mech->get_ok($url_root.'/bar/foo/mode2', '... got mode2 via dispatch');
+$mech->title_is('Goodbye', '... got the right page title for mode2 (bye)');
+
+$mech->get_ok($url_root.'/bar/foo/mode3', '... got mode3, get redir');
+$mech->title_is('Redirect End', '... got the right page title for mode4');
diff -Nur CGI-Application-Server-0.03/t/lib/MyCGIApp/Dispatch.pm CGI-Application-Server-0.04/t/lib/MyCGIApp/Dispatch.pm
--- CGI-Application-Server-0.03/t/lib/MyCGIApp/Dispatch.pm 1969-12-31 19:00:00.000000000 -0500
+++ CGI-Application-Server-0.04/t/lib/MyCGIApp/Dispatch.pm 2007-10-21 09:05:48.000000000 -0400
@@ -0,0 +1,15 @@
+use strict;
+use warnings;
+
+package MyCGIApp::Dispatch;
+use base 'CGI::Application::Dispatch';
+
+sub dispatch_args {
+ return {
+ table => [
+ '/foo/:rm' => { app => 'MyCGIApp' },
+ ]
+ }
+}
+
+1;
diff -Nur CGI-Application-Server-0.03/t/lib/MyCGIApp.pm CGI-Application-Server-0.04/t/lib/MyCGIApp.pm
--- CGI-Application-Server-0.03/t/lib/MyCGIApp.pm 2007-02-20 21:07:27.000000000 -0500
+++ CGI-Application-Server-0.04/t/lib/MyCGIApp.pm 2007-10-21 09:38:22.000000000 -0400
@@ -10,9 +10,9 @@
$self->mode_param('rm');
$self->run_modes(
'mode1' => 'hello_world',
- 'mode2' => 'goodbye_world',
- 'mode3' => 'redirected',
- 'mode4' => 'redirect_end',
+ 'mode2' => 'goodbye_world',
+ 'mode3' => 'redirected',
+ 'mode4' => 'redirect_end',
);
}
@@ -31,7 +31,7 @@
sub redirected {
my $self = shift;
- return $self->redirect( "index.cgi?rm=mode4" );
+ return $self->redirect( "/index.cgi?rm=mode4" );
}
sub redirect_end {
More information about the cgiapp
mailing list