lib/Catalyst/Engine/Server.pm

   1 package Catalyst::Engine::Server;
   2
   3 use strict;
   4 use base 'Catalyst::Engine::CGI::NPH';
   5
   6 =head1 NAME
   7
   8 Catalyst::Engine::Server - Catalyst Server Engine
   9
  10 =head1 SYNOPSIS
  11
  12 See L<Catalyst>.
  13
  14 =head1 DESCRIPTION
  15
  16 This is the Catalyst engine specialized for development and testing.
  17
  18 =head1 OVERLOADED METHODS
  19
  20 This class overloads some methods from C<Catalyst::Engine::CGI::NPH>.
  21
  22 =over 4
  23
  24 =item $c->run
  25
  26 =cut
  27
  28 sub run {
  29     my $class = shift;
  30     my $port  = shift || 3000;
  31
  32     my $server = Catalyst::Engine::Server::Simple->new($port);
  33
  34     $server->handler( sub { $class->handler } );
  35     $server->run;
  36 }
  37
  38 =back
  39
  40 =head1 SEE ALSO
  41
  42 L<Catalyst>, L<HTTP::Server::Simple>.
  43
  44 =head1 AUTHOR
  45
  46 Sebastian Riedel, C<sri@cpan.org>
  47 Christian Hansen, C<ch@ngmedia.com>
  48
  49 =head1 COPYRIGHT
  50
  51 This program is free software, you can redistribute it and/or modify it under
  52 the same terms as Perl itself.
  53
  54 =cut
  55
  56 package Catalyst::Engine::Server::Simple;
  57
  58 use strict;
  59 use base 'HTTP::Server::Simple';
  60
  61 my %CLEAN_ENV = %ENV;
  62
  63 sub handler {
  64     my $self = shift;
  65
  66     if (@_) {
  67         $self->{handler} = shift;
  68     }
  69
  70     else {
  71         $self->{handler}->();
  72     }
  73 }
  74
  75 sub print_banner {
  76     my $self = shift;
  77
  78     printf(
  79         "You can connect to your server at http://%s:%d/\n",
  80         $self->host || 'localhost',
  81         $self->port
  82     );
  83 }
  84
  85 sub accept_hook {
  86     %ENV = ( %CLEAN_ENV, SERVER_SOFTWARE => "Catalyst/$Catalyst::VERSION" );
  87 }
  88
  89 our %env_mapping = (
  90     protocol     => "SERVER_PROTOCOL",
  91     localport    => "SERVER_PORT",
  92     localname    => "SERVER_NAME",
  93     path         => "PATH_INFO",
  94     request_uri  => "REQUEST_URI",
  95     method       => "REQUEST_METHOD",
  96     peeraddr     => "REMOTE_ADDR",
  97     peername     => "REMOTE_HOST",
  98     query_string => "QUERY_STRING",
  99 );
 100
 101 sub setup {
 102     no warnings 'uninitialized';
 103     my $self = shift;
 104
 105     while ( my ( $item, $value ) = splice @_, 0, 2 ) {
 106         if ( $self->can($item) ) {
 107             $self->$item($value);
 108         }
 109         elsif ( my $k = $env_mapping{$item} ) {
 110             $ENV{$k} = $value;
 111         }
 112     }
 113 }
 114
 115 sub headers {
 116     my $self    = shift;
 117     my $headers = shift;
 118
 119     while ( my ( $tag, $value ) = splice @{$headers}, 0, 2 ) {
 120         $tag = uc($tag);
 121         $tag =~ s/^COOKIES$/COOKIE/;
 122         $tag =~ s/-/_/g;
 123         $tag = "HTTP_" . $tag
 124           unless $tag =~ m/^CONTENT_(?:LENGTH|TYPE)$/;
 125
 126         if ( exists $ENV{$tag} ) {
 127             $ENV{$tag} .= "; $value";
 128         }
 129         else {
 130             $ENV{$tag} = $value;
 131         }
 132     }
 133 }
 134
 135 1;