File Coverage

blib/lib/Gantry/Server.pm

Criterion	Covered	Total	%
statement	18	86	20.9
branch	0	12	0.0
condition	0	13	0.0
subroutine	6	19	31.5
pod	9	9	100.0
total	33	139	23.7

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

Not Found
The requested URL $ENV{PATH_INFO} was not found on this server.

$@
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;

=head1 NAME

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

=head1 SYNOPSIS

    #!/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();

=head1 DESCRIPTION

This module subclasses HTTP::Server::Simple::CGI to provide a stand
alone server for any Gantry app.  Pretend you are deploying to a CGI
environment, but replace

    $cgi_engine->dispatch();

with

    use Gantry::Server;

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

Note that you must call set_engine_object before calling run, and you
must pass it a valid Gantry::Engine::CGI object with the proper
locations and config definitions.

By default, your server will start on port 8080.  If you want a different
port, pass it to the constructor.  You can generate the above script,
with port control, in bigtop by doing this in your config section:

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

=head1 METHODS

=over 4

=item set_engine_object

You must call this before calling run.  Pass it a Gantry::Engine::CGI object.

=item run

This starts the server and never returns.

=item handler

This method overrides the parent version to avoid taking form parameters
prematurely.

=item handle_request

This method functions as a little web server processing http requests
(but it leans heavily on HTTP::Server::Simple::CGI).

=item handle_request_test

This method pretends to be a web server, but only handles a single request
before returning.  This is useful for testing your Gantry app without
having to use sockets.

=item handle_request_test_post

This is the same as handle_request_test, but it treats the request as a POST.
This is mainly used for form testing.

=item handle_request_test_xml

This method is like C, but for SOAP packets.  Call
it with the location you want to hit and the XML packet to PUT there.
Returns whatever the server returns.

=item net_server

Retrieves the defined Net::Sever engine type

=item set_net_server

optionaly you can set a Net::Sever engine type ( see Net::Server ).

 $server->set_net_server( 'Net::Server::PreForkSimple' );

=item setup_server_url

Builds and sets the SERVER_URL environment variable.

=back

=head1 AUTHOR

Phil Crow

=head1 COPYRIGHT and LICENSE

Copyright (c) 2006, Phil Crow.

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.6 or,
at your option, any later version of Perl 5 you may have available.

=cut