line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Devel::hdb::Server; |
2
|
|
|
|
|
|
|
|
3
|
4
|
|
|
4
|
|
22
|
use strict; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
96
|
|
4
|
4
|
|
|
4
|
|
18
|
use warnings; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
87
|
|
5
|
|
|
|
|
|
|
|
6
|
4
|
|
|
4
|
|
1691
|
use HTTP::Server::PSGI; |
|
4
|
|
|
|
|
106906
|
|
|
4
|
|
|
|
|
196
|
|
7
|
|
|
|
|
|
|
our @ISA = qw( HTTP::Server::PSGI ); |
8
|
|
|
|
|
|
|
|
9
|
4
|
|
|
4
|
|
30
|
use Socket qw(IPPROTO_TCP TCP_NODELAY); |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
2460
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '0.23_15'; |
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub new { |
14
|
1
|
|
|
1
|
0
|
3
|
my($class, %args) = @_; |
15
|
|
|
|
|
|
|
|
16
|
1
|
|
|
|
|
2
|
my %supplied_port_arg; |
17
|
1
|
50
|
|
|
|
3
|
if (exists $args{port}) { |
18
|
0
|
|
|
|
|
0
|
$supplied_port_arg{port} = delete $args{port}; |
19
|
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
|
21
|
1
|
|
|
|
|
10
|
my $self = $class->SUPER::new(%args); |
22
|
1
|
50
|
|
|
|
18
|
if (%supplied_port_arg) { |
23
|
0
|
|
|
|
|
0
|
$self->{port} = $supplied_port_arg{port}; |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
|
26
|
1
|
50
|
|
|
|
2
|
$self->{listen_sock} = $args{listen_sock} if exists $args{listen_sock}; |
27
|
1
|
|
|
|
|
3
|
return $self; |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
sub accept_loop { |
31
|
0
|
|
|
0
|
0
|
|
my($self, $app) = @_; |
32
|
|
|
|
|
|
|
|
33
|
0
|
|
|
|
|
|
$app = Plack::Middleware::ContentLength->wrap($app); |
34
|
|
|
|
|
|
|
|
35
|
0
|
|
|
|
|
|
while (1) { |
36
|
0
|
|
|
|
|
|
local $SIG{PIPE} = 'IGNORE'; |
37
|
0
|
0
|
|
|
|
|
if (my $conn = $self->{listen_sock}->accept) { |
38
|
0
|
0
|
|
|
|
|
$conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1) |
39
|
|
|
|
|
|
|
or die "setsockopt(TCP_NODELAY) failed:$!"; |
40
|
|
|
|
|
|
|
my $env = { |
41
|
|
|
|
|
|
|
SERVER_PORT => $self->{port}, |
42
|
|
|
|
|
|
|
SERVER_NAME => $self->{host}, |
43
|
|
|
|
|
|
|
SCRIPT_NAME => '', |
44
|
|
|
|
|
|
|
REMOTE_ADDR => $conn->peerhost, |
45
|
|
|
|
|
|
|
REMOTE_PORT => $conn->peerport || 0, |
46
|
|
|
|
|
|
|
'psgi.version' => [ 1, 1 ], |
47
|
|
|
|
|
|
|
'psgi.errors' => *STDERR, |
48
|
0
|
0
|
0
|
|
|
|
'psgi.url_scheme' => $self->{ssl} ? 'https' : 'http', |
49
|
|
|
|
|
|
|
'psgi.run_once' => Plack::Util::FALSE, |
50
|
|
|
|
|
|
|
'psgi.multithread' => Plack::Util::FALSE, |
51
|
|
|
|
|
|
|
'psgi.multiprocess' => Plack::Util::FALSE, |
52
|
|
|
|
|
|
|
'psgi.streaming' => Plack::Util::TRUE, |
53
|
|
|
|
|
|
|
'psgi.nonblocking' => Plack::Util::FALSE, |
54
|
|
|
|
|
|
|
'psgix.harakiri' => Plack::Util::TRUE, |
55
|
|
|
|
|
|
|
'psgix.input.buffered' => Plack::Util::TRUE, |
56
|
|
|
|
|
|
|
'psgix.io' => $conn, |
57
|
|
|
|
|
|
|
}; |
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
|
$self->handle_connection($env, $conn, $app); |
60
|
|
|
|
|
|
|
#$conn->close; |
61
|
0
|
0
|
|
|
|
|
last if $env->{'psgix.harakiri.commit'}; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
sub _handle_response { |
67
|
0
|
|
|
0
|
|
|
my($self, $res, $conn) = @_; |
68
|
|
|
|
|
|
|
|
69
|
0
|
|
|
|
|
|
my @lines = ( |
70
|
0
|
|
|
|
|
|
"Date: @{[HTTP::Date::time2str()]}\015\012", |
71
|
|
|
|
|
|
|
"Server: $self->{server_software}\015\012", |
72
|
|
|
|
|
|
|
); |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
Plack::Util::header_iter($res->[1], sub { |
75
|
0
|
|
|
0
|
|
|
my ($k, $v) = @_; |
76
|
0
|
|
|
|
|
|
push @lines, "$k: $v\015\012"; |
77
|
0
|
|
|
|
|
|
}); |
78
|
|
|
|
|
|
|
|
79
|
0
|
|
|
|
|
|
unshift @lines, "HTTP/1.0 $res->[0] @{[ HTTP::Status::status_message($res->[0]) ]}\015\012"; |
|
0
|
|
|
|
|
|
|
80
|
0
|
|
|
|
|
|
push @lines, "\015\012"; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
$self->write_all($conn, join('', @lines), $self->{timeout}) |
83
|
0
|
0
|
|
|
|
|
or return; |
84
|
|
|
|
|
|
|
|
85
|
0
|
0
|
|
|
|
|
if (defined $res->[2]) { |
86
|
0
|
|
|
|
|
|
my $err; |
87
|
|
|
|
|
|
|
my $done; |
88
|
|
|
|
|
|
|
{ |
89
|
0
|
|
|
|
|
|
local $@; |
|
0
|
|
|
|
|
|
|
90
|
0
|
|
|
|
|
|
eval { |
91
|
|
|
|
|
|
|
Plack::Util::foreach( |
92
|
|
|
|
|
|
|
$res->[2], |
93
|
|
|
|
|
|
|
sub { |
94
|
|
|
|
|
|
|
$self->write_all($conn, $_[0], $self->{timeout}) |
95
|
0
|
0
|
|
0
|
|
|
or die "failed to send all data\n"; |
96
|
|
|
|
|
|
|
}, |
97
|
0
|
|
|
|
|
|
); |
98
|
0
|
|
|
|
|
|
$done = 1; |
99
|
|
|
|
|
|
|
}; |
100
|
0
|
|
|
|
|
|
$err = $@; |
101
|
|
|
|
|
|
|
}; |
102
|
0
|
0
|
|
|
|
|
if ($done) { |
103
|
0
|
|
|
|
|
|
$conn->close(); |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
} else { |
106
|
0
|
0
|
|
|
|
|
if ($err =~ /^failed to send all data\n/) { |
107
|
0
|
|
|
|
|
|
return; |
108
|
|
|
|
|
|
|
} else { |
109
|
0
|
|
|
|
|
|
die $err; |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
} else { |
113
|
|
|
|
|
|
|
return Plack::Util::inline_object |
114
|
0
|
|
|
0
|
|
|
write => sub { $self->write_all($conn, $_[0], $self->{timeout}) }, |
115
|
0
|
|
|
0
|
|
|
close => sub { $conn->close() }; |
|
0
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
} |
118
|
|
|
|
|
|
|
|
119
|
|
|
|
|
|
|
1; |