File Coverage

blib/lib/Net/Server/PSGI.pm

Criterion	Covered	Total	%
statement	76	96	79.1
branch	10	24	41.6
condition	4	18	22.2
subroutine	14	18	77.7
pod	7	12	58.3
total	111	168	66.0

# -*- perl -*-
#
#  Net::Server::PSGI - Extensible Perl HTTP PSGI base server
#
#  Copyright (C) 2011-2022
#
#    Paul Seamons
#
#  This package may be distributed under the terms of either the
#  GNU General Public License
#    or the
#  Perl Artistic License
#
################################################################

package Net::Server::PSGI;

use strict;
use base qw(Net::Server::HTTP);
use Scalar::Util qw(blessed);

sub net_server_type { __PACKAGE__ }

sub options {
    my $self = shift;
    my $ref  = $self->SUPER::options(@_);
    my $prop = $self->{'server'};
    $ref->{$_} = \$prop->{$_} for qw(app);
    return $ref;
}

sub post_configure {
    my $self = shift;
    my $prop = $self->{'server'};

    $prop->{'log_handle'} = IO::Handle->new;
    $prop->{'log_handle'}->fdopen(fileno(STDERR), "w");
    $prop->{'no_client_stdout'} = 1;

    $self->SUPER::post_configure(@_);
}

sub _tie_client_stdout {} # the client should not print directly

sub process_request {
    my $self = shift;

    local $SIG{'ALRM'} = sub { die "Server Timeout\n" };
    my $ok = eval {
        alarm($self->timeout_header);
        $self->process_headers;

        alarm($self->timeout_idle);
        my $env = { %ENV };
        $env->{'psgi.version'}      = [1, 0];
        $env->{'psgi.url_scheme'}   = ($ENV{'HTTPS'} && $ENV{'HTTPS'} eq 'on') ? 'https' : 'http';
        $env->{'psgi.input'}        = $self->{'server'}->{'client'};
        $env->{'psgi.errors'}       = $self->{'server'}->{'log_handle'};
        $env->{'psgi.multithread'}  = 1;
        $env->{'psgi.multiprocess'} = 1;
        $env->{'psgi.nonblocking'}  = 1; # need to make this false if we aren't of a forking type server
        $env->{'psgi.streaming'}    = 1;
        local %ENV;
        $self->process_psgi_request($env);
        alarm(0);
        1;
    };
    alarm(0);

    if (! $ok) {
        my $err = "$@" || "Something happened";
        $self->send_500($err);
        die $err;
    }
}

sub process_psgi_request {
    my ($self, $env) = @_;
    my $app = $self->find_psgi_handler($env);
    my $resp = $app->($env);
    return $resp->(sub {
        my $resp = shift;
        $self->print_psgi_headers($resp->[0], $resp->[1]);
        return $self->{'server'}->{'client'} if @$resp == 2;
        return $self->print_psgi_body($resp->[2]);
    }) if ref($resp) eq 'CODE';
    $self->print_psgi_headers($resp->[0], $resp->[1]);
    $self->print_psgi_body($resp->[2]);
}

sub find_psgi_handler { shift->app || \&psgi_echo_handler }

sub app {
    my $self = shift;
    $self->{'server'}->{'app'} = shift if @_;
    my $app = $self->{'server'}->{'app'};
    if (!ref($app) && $app) {
        $app = $self->{'server'}->{'app'} = eval { require CGI::Compile; CGI::Compile->compile($app) }
            || die "Failed to compile app with CGI::Compile";
    }
    return $app;
}

sub print_psgi_headers {
    my ($self, $status, $headers) = @_;
    $headers ||= [];
    $self->send_status({
        status => $status,
        headers => [map {[@$headers[$_*2, $_*2+1]]} 0 .. $#$headers / 2],
    });
}

sub print_psgi_body {
    my ($self, $body) = @_;
    my $client = $self->{'server'}->{'client'};
    my $request_info = $self->{'request_info'};
    if (ref $body eq 'ARRAY') {
        for my $chunk (@$body) {
            $client->print($chunk);
            $request_info->{'response_size'} += length $chunk;
        }
    } elsif (blessed($body) && $body->can('getline')) {
        while (defined(my $chunk = $body->getline)) {
            $client->print($chunk);
            $request_info->{'response_size'} += length $chunk;
        }
    } else {
        while (defined(my $chunk = <$body>)) {
            $client->print($chunk);
            $request_info->{'response_size'} += length $chunk;
        }
    }
}

sub psgi_echo_handler {
    my $env = shift;
    if ($env->{'PATH_INFO'} && $env->{'PATH_INFO'} eq '/simple') {
        return [200, [content_type => 'text/html'], ['Simple']];
    }
    my $txt = qq{\n};
    if (eval { require Data::Dumper }) {
        local $Data::Dumper::Sortkeys = 1;
        my $form = {};
        if (eval { require CGI::PSGI }) {  my $q = CGI::PSGI->new($env); $form->{$_} = $q->param($_) for $q->param;  }
        $txt .= "".Data::Dumper->Dump([$env, $form], ['env', 'form'])."";
    }
    return [200, ['Content-type', 'text/html'], [$txt]];
}

sub exec_cgi { die "Not implemented" }
sub exec_trusted_perl { die "Not implemented" }

1;

__END__