view release on metacpan or  search on metacpan

lib/HTTP/Server/Simple/PSGI.pm  view on Meta::CPAN

    405 => 'Method Not Allowed',
    406 => 'Not Acceptable',
    407 => 'Proxy Authentication Required',
    408 => 'Request Timeout',
    409 => 'Conflict',
    410 => 'Gone',
    411 => 'Length Required',
    412 => 'Precondition Failed',
    413 => 'Request Entity Too Large',
    414 => 'Request-URI Too Large',
    415 => 'Unsupported Media Type',
    416 => 'Request Range Not Satisfiable',
    417 => 'Expectation Failed',
    422 => 'Unprocessable Entity',            # RFC 2518 (WebDAV)
    423 => 'Locked',                          # RFC 2518 (WebDAV)
    424 => 'Failed Dependency',               # RFC 2518 (WebDAV)
    425 => 'No code',                         # WebDAV Advanced Collections
    426 => 'Upgrade Required',                # RFC 2817
    449 => 'Retry with',                      # unofficial Microsoft
    500 => 'Internal Server Error',
    501 => 'Not Implemented',
    502 => 'Bad Gateway',
    503 => 'Service Unavailable',
    504 => 'Gateway Timeout',
    505 => 'HTTP Version Not Supported',
    506 => 'Variant Also Negotiates',         # RFC 2295
    507 => 'Insufficient Storage',            # RFC 2518 (WebDAV)
    509 => 'Bandwidth Limit Exceeded',        # unofficial
    510 => 'Not Extended',                    # RFC 2774
);

sub app {
    my $self = shift;
    $self->{psgi_app} = shift if @_;
    $self->{psgi_app};
}

sub handler {
    my $self = shift;

    my $env = {
        CONTENT_LENGTH  => $ENV{CONTENT_LENGTH},
        CONTENT_TYPE    => $ENV{CONTENT_TYPE},
        SCRIPT_NAME     => '',
        REQUEST_METHOD  => $ENV{REQUEST_METHOD},
        PATH_INFO       => $ENV{PATH_INFO},
        QUERY_STRING    => $ENV{QUERY_STRING},
        REQUEST_URI     => $ENV{REQUEST_URI},
        SERVER_NAME     => $ENV{SERVER_NAME},
        SERVER_PORT     => $ENV{SERVER_PORT},
        SERVER_PROTOCOL => $ENV{SERVER_PROTOCOL},
        REMOTE_ADDR     => $ENV{REMOTE_ADDR},
        HTTP_COOKIE     => $ENV{COOKIE}, # HTTP::Server::Simple bug
        'psgi.version'    => [1,1],
        'psgi.url_scheme' => 'http',
        'psgi.input'      => $self->stdin_handle,
        'psgi.errors'     => *STDERR,
        'psgi.multithread'  => 0,
        'psgi.multiprocess' => 0,
        'psgi.run_once'     => 0,
        'psgi.streaming'    => 1,
        'psgi.nonblocking'  => 0,
        'psgix.io'          => $self->stdio_handle,
    };

    while (my ($k, $v) = each %ENV) {
        $env->{$k} = $v if $k =~ /^HTTP_/;
    }

    my $res = eval { $self->{psgi_app}->($env) }
        || [ 500, [ 'Content-Type', 'text/plain' ], [ "Internal Server Error" ] ];

    if (ref $res eq 'ARRAY') {
        $self->_handle_response($res);
    } elsif (ref $res eq 'CODE') {
        $res->(sub {
            $self->_handle_response($_[0]);
        });
    } else {
        die "Bad response $res";
    }
}

sub _handle_response {
    my ($self, $res) = @_;

    my $message = $StatusCode{$res->[0]};

    my $response = "HTTP/1.0 $res->[0] $message\015\012";
    my $headers = $res->[1];
    while (my ($k, $v) = splice(@$headers, 0, 2)) {
        $response .= "$k: $v\015\012";
    }
    $response .= "\015\012";

    print STDOUT $response;

    my $body = $res->[2];
    my $cb = sub { print STDOUT $_[0] };

    if (defined $body) {
        if (ref $body eq 'ARRAY') {
            for my $line (@$body) {
                $cb->($line) if length $line;
            }
        } else {
            local $/ = \65536 unless ref $/;
            while (defined(my $line = $body->getline)) {
                $cb->($line) if length $line;
            }
            $body->close;
        }
    } else {
        return HTTP::Server::Simple::PSGI::Writer->new($cb);
    }
}

package HTTP::Server::Simple::PSGI::Writer;

sub new   { bless $_[1], $_[0] }
sub write { $_[0]->($_[1]) }