X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst%2FEngine%2FServer.pm;h=02d96077c3d663dc7efe6ff8577dbbd72d1a4562;hp=20c0bcc7ed7575488ca7f7198d597861173fcab6;hb=45374ac6977e9464410a8c7518fb26ab812258cb;hpb=c9afa5fc4ed6c36afe6653d7d8fbb9909994c1a8 diff --git a/lib/Catalyst/Engine/Server.pm b/lib/Catalyst/Engine/Server.pm index 20c0bcc..02d9607 100644 --- a/lib/Catalyst/Engine/Server.pm +++ b/lib/Catalyst/Engine/Server.pm @@ -1,7 +1,7 @@ package Catalyst::Engine::Server; use strict; -use base 'Catalyst::Engine::CGI::NPH'; +use base 'Catalyst::Engine::HTTP::Daemon'; =head1 NAME @@ -27,31 +27,9 @@ A script using the Catalyst::Engine::Server module might look like: This is the Catalyst engine specialized for development and testing. -=head1 OVERLOADED METHODS - -This class overloads some methods from C. - -=over 4 - -=item $c->run - -=cut - -sub run { - my $class = shift; - my $port = shift || 3000; - - my $server = Catalyst::Engine::Server::Simple->new($port); - - $server->handler( sub { $class->handler } ); - $server->run; -} - -=back - =head1 SEE ALSO -L, L. +L, L. =head1 AUTHOR @@ -65,83 +43,4 @@ the same terms as Perl itself. =cut -package Catalyst::Engine::Server::Simple; - -use strict; -use base 'HTTP::Server::Simple'; - -my %CLEAN_ENV = %ENV; - -sub handler { - my $self = shift; - - if (@_) { - $self->{handler} = shift; - } - - else { - $self->{handler}->(); - } -} - -sub print_banner { - my $self = shift; - - printf( - "You can connect to your server at http://%s:%d/\n", - $self->host || 'localhost', - $self->port - ); -} - -sub accept_hook { - %ENV = ( %CLEAN_ENV, SERVER_SOFTWARE => "Catalyst/$Catalyst::VERSION" ); -} - -our %env_mapping = ( - protocol => "SERVER_PROTOCOL", - localport => "SERVER_PORT", - localname => "SERVER_NAME", - path => "PATH_INFO", - request_uri => "REQUEST_URI", - method => "REQUEST_METHOD", - peeraddr => "REMOTE_ADDR", - peername => "REMOTE_HOST", - query_string => "QUERY_STRING", -); - -sub setup { - no warnings 'uninitialized'; - my $self = shift; - - while ( my ( $item, $value ) = splice @_, 0, 2 ) { - if ( $self->can($item) ) { - $self->$item($value); - } - elsif ( my $k = $env_mapping{$item} ) { - $ENV{$k} = $value; - } - } -} - -sub headers { - my $self = shift; - my $headers = shift; - - while ( my ( $tag, $value ) = splice @{$headers}, 0, 2 ) { - $tag = uc($tag); - $tag =~ s/^COOKIES$/COOKIE/; - $tag =~ s/-/_/g; - $tag = "HTTP_" . $tag - unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/; - - if ( exists $ENV{$tag} ) { - $ENV{$tag} .= "; $value"; - } - else { - $ENV{$tag} = $value; - } - } -} - 1;