lib/Catalyst/Engine/Server.pm

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