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;

=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<handle_request_test>, 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 <philcrow2000@yahoo.com>

=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