File Coverage

blib/lib/Mojo/Server/CGI.pm
Criterion Covered Total %
statement 36 36 100.0
branch 12 20 60.0
condition 7 16 43.7
subroutine 3 3 100.0
pod 1 1 100.0
total 59 76 77.6


line stmt bran cond sub pod time code
1             package Mojo::Server::CGI;
2 2     2   480 use Mojo::Base 'Mojo::Server';
  2         5  
  2         17  
3              
4             has 'nph';
5              
6             sub run {
7 9     9 1 18 my $self = shift;
8              
9 9         27 $self->app->server($self);
10 9         29 my $tx = $self->build_tx;
11 9         22 my $req = $tx->req->parse(\%ENV);
12 9         43 $tx->local_port($ENV{SERVER_PORT})->remote_address($ENV{REMOTE_ADDR});
13              
14             # Request body (may block if we try to read too much)
15 9         36 binmode STDIN;
16 9         25 my $len = $req->headers->content_length;
17 9         24 until ($req->is_finished) {
18 1 50 33     9 my $chunk = ($len && $len < 131072) ? $len : 131072;
19 1 50       16 last unless my $read = STDIN->read(my $buffer, $chunk, 0);
20 1         16 $req->parse($buffer);
21 1 50       6 last if ($len -= $read) <= 0;
22             }
23              
24 9         34 $self->emit(request => $tx);
25              
26             # Response start-line
27 9         56 STDOUT->autoflush(1);
28 9         379 binmode STDOUT;
29 9         29 my $res = $tx->res->fix_headers;
30 9 50 66     24 return undef if $self->nph && !_write($res, 'get_start_line_chunk');
31              
32             # Response headers
33 9   50     19 my $code = $res->code || 404;
34 9   33     26 my $msg = $res->message || $res->default_message;
35 9 100       24 $res->headers->status("$code $msg") unless $self->nph;
36 9 50       26 return undef unless _write($res, 'get_header_chunk');
37              
38             # Response body
39 9 50 66     30 return undef unless $tx->is_empty || _write($res, 'get_body_chunk');
40              
41             # Finish transaction
42 9         35 $tx->closed;
43              
44 9         26 return $res->code;
45             }
46              
47             sub _write {
48 18     18   43 my ($res, $method) = @_;
49              
50 18         30 my $offset = 0;
51 18         33 while (1) {
52              
53             # No chunk yet, try again
54 43 50 0     147 sleep 1 and next unless defined(my $chunk = $res->$method($offset));
55              
56             # End of part
57 43 100       111 last unless my $len = length $chunk;
58              
59             # Make sure we can still write
60 25         41 $offset += $len;
61 25 50       91 return undef unless STDOUT->opened;
62 25         198 print STDOUT $chunk;
63             }
64              
65 18         57 return 1;
66             }
67              
68             1;
69              
70             =encoding utf8
71              
72             =head1 NAME
73              
74             Mojo::Server::CGI - CGI server
75              
76             =head1 SYNOPSIS
77              
78             use Mojo::Server::CGI;
79              
80             my $cgi = Mojo::Server::CGI->new;
81             $cgi->unsubscribe('request')->on(request => sub ($cgi, $tx) {
82              
83             # Request
84             my $method = $tx->req->method;
85             my $path = $tx->req->url->path;
86              
87             # Response
88             $tx->res->code(200);
89             $tx->res->headers->content_type('text/plain');
90             $tx->res->body("$method request for $path!");
91              
92             # Resume transaction
93             $tx->resume;
94             });
95             $cgi->run;
96              
97             =head1 DESCRIPTION
98              
99             L is a simple and portable implementation of L.
100              
101             See L for more.
102              
103             =head1 EVENTS
104              
105             L inherits all events from L.
106              
107             =head1 ATTRIBUTES
108              
109             L inherits all attributes from L and implements the following new ones.
110              
111             =head2 nph
112              
113             my $bool = $cgi->nph;
114             $cgi = $cgi->nph($bool);
115              
116             Activate non-parsed header mode.
117              
118             =head1 METHODS
119              
120             L inherits all methods from L and implements the following new ones.
121              
122             =head2 run
123              
124             my $status = $cgi->run;
125              
126             Run CGI.
127              
128             =head1 SEE ALSO
129              
130             L, L, L.
131              
132             =cut