File Coverage

blib/lib/CGI/Application/Server.pm

Criterion	Covered	Total	%
statement	28	30	93.3
branch			n/a
condition			n/a
subroutine	10	10	100.0
pod			n/a
total	38	40	95.0

use strict;
use warnings;
package CGI::Application::Server;
{
  $CGI::Application::Server::VERSION = '0.063';
}
# ABSTRACT: a simple HTTP server for developing with CGI::Application

use Carp 0.01 qw( confess );
use CGI qw( param );
use Scalar::Util 1.18 qw( blessed reftype );
use HTTP::Response;
use HTTP::Status;

use base qw( HTTP::Server::Simple::CGI );
use HTTP::Server::Simple 0.18;
use HTTP::Server::Simple::Static 0.02;

# HTTP::Server::Simple methods

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);
    $self->{entry_points} = {};
    $self->{document_root}  = '.';
    return $self;
}

# accessors

sub document_root {
    my ($self, $document_root) = @_;
    if (defined $document_root) {
        (-d $document_root)
            || confess "The server root ($document_root) is not found";
        $self->{document_root} = $document_root;
    }
    $self->{document_root};
}

sub entry_points {
    my ($self, $entry_points) = @_;
    if (defined $entry_points) {
        (reftype($entry_points) && reftype($entry_points) eq 'HASH')
            || confess "The entry points map must be a HASH reference, not $entry_points";
        $self->{entry_points} = $entry_points;
    }
    $self->{entry_points};
}

# check request

sub is_valid_entry_point {
    my ($self, $uri) = @_;

    # Remove all parameters
    $uri =~ s/\?.*//;

    while ( $uri ) {
        # Check to see if this is an exact match
        if (exists $self->{entry_points}{$uri}) {
            return ($uri, $self->{entry_points}{$uri});
        }

        # Remove the rightmost path element
        $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;
}

sub handle_request {
    my ($self, $cgi) = @_;
    if (my ($path, $target) = $self->is_valid_entry_point($ENV{REQUEST_URI})) {
        # warn "$ENV{REQUEST_URI} ($target)\n";
        # warn "\t$_ => " . param( $_ ) . "\n" for param();

        local $ENV{CGI_APP_RETURN_ONLY} = 1;
        (local $ENV{PATH_INFO} = $ENV{PATH_INFO}) =~ s/\A\Q$path//;

        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) {
	    return $self->_serve_response($target->new->run);
          } else {
        $target->query($cgi);
	    return $self->_serve_response($target->run);
          }
	}
	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";
        }
    } 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 ) = @_;

    $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__