1package Gantry::Server;
2use strict; use warnings;
3
4use base qw( HTTP::Server::Simple::CGI );
5
6use Symbol;
7
8my $engine_object;
9my $net_server;
10
11sub set_engine_object {
12    my $self       = shift;
13    $engine_object = shift;
14}
15
16sub set_net_server {
17    my $self       = shift;
18    $net_server    = shift;
19}
20
21sub handler {
22    my $self = shift;
23
24    eval { $self->handle_request() };
25    if ( $@ ) {
26        warn "$@\n";
27    }
28}
29
30sub handle_request_test_xml {
31    my ( $self, $location, $xml ) = @_;
32
33    $engine_object->{__POST_BODY__} = $xml;
34    $ENV{ CONTENT_LENGTH } = 0;
35    $ENV{ REQUEST_METHOD } = 'POST';
36    $ENV{ URI            } = $location;
37    $ENV{ PATH_INFO      } = $location;
38
39    return $self->_test_helper();
40}
41
42sub handle_request_test_post {
43    my ( $self, $request ) = @_;
44
45    my $method = 'POST'; # always GET for tests
46    $request =~ s/^(POST|GET)\://;
47
48    my( $uri, $args ) = split( /\?/, $request );
49
50    $ENV{PATH_INFO}         = $uri || $request;
51    $ENV{REQUEST_METHOD}    = $method;
52    $ENV{CONTENT_LENGTH}    = 0;
53    $ENV{QUERY_STRING}      = ( defined $args ? $args : '' );
54    $ENV{SCRIPT_NAME}       = "";
55
56    return $self->_test_helper();
57}
58
59sub handle_request_test {
60    my ( $self, $request ) = @_;
61
62    my $method = 'GET'; # always GET for tests
63    $request =~ s/^(POST|GET)\://;
64
65    my( $uri, $args ) = split( /\?/, $request );
66
67    $ENV{PATH_INFO}         = $uri || $request;
68    $ENV{REQUEST_METHOD}    = $method;
69    $ENV{CONTENT_LENGTH}    = 0;
70    $ENV{QUERY_STRING}      = ( defined $args ? $args : '' );
71    $ENV{SCRIPT_NAME}       = "";
72
73    return $self->_test_helper();
74}
75
76sub _test_helper {
77    my $self = @_;
78
79    # divert STDOUT to another handle that stores the returned data
80    my $out_handle      = gensym;
81    my $out             = tie   *$out_handle, "Gantry::Server::Tier";
82    my $original_handle = select $out_handle;
83
84    # dispatch to the gantry engine
85    my $status;
86    eval {
87        $status = $engine_object->dispatch();
88    };
89    if ( $@ ) {
90        return( '401', ( "($@)" . ( $out->get_output() ) ) );
91    }
92
93    return( $status, $out->get_output() );
94
95}
96
97sub net_server {
98    $net_server ? $net_server : '';
99}
100
101sub setup_server_url {
102    $ENV{SERVER_URL}
103    ||= (
104        "http://"
105        . ( $ENV{SERVER_NAME} || '' )
106        . ":" . $ENV{SERVER_PORT} . "/"
107    );
108}
109
110sub handle_request {
111    my ( $self  ) = @_;
112
113    # divert STDOUT to another handle that stores the returned data
114    my $out_handle      = gensym;
115    my $out             = tie   *$out_handle, "Gantry::Server::Tier";
116    my $original_handle = select $out_handle;
117
118    # dispatch to the gantry engine
119    my $status;
120    eval {
121        $status = $engine_object->dispatch();
122    };
123    if ( $@ ) {
124        select $original_handle;
125        print <<"EO_FAILURE_RESPONSE";
126HTTP/1.0 401 Not Found
127Content-type: text/html
128
129<h1>Not Found</h1>
130The requested URL $ENV{PATH_INFO} was not found on this server.
131<br />
132$@
133EO_FAILURE_RESPONSE
134        return;
135    }
136
137    select $original_handle;
138
139    print "HTTP/1.0 $status\n" . $out->get_output();
140
141}
142
143package Gantry::Server::Tier;
144use strict;
145
146sub get_output {
147    my $self = shift;
148
149    return $self->[1] || '';
150}
151
152sub TIEHANDLE {
153    my $class = shift;
154    my $self  = [ shift() ];
155
156    return bless $self, $class;
157}
158
159sub PRINT {
160    my $self    = shift;
161
162    no warnings;
163    $self->[1] .= join '', @_;
164}
165
1661;
167
168=head1 NAME
169
170Gantry::Server - HTTP::Server::Simple::CGI subclass providing stand alone server
171
172=head1 SYNOPSIS
173
174    #!/usr/bin/perl
175    use strict;
176
177    use Gantry::Server;
178
179    use lib '/home/myhome/lib';
180
181    use YourApp qw{ -Engine=CGI -TemplateEngine=Default };
182
183    my $cgi_engine = Gantry::Engine::CGI->new();
184    $cgi_engine->add_location( '/', 'YourApp' );
185
186    my $server = Gantry::Server->new();
187    # pass a port number to the above constructor if you don't want 8080.
188
189    $server->set_engine_object( $cgi_engine );
190    $server->run();
191
192=head1 DESCRIPTION
193
194This module subclasses HTTP::Server::Simple::CGI to provide a stand
195alone server for any Gantry app.  Pretend you are deploying to a CGI
196environment, but replace
197
198    $cgi_engine->dispatch();
199
200with
201
202    use Gantry::Server;
203
204    my $server = Gantry::Server->new();
205    $server->set_engine_object( $cgi_engine );
206    $server->run();
207
208Note that you must call set_engine_object before calling run, and you
209must pass it a valid Gantry::Engine::CGI object with the proper
210locations and config definitions.
211
212By default, your server will start on port 8080.  If you want a different
213port, pass it to the constructor.  You can generate the above script,
214with port control, in bigtop by doing this in your config section:
215
216    config {
217        engine CGI;
218        CGI    Gantry { with_server 1; }
219        #...
220    }
221    app YourApp {
222        #...
223    }
224
225=head1 METHODS
226
227=over 4
228
229=item set_engine_object
230
231You must call this before calling run.  Pass it a Gantry::Engine::CGI object.
232
233=item run
234
235This starts the server and never returns.
236
237=item handler
238
239This method overrides the parent version to avoid taking form parameters
240prematurely.
241
242=item handle_request
243
244This method functions as a little web server processing http requests
245(but it leans heavily on HTTP::Server::Simple::CGI).
246
247=item handle_request_test
248
249This method pretends to be a web server, but only handles a single request
250before returning.  This is useful for testing your Gantry app without
251having to use sockets.
252
253=item handle_request_test_post
254
255This is the same as handle_request_test, but it treats the request as a POST.
256This is mainly used for form testing.
257
258=item handle_request_test_xml
259
260This method is like C<handle_request_test>, but for SOAP packets.  Call
261it with the location you want to hit and the XML packet to PUT there.
262Returns whatever the server returns.
263
264=item net_server
265
266Retrieves the defined Net::Sever engine type
267
268=item set_net_server
269
270optionaly you can set a Net::Sever engine type ( see Net::Server ).
271
272 $server->set_net_server( 'Net::Server::PreForkSimple' );
273
274=item setup_server_url
275
276Builds and sets the SERVER_URL environment variable.
277
278=back
279
280=head1 AUTHOR
281
282Phil Crow <philcrow2000@yahoo.com>
283
284=head1 COPYRIGHT and LICENSE
285
286Copyright (c) 2006, Phil Crow.
287
288This library is free software; you can redistribute it and/or modify
289it under the same terms as Perl itself, either Perl version 5.8.6 or,
290at your option, any later version of Perl 5 you may have available.
291
292=cut
293