$caller

[catagits/Catalyst-Runtime.git] / lib / Catalyst / Engine / Server.pm

package Catalyst::Engine::Server;

use strict;
use base 'Catalyst::Engine::CGI';

=head1 NAME

Catalyst::Engine::Server - Catalyst Server Engine

=head1 SYNOPSIS

See L<Catalyst>.

=head1 DESCRIPTION

This is the Catalyst engine specialized for development and testing.

=head1 OVERLOADED METHODS

This class overloads some methods from C<Catalyst::Engine::CGI>.

=over 4

=item $c->run

=cut

sub run {
    my $class  = shift;
    my $port   = shift || 3000;
    my $script = shift;

    my $server = Catalyst::Engine::Server::Simple->new($port);

    $server->handler( sub { $script ? print `$script` : $class->handler } );
    $server->run;
}

=back

=head1 SEE ALSO

L<Catalyst>, L<HTTP::Server::Simple>.

=head1 AUTHOR

Sebastian Riedel, C<sri@cpan.org>
Christian Hansen, C<ch@ngmedia.com>

=head1 COPYRIGHT

This program is free software, you can redistribute it and/or modify it under
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;