File Coverage

blib/lib/Net/Server/PSGI.pm
Criterion Covered Total %
statement 84 103 81.5
branch 10 24 41.6
condition 2 13 15.3
subroutine 13 17 76.4
pod 7 12 58.3
total 116 169 68.6


line stmt bran cond sub pod time code
1             # -*- perl -*-
2             #
3             # Net::Server::PSGI - Extensible Perl HTTP PSGI base server
4             #
5             # Copyright (C) 2011-2017
6             #
7             # Paul Seamons
8             #
9             # This package may be distributed under the terms of either the
10             # GNU General Public License
11             # or the
12             # Perl Artistic License
13             #
14             ################################################################
15              
16             package Net::Server::PSGI;
17              
18 2     2   9228 use strict;
  2         10  
  2         56  
19 2     2   10 use base qw(Net::Server::HTTP);
  2         2  
  2         778  
20              
21 1     1 0 3 sub net_server_type { __PACKAGE__ }
22              
23             sub options {
24 2     2 0 5 my $self = shift;
25 2         25 my $ref = $self->SUPER::options(@_);
26 2         3 my $prop = $self->{'server'};
27 2         10 $ref->{$_} = \$prop->{$_} for qw(app);
28 2         3 return $ref;
29             }
30              
31             sub post_configure {
32 1     1 1 1 my $self = shift;
33 1         4 my $prop = $self->{'server'};
34              
35 1         20 $prop->{'log_handle'} = IO::Handle->new;
36 1         59 $prop->{'log_handle'}->fdopen(fileno(STDERR), "w");
37 1         45 $prop->{'no_client_stdout'} = 1;
38              
39 1         13 $self->SUPER::post_configure(@_);
40             }
41              
42       1     sub _tie_client_stdout {} # the client should not print directly
43              
44             sub process_request {
45 1     1 1 2 my $self = shift;
46              
47 1     0   24 local $SIG{'ALRM'} = sub { die "Server Timeout\n" };
  0         0  
48 1         5 my $ok = eval {
49 1         9 alarm($self->timeout_header);
50 1         19 $self->process_headers;
51              
52 1         5 alarm($self->timeout_idle);
53 1         2 my $env = \%ENV;
54 1         4 $env->{'psgi.version'} = [1, 0];
55 1 50 33     6 $env->{'psgi.url_scheme'} = ($ENV{'HTTPS'} && $ENV{'HTTPS'} eq 'on') ? 'https' : 'http';
56 1         7 $env->{'psgi.input'} = $self->{'server'}->{'client'};
57 1         6 $env->{'psgi.errors'} = $self->{'server'}->{'log_handle'};
58 1         6 $env->{'psgi.multithread'} = 1;
59 1         5 $env->{'psgi.multiprocess'} = 1;
60 1         11 $env->{'psgi.nonblocking'} = 1; # need to make this false if we aren't of a forking type server
61 1         6 $env->{'psgi.streaming'} = 1;
62 1         5 local %ENV;
63 1         9 $self->process_psgi_request($env);
64 1         8 alarm(0);
65 1         13 1;
66             };
67 1         3 alarm(0);
68              
69 1 50       13 if (! $ok) {
70 0   0     0 my $err = "$@" || "Something happened";
71 0         0 $self->send_500($err);
72 0         0 die $err;
73             }
74             }
75              
76             sub process_psgi_request {
77 1     1 1 5 my ($self, $env) = @_;
78 1         21 my $app = $self->find_psgi_handler($env);
79 1         4 my $resp = $app->($env);
80             return $resp->(sub {
81 0     0   0 my $resp = shift;
82 0         0 $self->print_psgi_headers($resp->[0], $resp->[1]);
83 0 0       0 return $self->{'server'}->{'client'} if @$resp == 2;
84 0         0 return $self->print_psgi_body($resp->[2]);
85 1 50       5 }) if ref($resp) eq 'CODE';
86 1         18 $self->print_psgi_headers($resp->[0], $resp->[1]);
87 1         12 $self->print_psgi_body($resp->[2]);
88             }
89              
90 1 50   1 1 7 sub find_psgi_handler { shift->app || \&psgi_echo_handler }
91              
92             sub app {
93 1     1 1 2 my $self = shift;
94 1 50       4 $self->{'server'}->{'app'} = shift if @_;
95 1         2 my $app = $self->{'server'}->{'app'};
96 1 50 33     9 if (!ref($app) && $app) {
97 0   0     0 $app = $self->{'server'}->{'app'} = eval { require CGI::Compile; CGI::Compile->compile($app) }
98             || die "Failed to compile app with CGI::Compile";
99             }
100 1         6 return $app;
101             }
102              
103             sub print_psgi_headers {
104 1     1 0 2 my ($self, $status, $headers) = @_;
105 1         12 $self->send_status($status);
106 1         2 my $request_info = $self->{'request_info'};
107 1         2 my $out = '';
108 1 50       2 for my $i (0 .. @{ $headers || [] } / 2 - 1) {
  1         9  
109 1         5 my $key = "\u\L$headers->[$i*2]";
110 1         3 my $val = $headers->[$i*2 + 1];
111 1         3 $key =~ y/_/-/;
112 1         4 $out .= "$key: $val\015\012";
113 1         2 push @{ $request_info->{'response_headers'} }, [$key, $val];
  1         4  
114             }
115 1         2 $out .= "\015\012";
116 1         2 $request_info->{'response_header_size'} += length $out;
117 1         5 $self->{'server'}->{'client'}->print($out);
118 1         36 $request_info->{'headers_sent'} = 1;
119             }
120              
121             sub print_psgi_body {
122 1     1 0 3 my ($self, $body) = @_;
123 1         2 my $client = $self->{'server'}->{'client'};
124 1         1 my $request_info = $self->{'request_info'};
125 1 50 0     4 if (ref $body eq 'ARRAY') {
    0          
126 1         7 for my $chunk (@$body) {
127 1         4 $client->print($chunk);
128 1         36 $request_info->{'response_size'} += length $chunk;
129             }
130             } elsif (blessed($body) && $body->can('getline')) {
131 0         0 while (defined(my $chunk = $body->getline)) {
132 0         0 $client->print($chunk);
133 0         0 $request_info->{'response_size'} += length $chunk;
134             }
135             } else {
136 0         0 while (defined(my $chunk = <$body>)) {
137 0         0 $client->print($chunk);
138 0         0 $request_info->{'response_size'} += length $chunk;
139             }
140             }
141             }
142              
143             sub psgi_echo_handler {
144 1     1 0 2 my $env = shift;
145 1         3 my $txt = qq{
\n};
146 1 50       2 if (eval { require Data::Dumper }) {
  1         421  
147 1         5288 local $Data::Dumper::Sortkeys = 1;
148 1         3 my $form = {};
149 1 50       2 if (eval { require CGI::PSGI }) { my $q = CGI::PSGI->new($env); $form->{$_} = $q->param($_) for $q->param; }
  1         100  
  0         0  
  0         0  
150 1         8 $txt .= "
".Data::Dumper->Dump([$env, $form], ['env', 'form'])."
";
151             }
152 1         113 return [200, ['Content-type', 'text/html'], [$txt]];
153             }
154              
155 0     0 1   sub exec_cgi { die "Not implemented" }
156 0     0 1   sub exec_trusted_perl { die "Not implemented" }
157              
158             1;
159              
160             __END__