File Coverage

blib/lib/Devel/hdb/Server.pm
Criterion Covered Total %
statement 19 57 33.3
branch 3 24 12.5
condition 0 2 0.0
subroutine 5 11 45.4
pod 0 2 0.0
total 27 96 28.1


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;