File Coverage

blib/lib/HTTP/Server/Simple/PSGI.pm
Criterion Covered Total %
statement 11 46 23.9
branch 0 18 0.0
condition 0 2 0.0
subroutine 4 12 33.3
pod 1 2 50.0
total 16 80 20.0


line stmt bran cond sub pod time code
1             package HTTP::Server::Simple::PSGI;
2 1     1   16604 use strict;
  1         2  
  1         23  
3 1     1   16 use 5.005_03;
  1         2  
4 1     1   4 use vars qw($VERSION);
  1         7  
  1         75  
5             $VERSION = '0.15';
6              
7 1     1   4 use base qw/HTTP::Server::Simple::CGI/;
  1         1  
  1         455  
8              
9             # copied from HTTP::Status
10             my %StatusCode = (
11             100 => 'Continue',
12             101 => 'Switching Protocols',
13             102 => 'Processing', # RFC 2518 (WebDAV)
14             200 => 'OK',
15             201 => 'Created',
16             202 => 'Accepted',
17             203 => 'Non-Authoritative Information',
18             204 => 'No Content',
19             205 => 'Reset Content',
20             206 => 'Partial Content',
21             207 => 'Multi-Status', # RFC 2518 (WebDAV)
22             300 => 'Multiple Choices',
23             301 => 'Moved Permanently',
24             302 => 'Found',
25             303 => 'See Other',
26             304 => 'Not Modified',
27             305 => 'Use Proxy',
28             307 => 'Temporary Redirect',
29             400 => 'Bad Request',
30             401 => 'Unauthorized',
31             402 => 'Payment Required',
32             403 => 'Forbidden',
33             404 => 'Not Found',
34             405 => 'Method Not Allowed',
35             406 => 'Not Acceptable',
36             407 => 'Proxy Authentication Required',
37             408 => 'Request Timeout',
38             409 => 'Conflict',
39             410 => 'Gone',
40             411 => 'Length Required',
41             412 => 'Precondition Failed',
42             413 => 'Request Entity Too Large',
43             414 => 'Request-URI Too Large',
44             415 => 'Unsupported Media Type',
45             416 => 'Request Range Not Satisfiable',
46             417 => 'Expectation Failed',
47             422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
48             423 => 'Locked', # RFC 2518 (WebDAV)
49             424 => 'Failed Dependency', # RFC 2518 (WebDAV)
50             425 => 'No code', # WebDAV Advanced Collections
51             426 => 'Upgrade Required', # RFC 2817
52             449 => 'Retry with', # unofficial Microsoft
53             500 => 'Internal Server Error',
54             501 => 'Not Implemented',
55             502 => 'Bad Gateway',
56             503 => 'Service Unavailable',
57             504 => 'Gateway Timeout',
58             505 => 'HTTP Version Not Supported',
59             506 => 'Variant Also Negotiates', # RFC 2295
60             507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
61             509 => 'Bandwidth Limit Exceeded', # unofficial
62             510 => 'Not Extended', # RFC 2774
63             );
64              
65             sub app {
66 0     0 0   my $self = shift;
67 0 0         $self->{psgi_app} = shift if @_;
68 0           $self->{psgi_app};
69             }
70              
71             sub handler {
72 0     0 1   my $self = shift;
73              
74             my $env = {
75             CONTENT_LENGTH => $ENV{CONTENT_LENGTH},
76             CONTENT_TYPE => $ENV{CONTENT_TYPE},
77             SCRIPT_NAME => '',
78             REQUEST_METHOD => $ENV{REQUEST_METHOD},
79             PATH_INFO => $ENV{PATH_INFO},
80             QUERY_STRING => $ENV{QUERY_STRING},
81             REQUEST_URI => $ENV{REQUEST_URI},
82             SERVER_NAME => $ENV{SERVER_NAME},
83             SERVER_PORT => $ENV{SERVER_PORT},
84             SERVER_PROTOCOL => $ENV{SERVER_PROTOCOL},
85             REMOTE_ADDR => $ENV{REMOTE_ADDR},
86             HTTP_COOKIE => $ENV{COOKIE}, # HTTP::Server::Simple bug
87 0           'psgi.version' => [1,1],
88             'psgi.url_scheme' => 'http',
89             'psgi.input' => $self->stdin_handle,
90             'psgi.errors' => *STDERR,
91             'psgi.multithread' => 0,
92             'psgi.multiprocess' => 0,
93             'psgi.run_once' => 0,
94             'psgi.streaming' => 1,
95             'psgi.nonblocking' => 0,
96             'psgix.io' => $self->stdio_handle,
97             };
98              
99 0           while (my ($k, $v) = each %ENV) {
100 0 0         $env->{$k} = $v if $k =~ /^HTTP_/;
101             }
102              
103 0   0       my $res = eval { $self->{psgi_app}->($env) }
104             || [ 500, [ 'Content-Type', 'text/plain' ], [ "Internal Server Error" ] ];
105              
106 0 0         if (ref $res eq 'ARRAY') {
    0          
107 0           $self->_handle_response($res);
108             } elsif (ref $res eq 'CODE') {
109             $res->(sub {
110 0     0     $self->_handle_response($_[0]);
111 0           });
112             } else {
113 0           die "Bad response $res";
114             }
115             }
116              
117             sub _handle_response {
118 0     0     my ($self, $res) = @_;
119              
120 0           my $message = $StatusCode{$res->[0]};
121              
122 0           my $response = "HTTP/1.0 $res->[0] $message\015\012";
123 0           my $headers = $res->[1];
124 0           while (my ($k, $v) = splice(@$headers, 0, 2)) {
125 0           $response .= "$k: $v\015\012";
126             }
127 0           $response .= "\015\012";
128              
129 0           print STDOUT $response;
130              
131 0           my $body = $res->[2];
132 0     0     my $cb = sub { print STDOUT $_[0] };
  0            
133              
134 0 0         if (defined $body) {
135 0 0         if (ref $body eq 'ARRAY') {
136 0           for my $line (@$body) {
137 0 0         $cb->($line) if length $line;
138             }
139             } else {
140 0 0         local $/ = \65536 unless ref $/;
141 0           while (defined(my $line = $body->getline)) {
142 0 0         $cb->($line) if length $line;
143             }
144 0           $body->close;
145             }
146             } else {
147 0           return HTTP::Server::Simple::PSGI::Writer->new($cb);
148             }
149             }
150              
151             package HTTP::Server::Simple::PSGI::Writer;
152              
153 0     0     sub new { bless $_[1], $_[0] }
154 0     0     sub write { $_[0]->($_[1]) }
155       0     sub close { }
156              
157             package HTTP::Server::Simple::PSGI;
158              
159             1;
160              
161             __END__