view release on metacpan or  search on metacpan

lib/HTTP/Message/PSGI.pm  view on Meta::CPAN

our @EXPORT = qw( req_to_psgi res_from_psgi );

use Carp ();
use HTTP::Status qw(status_message);
use URI::Escape ();
use Plack::Util;
use Scalar::Util ();

my $TRUE  = (1 == 1);
my $FALSE = !$TRUE;

sub req_to_psgi {
    my $req = shift;

    unless (Scalar::Util::blessed($req) && $req->isa('HTTP::Request')) {
        Carp::croak("Request is not HTTP::Request: $req");
    }

    # from HTTP::Request::AsCGI
    my $host = $req->header('Host');
    my $uri  = $req->uri->clone;
    $uri->scheme('http')    unless $uri->scheme;
    $uri->host('localhost') unless $uri->host;
    $uri->port(80)          unless $uri->port;
    $uri->host_port($host)  unless !$host || ( $host eq $uri->host_port );

    my $input;
    my $content = $req->content;
    if (ref $content eq 'CODE') {
        if (defined $req->content_length) {
            $input = HTTP::Message::PSGI::ChunkedInput->new($content);
        } else {
            $req->header("Transfer-Encoding" => "chunked");
            $input = HTTP::Message::PSGI::ChunkedInput->new($content, 1);
        }
    } else {
        open $input, "<", \$content;
        $req->content_length(length $content)
            unless defined $req->content_length;
    }

    my $env = {
        PATH_INFO         => URI::Escape::uri_unescape($uri->path || '/'),
        QUERY_STRING      => $uri->query || '',
        SCRIPT_NAME       => '',
        SERVER_NAME       => $uri->host,
        SERVER_PORT       => $uri->port,
        SERVER_PROTOCOL   => $req->protocol || 'HTTP/1.1',
        REMOTE_ADDR       => '127.0.0.1',
        REMOTE_HOST       => 'localhost',
        REMOTE_PORT       => int( rand(64000) + 1000 ),                   # not in RFC 3875
        REQUEST_URI       => $uri->path_query || '/',                     # not in RFC 3875
        REQUEST_METHOD    => $req->method,
        'psgi.version'      => [ 1, 1 ],
        'psgi.url_scheme'   => $uri->scheme eq 'https' ? 'https' : 'http',
        'psgi.input'        => $input,
        'psgi.errors'       => *STDERR,
        'psgi.multithread'  => $FALSE,
        'psgi.multiprocess' => $FALSE,
        'psgi.run_once'     => $TRUE,
        'psgi.streaming'    => $TRUE,
        'psgi.nonblocking'  => $FALSE,
        @_,
    };

    for my $field ( $req->headers->header_field_names ) {
        my $key = uc("HTTP_$field");
        $key =~ tr/-/_/;
        $key =~ s/^HTTP_// if $field =~ /^Content-(Length|Type)$/;

        unless ( exists $env->{$key} ) {
            $env->{$key} = $req->headers->header($field);
        }
    }

    if ($env->{SCRIPT_NAME}) {
        $env->{PATH_INFO} =~ s/^\Q$env->{SCRIPT_NAME}\E/\//;
        $env->{PATH_INFO} =~ s/^\/+/\//;
    }

    if (!defined($env->{HTTP_HOST}) && $req->uri->can('host')) {
        $env->{HTTP_HOST} = $req->uri->host;
        $env->{HTTP_HOST} .= ':' . $req->uri->port
            if $req->uri->port ne $req->uri->default_port;
    }

    return $env;
}

sub res_from_psgi {
    my ($psgi_res) = @_;

    require HTTP::Response;

    my $res;
    if (ref $psgi_res eq 'ARRAY') {
        _res_from_psgi($psgi_res, \$res);
    } elsif (ref $psgi_res eq 'CODE') {
        $psgi_res->(sub {
            _res_from_psgi($_[0], \$res);
        });
    } else {
        Carp::croak("Bad response: ", defined $psgi_res ? $psgi_res : 'undef');
    }

    return $res;
}

sub _res_from_psgi {
    my ($status, $headers, $body) = @{+shift};
    my $res_ref = shift;

    my $convert_resp = sub {
        my $res = HTTP::Response->new($status);
        $res->message(status_message($status));
        $res->headers->header(@$headers) if @$headers;

        if (ref $body eq 'ARRAY') {
            $res->content(join '', grep defined, @$body);
        } else {
            local $/ = \4096;