2) I think that "someone" (I think that Mark Stosberg holds the keys
to CAD::Server at the moment, I'd be happy to take them back)
should make some changes to ::Server.
- change new() so that it stashes a copy of $p{class} into
$self->{_class} and no longer saves
$p{class}->dispatch_args.
- delete the entire ::Server::dispatch_args method.
- change handle_request() so that instead of
CGI::Application::Dispatch->dispatch(%{$self->{dispatch_args}})
it just does
$self->{_class}->dispatch();
and let's the CGI::Application::Dispatch {,sub}class do the
right thing.
- add some tests to the package. Any tests would be a start.
3) I think that CGI::Application::Dispatch::dispatch is being too
clever/helpful/broken in how it handles dispatch_args. In
particular, if someone calls dispatch with a hash that contains an
args_to_new hash which in turn contains a TMPL_PATH array ref, then
dispatch() ends up duplicating that array's values.
Number 2) above is the quickest fix to the problem. Mark?
Number 1) will be necessary once number 2) is in place and is already
necessary if you want to run under fastcgi.
Number 3) seems to be a problem that no one has had yet but it's
lurking.
For what it's worth, about 6 months ago I was playing with CAD::Server
and started fixing a bunch of the things you mentioned. I have attached
a patch if anyone wishes to finish where I left off.
I can not recall, but I think I originally tried CA::Server, but could
not get it to work which is why I then started using CAD::Server. My
personal opinion would be to just update CA::Server to work with or
without CA::Dispatch.
Hopefully one of these days I will find time to start working on my
cgiapp projects again.
Regards,
Bradley C Bailey
diff -ruN
CGI-Application-Dispatch-Server-0.52.orig/lib/CGI/Application/Dispatch/Server.pm
CGI-Application-Dispatch-Server-0.52/lib/CGI/Application/Dispatch/Server.pm
---
CGI-Application-Dispatch-Server-0.52.orig/lib/CGI/Application/Dispatch/Server.pm
2007-07-07 06:49:22.000000000 -0600
+++ CGI-Application-Dispatch-Server-0.52/lib/CGI/Application/Dispatch/Server.pm
2008-03-13 18:58:39.000000000 -0600
@@ -11,52 +11,70 @@
use HTTP::Status;
use IO::Capture::Stdout;
use CGI::Application::Dispatch;
-use Params::Validate ':all';
-our $VERSION = '0.52';
+our $VERSION = '0.53_01';
-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
sub new {
- my $class = shift;
- my %p = validate(@_, {
- port => { default => '8080',},
- class => { default => 'CGI::Application::Dispatch' },
- root_dir => { default => '.' }
- });
+ my $class = shift;
+ my %p = @_;
+ my $self = $class->SUPER::new($p{port} || '8080');
+ $self->root_dir($p{root_dir}) if (exists $p{root_dir});
+ $self->dispatch_class($p{class}) if (exists $p{class});
+
+ return $self;
+}
+
+# accessors
+
+sub root_dir
+{
+ my ($self, $dir) = @_;
+
+ if (defined $dir) {
# Reality check, is "root_dir really a directory?
- unless (-d $p{root_dir}) {
- croak "root_dir does not appear to a directory. The path provided was:
$p{root_dir} ";
- }
+ croak "The specified root_dir ($dir) does not appear to be a directory."
+ unless (-d $dir);
+
+ $self->{root_dir} = $dir;
+ }
- my $self = $class->SUPER::new($p{port});
+ return $self->{root_dir} || '.';
+}
- $self->{root_dir} = $p{root_dir};
+sub dispatch_class {
+ my ($self, $class) = @_;
+ if (defined $class) {
# XXX add reality check that the class has dispatch_args method first?
- eval "require $p{class}" || croak $@;
+ eval "require $class" || croak $@;
+ $self->{dispatch_class} = $class;
+ }
- $self->{dispatch_args} = $p{class}->dispatch_args;
- return $self;
+ return $self->{dispatch_class} || 'CGI::Application::Dispatch';
}
-# accessors
-
sub dispatch_args {
my ($self, $new_args) = @_;
+
if (defined $new_args) {
(reftype($new_args) && reftype($new_args) eq 'HASH') ||
confess "The new_args must be a HASH ref, not $new_args";
+
+ # grab the current dispatch_args from the dispatch_class
+ $self->{dispatch_args} = $self->dispatch_class->dispatch_args
+ if (!defined $self->{dispatch_args});
+
# merge the new args into the defaults.
@{$self->{dispatch_args}}{keys %$new_args} = values %$new_args;
}
- return $self->{dispatch_args} ;
+
+ return $self->{dispatch_args};
}
sub handle_request {
@@ -64,12 +82,12 @@
# If the the request doesn't map to a static file that exists,
# try our dispatch table.
- unless ( $self->serve_static($cgi, $self->{root_dir}) ) {
+ unless ( $self->serve_static($cgi, $self->root_dir) ) {
# warn "$ENV{REQUEST_URI}\n";
# warn "\t$_ => " . param( $_ ) . "\n" for param();
my $capture = IO::Capture::Stdout->new;
$capture->start;
- CGI::Application::Dispatch->dispatch(%{$self->{dispatch_args}});
+ $self->dispatch_class->dispatch(%{$self->{dispatch_args}});
$capture->stop;
my $stdout = join "\x0d\x0a", $capture->read;
my $response = $self->_build_response( $stdout );
@@ -174,20 +192,63 @@
root_dir => './alphasite', # optional, defaults to "."
);
-Initialize the server. If you've subclassed CGI::Application::Dispatch to
provide your own
-C<dispatch_args()>, let us know that here.
+Initialize the server. The options to the constructor are described below.
-If you are also serving some static content, define "root_dir" with the root
directory
-of this content.
+=over 4
-=head1 Other Methods You Probably Don't Need to Know About
+=item class
+
+If you are using a subclass of
+L<CGI::Application::Dispatch|CGI::Application::Dispatch> specify that here.
+This will default to C<CGI::Application::Dispatch>.
+
+=item port
+
+Specify the port to listen on. By default it will listen on 8080.
+
+=item root_dir
+
+If you are serving any static content, specify the directory here. By default
+it will check for static content in the current directory (C<.>).
+
+=back
+
+Since the returned object is a subclass of L<HTTP::Server::Simple::CGI>, any
+methods supported by it will also be supported.
+
+=head2 root_dir()
+
+ $server->root_dir("/path/to/content");
+ my $dir = $server->root_dir;
+
+Get or set the value of the root directory. This directory is used for serving
+static content. The default value is the current directory (C<.>).
+
+This method verifies that the parameter is indeed a directory and will throw
+an error if it is not.
+
+=head2 dispatch_class()
+
+ $server->dispatch_class('My::Custom::Dispatch');
+ my $class = $server->dispatch_class;
+
+Get or set the current dispatch class to use. This is initially set to the
+value of the C<class> parameter when creating a new object. You will not
+likely ever need to call it directly. The default value is
+C<CGI::Application::Dispatch>.
+
+When setting the class, specify a the class name as a string. The class is
+automatically loaded when set and it will throw an error if there were any
+errors during the loading.
=head2 dispatch_args()
$server->dispatch_args(\%override_args);
-This accepts a hashref of arguments and merges it into
-L<CGI::Application::Dispatch|CGI::Application::Dispatch>'s dispatch()
arguments.
+This accepts a hashref of arguments and merges it into the C<dispatch_args>
+of the C<dispatch_class>. This first time this is called the C<dispatch_args>
+are retrieved from the C<dispatch_class> and the specified values merged into
+it.
Be aware that this is a shallow merge, so a top level key name in the new hash
will completely replace one in the old hash with the same name.
@@ -195,6 +256,8 @@
It is recommended that you put your dispatch args in a separate class instead,
as mentioned
in the L<DESCRIPTION>.
+=head1 Other Methods You Probably Don't Need to Know About
+
=head2 handle_request()
$self->handle_request($cgi);
@@ -222,6 +285,7 @@
George Hartzell E<lt>[EMAIL PROTECTED]<gt>
Mark Stosberg
+Bradley C Bailey
=head1 COPYRIGHT AND LICENSE
diff -ruN CGI-Application-Dispatch-Server-0.52.orig/Makefile.PL
CGI-Application-Dispatch-Server-0.52/Makefile.PL
--- CGI-Application-Dispatch-Server-0.52.orig/Makefile.PL 2007-07-07
06:49:22.000000000 -0600
+++ CGI-Application-Dispatch-Server-0.52/Makefile.PL 2008-03-04
17:25:23.000000000 -0700
@@ -15,7 +15,6 @@
'Test::More' => '0.47',
'HTTP::Server::Simple' => '0.18',
'CGI::Application' => '0',
- 'Params::Validate' => 0,
'CGI::Application::Dispatch' => '0',
'HTTP::Server::Simple::CGI' => 0,
'HTTP::Request' => '0',
diff -ruN CGI-Application-Dispatch-Server-0.52.orig/t/01-basic.t
CGI-Application-Dispatch-Server-0.52/t/01-basic.t
--- CGI-Application-Dispatch-Server-0.52.orig/t/01-basic.t 1969-12-31
17:00:00.000000000 -0700
+++ CGI-Application-Dispatch-Server-0.52/t/01-basic.t 2008-03-04
17:35:25.000000000 -0700
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+use Test::More 'no_plan';
+use File::Basename;
+use strict;
+
+BEGIN { use_ok('CGI::Application::Dispatch::Server'); }
+
+my $server = bless { }, 'CGI::Application::Dispatch::Server';
+
+# Default values
+is($server->root_dir, '.', "default root_dir");
+is($server->dispatch_class, 'CGI::Application::Dispatch', "default class");
+is($server->dispatch_args, undef, "default dispatch_args is undef");
+
+# Setting root directory
+eval { $server->root_dir("/path/to/invalid") };
+like($@, qr/does not appear to be a directory/, "invalid root_dir error");
+ok($server->root_dir(dirname(__FILE__)), "setting root_dir"); # XXX
+is($server->root_dir, dirname(__FILE__), " got back correct value");
+
+# Merging in dispatch_args
+my $dispatch_args = CGI::Application::Dispatch->dispatch_args;
+ok($server->dispatch_args({ }), "setting dispatch args");
+is_deeply($server->dispatch_args, $dispatch_args, " nothing changed");
+ok($server->dispatch_args({ default => 'testing' }), "merging test arg");
+is($server->dispatch_args->{default}, 'testing', " value merged");
##### CGI::Application community mailing list ################
## ##
## To unsubscribe, or change your message delivery options, ##
## visit: http://www.erlbaum.net/mailman/listinfo/cgiapp ##
## ##
## Web archive: http://www.erlbaum.net/pipermail/cgiapp/ ##
## Wiki: http://cgiapp.erlbaum.net/ ##
## ##
################################################################
