Index: t/007_default_target.t
===================================================================
--- t/007_default_target.t (.../trunk) (revision 0)
+++ t/007_default_target.t (.../branches/mega) (revision 23)
@@ -0,0 +1,52 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+use Test::Exception;
+
+package main;
+
+BEGIN {
+ use_ok('CGI::Application::Server');
+}
+
+=pod
+
+This could probably use some more tests, but it
+is good enough for now.
+
+=cut
+
+my $server = CGI::Application::Server->new();
+isa_ok($server, 'CGI::Application::Server');
+isa_ok($server, 'HTTP::Server::Simple');
+
+$server->entry_points({
+ '/' => 'TopLevel',
+ '/foo' => 'Foo',
+});
+
+foreach my $uri (qw(
+ /foo
+ /foo?say=hello
+ /foo/bling/bar
+ /foo/?bar=baz
+ /foo/barr
+ )) {
+ is($server->is_valid_entry_point($uri), 'Foo', '... got Foo where we expected');
+}
+
+foreach my $uri (qw(
+ /
+ /fooo
+ /fooo/
+ /food?say=hello
+ /fooo/bar
+ /fooo/barr/baz
+ )) {
+ is($server->is_valid_entry_point($uri), 'TopLevel', '... got TopLevel where we expected');
+}
+
+
Index: t/htdocs/images/index.html
===================================================================
--- t/htdocs/images/index.html (.../trunk) (revision 0)
+++ t/htdocs/images/index.html (.../branches/mega) (revision 23)
@@ -0,0 +1,9 @@
+
+
+ 1000 Words!
+
+
+Bar
+Bar
+
+
Index: t/htdocs/static/index.html
===================================================================
--- t/htdocs/static/index.html (.../trunk) (revision 0)
+++ t/htdocs/static/index.html (.../branches/mega) (revision 23)
@@ -0,0 +1,9 @@
+
+
+ White Noise!
+
+
+Foo
+Foo
+
+
Index: t/006_docroot_as_entry_point.t
===================================================================
--- t/006_docroot_as_entry_point.t (.../trunk) (revision 0)
+++ t/006_docroot_as_entry_point.t (.../branches/mega) (revision 23)
@@ -0,0 +1,31 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More tests => 5;
+use Test::WWW::Mechanize;
+use CGI::Application::Server;
+
+{
+ package TestServer;
+ use base qw/
+ Test::HTTP::Server::Simple
+ CGI::Application::Server
+ /;
+}
+
+my $server = TestServer->new();
+$server->entry_points({
+ '/static' => 't/htdocs',
+ '/images' => 't/htdocs',
+});
+my $url_root = $server->started_ok("start up my web server");
+
+my $mech = Test::WWW::Mechanize->new();
+
+$mech->get_ok($url_root . '/static/index.html', '...got /static/index.html');
+$mech->title_is('White Noise!', '... got the right page title w/ static page');
+
+$mech->get_ok($url_root . '/images/index.html', '...got /images/index.html');
+$mech->title_is('1000 Words!', '... got the right page title w/ images page');
+
Index: lib/CGI/Application/Server.pm
===================================================================
--- lib/CGI/Application/Server.pm (.../trunk) (revision 23)
+++ lib/CGI/Application/Server.pm (.../branches/mega) (revision 23)
@@ -12,10 +12,8 @@
our $VERSION = '0.050';
-use base qw(
- HTTP::Server::Simple::CGI
- HTTP::Server::Simple::Static
-);
+use base qw( HTTP::Server::Simple::CGI );
+use HTTP::Server::Simple::Static;
# HTTP::Server::Simple methods
@@ -67,6 +65,11 @@
$uri =~ s/\/[^\/]*$//;
}
+ # Check to see if there's an entry for '/'
+ if (exists $self->{entry_points}{'/'}) {
+ return ($uri, $self->{entry_points}{'/'});
+ }
+
# Didn't find anything. Oh, well.
return;
}
@@ -77,29 +80,38 @@
warn "$ENV{REQUEST_URI} ($target)\n";
warn "\t$_ => " . param( $_ ) . "\n" for param();
- my $stdout;
local $ENV{CGI_APP_RETURN_ONLY} = 1;
(local $ENV{PATH_INFO} = $ENV{PATH_INFO}) =~ s/\A\Q$path//;
- if ($target->isa('CGI::Application::Dispatch')) {
- $stdout = $target->dispatch;
+ if (-d $target && -x $target) {
+ return $self->serve_static($cgi, $target);
+ }
+ elsif ($target->isa('CGI::Application::Dispatch')) {
+ return $self->serve_response($target->dispatch);
} elsif ($target->isa('CGI::Application')) {
if (!defined blessed $target) {
- $stdout = $target->new->run;
+ return $self->serve_response($target->new->run);
} else {
- $stdout = $target->run;
+ return $self->serve_response($target->run);
}
- } else {
- confess "Target must be a CGI::Application or CGI::Application::Dispatch subclass\n";
+ }
+ else {
+ confess "Target must be a CGI::Application or CGI::Application::Dispatch subclass or the name of a directory that exists and is readable.\n";
}
-
- my $response = $self->_build_response( $stdout );
- print $response->as_string;
} else {
return $self->serve_static($cgi, $self->document_root);
}
}
+sub serve_response {
+ my ( $self, $stdout ) = @_;
+
+ my $response = $self->_build_response( $stdout );
+ print $response->as_string();
+
+ return 1; # Like ...Simple::Static::serve_static does
+}
+
# Shamelessly stolen from HTTP::Request::AsCGI by chansen
sub _build_response {
my ( $self, $stdout ) = @_;
@@ -166,6 +178,10 @@
=head1 SYNOPSIS
use CGI::Application::Server;
+ use MyCGIApp::DefaultApp;
+ use MyCGIApp;
+ use MyCGIApp::Admin;
+ use MyCGI::App::Account::Dispatch;
my $server = CGI::Application::Server->new();
@@ -173,10 +189,12 @@
$server->document_root('./htdocs');
$server->entry_points({
+ '/' => 'MyCGIApp::DefaultApp',
'/index.cgi' => 'MyCGIApp',
'/admin' => 'MyCGIApp::Admin',
'/account' => 'MyCGIApp::Account::Dispatch',
'/users' => $object,
+ '/static' => '/usr/local/htdocs',
});
$server->run();
@@ -207,7 +225,8 @@
This accepts a HASH reference in C<$entry_points>, which maps server entry
points (uri) to L or L class
-names or objects. See the L above for examples.
+names or objects or to directories from which static content will be served
+by HTTP::Server::Simple::Static. See the L above for examples.
=item B
Property changes on: .
___________________________________________________________________
Added: svn:mergeinfo
Merged /branches/static-content:r13-21
Merged /branches/fix-pod:r15-19
Merged /branches/fix-empty-target-take-2:r9-22
Merged /branches/fix-simple-use:r6-20
Merged /branches/dispatching-whack:r5-12