CGI::Application::Dispatch::Server - A simple HTTP server for developing with CGI::Application::Dispatch

  use CGI::Application::Dispatch::Server;

  my $server = CGI::Application::Dispatch::Server->new( 
             class    => 'MyClass::Dispatch' 
             root_dir => '/home/project/www',
   );
  $server->run;

  my $server = CGI::Application::Dispatch::Server->new( 
        port     => '80',                # optional, defaults to 8080
        class    => 'MyClass::Dispatch', # optional, defaults CGI::Application::Dispatch
        root_dir => './alphasite',       # optional, defaults to "."
  );

 $server->dispatch_args(\%override_args);

  $self->handle_request($cgi);

package CGI::Application::Dispatch::Server;

use strict;
use warnings;

use Carp qw ( confess croak );
#use CGI 'param';
use Scalar::Util qw( blessed reftype );
use HTTP::Response;
use HTTP::Status;
use IO::Capture::Stdout;
use CGI::Application::Dispatch;
use Params::Validate ':all';

our $VERSION = '0.53';

use base qw(
	    HTTP::Server::Simple::CGI
	    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 => '.' }
    });

    # 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} ";
    }

	my $self  = $class->SUPER::new($p{port});

	$self->{root_dir}  = $p{root_dir};

    # XXX add reality check that the class has dispatch_args method first?
    eval "require $p{class}" || croak $@;

	$self->{dispatch_args} = $p{class}->dispatch_args;
	return $self;
}

# 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";
    # merge the new args into the defaults.
    @{$self->{dispatch_args}}{keys %$new_args} = values %$new_args;
  }
  return $self->{dispatch_args} ;
}

sub handle_request {
  my ($self, $cgi) = @_;

  # 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}) ) {
    # 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}});
    $capture->stop;
    my $stdout = join "\x0d\x0a", $capture->read;
    my $response = $self->_build_response( $stdout );
    print $response->as_string;
  }

}

# Shamelessly stolen from HTTP::Request::AsCGI by chansen
sub _build_response {
    my ( $self, $stdout ) = @_;

    $stdout =~ s{(.*?\x0d?\x0a\x0d?\x0a)}{}xsm;
    my $headers = $1;

    unless ( defined $headers ) {
        $headers = "HTTP/1.1 500 Internal Server Error\x0d\x0a";
    }

    unless ( $headers =~ /^HTTP/ ) {
        $headers = "HTTP/1.1 200 OK\x0d\x0a" . $headers;
    }

    my $response = HTTP::Response->parse($headers);
    $response->date( time() ) unless $response->date;

    my $message = $response->message;
    my $status  = $response->header('Status');

    $response->header( Connection => 'close' );

    if ( $message && $message =~ /^(.+)\x0d$/ ) {
        $response->message($1);
    }

    if ( $status && $status =~ /^(\d\d\d)\s?(.+)?$/ ) {

        my $code    = $1;
           $message = $2 || HTTP::Status::status_message($code);

        $response->code($code);
        $response->message($message);
    }

    my $length = length $stdout;

    if ( $response->code == 500 && !$length ) {

        $response->content( $response->error_as_HTML );
        $response->content_type('text/html');

        return $response;
    }

    $response->add_content($stdout);
    $response->content_length($length);

    return $response;
}


1;

__END__