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