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