Gantry::Server - HTTP::Server::Simple::CGI subclass providing stand alone server

    #!/usr/bin/perl
    use strict;

    use Gantry::Server;

    use lib '/home/myhome/lib';

    use YourApp qw{ -Engine=CGI -TemplateEngine=Default };

    my $cgi_engine = Gantry::Engine::CGI->new();
    $cgi_engine->add_location( '/', 'YourApp' );

    my $server = Gantry::Server->new();
    # pass a port number to the above constructor if you don't want 8080.

    $server->set_engine_object( $cgi_engine );
    $server->run();

    $cgi_engine->dispatch();

    use Gantry::Server;

    my $server = Gantry::Server->new();
    $server->set_engine_object( $cgi_engine );
    $server->run();

    config {
        engine CGI;
        CGI    Gantry { with_server 1; }
        #...
    }
    app YourApp {
        #...
    }

package Gantry::Server;
use strict; use warnings;

use base qw( HTTP::Server::Simple::CGI );

use Symbol;

my $engine_object;
my $net_server;

sub set_engine_object {
    my $self       = shift;
    $engine_object = shift;
}

sub set_net_server {
    my $self       = shift;
    $net_server    = shift;
}

sub handler {
    my $self = shift;

    eval { $self->handle_request() };
    if ( $@ ) {
        warn "$@\n";
    }
}

sub handle_request_test_xml {
    my ( $self, $location, $xml ) = @_;

    $engine_object->{__POST_BODY__} = $xml;
    $ENV{ CONTENT_LENGTH } = 0;
    $ENV{ REQUEST_METHOD } = 'POST';
    $ENV{ URI            } = $location;
    $ENV{ PATH_INFO      } = $location;

    return $self->_test_helper();
}

sub handle_request_test_post {
    my ( $self, $request ) = @_;

    my $method = 'POST'; # always GET for tests
    $request =~ s/^(POST|GET)\://;
    
    my( $uri, $args ) = split( /\?/, $request );
    
    $ENV{PATH_INFO}         = $uri || $request;
    $ENV{REQUEST_METHOD}    = $method;
    $ENV{CONTENT_LENGTH}    = 0;
    $ENV{QUERY_STRING}      = ( defined $args ? $args : '' );
    $ENV{SCRIPT_NAME}       = "";

    return $self->_test_helper();
}

sub handle_request_test {
    my ( $self, $request ) = @_;

    my $method = 'GET'; # always GET for tests
    $request =~ s/^(POST|GET)\://;
    
    my( $uri, $args ) = split( /\?/, $request );
    
    $ENV{PATH_INFO}         = $uri || $request;
    $ENV{REQUEST_METHOD}    = $method;
    $ENV{CONTENT_LENGTH}    = 0;
    $ENV{QUERY_STRING}      = ( defined $args ? $args : '' );
    $ENV{SCRIPT_NAME}       = "";

    return $self->_test_helper();
}

sub _test_helper {
    my $self = @_;

    # divert STDOUT to another handle that stores the returned data
    my $out_handle      = gensym;
    my $out             = tie   *$out_handle, "Gantry::Server::Tier";
    my $original_handle = select $out_handle;

    # dispatch to the gantry engine
    my $status;
    eval {
        $status = $engine_object->dispatch();
    };
    if ( $@ ) {
        return( '401', ( "($@)" . ( $out->get_output() ) ) );
    }

    return( $status, $out->get_output() );
    
}

sub net_server {
    $net_server ? $net_server : '';    
}

sub setup_server_url {
    $ENV{SERVER_URL}
    ||= ( 
        "http://" 
        . ( $ENV{SERVER_NAME} || '' ) 
        . ":" . $ENV{SERVER_PORT} . "/" 
    );
}

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

    # divert STDOUT to another handle that stores the returned data
    my $out_handle      = gensym;
    my $out             = tie   *$out_handle, "Gantry::Server::Tier";
    my $original_handle = select $out_handle;

    # dispatch to the gantry engine
    my $status;
    eval {
        $status = $engine_object->dispatch();
    };
    if ( $@ ) {
        select $original_handle;
        print <<"EO_FAILURE_RESPONSE";
HTTP/1.0 401 Not Found
Content-type: text/html

<h1>Not Found</h1>
The requested URL $ENV{PATH_INFO} was not found on this server.
<br />
$@
EO_FAILURE_RESPONSE
        return;
    }
    
    select $original_handle;

    print "HTTP/1.0 $status\n" . $out->get_output();

}

package Gantry::Server::Tier;
use strict;

sub get_output {
    my $self = shift;

    return $self->[1] || '';
}

sub TIEHANDLE {
    my $class = shift;
    my $self  = [ shift() ];

    return bless $self, $class;
}

sub PRINT {
    my $self    = shift;

    no warnings;    
    $self->[1] .= join '', @_;
}

1;