Coverage Summary

# File Coverage

blib/lib/Prancer/Response.pm
Criterion | Covered | Total | %
--- | --- | --- | ---
statement | 18 | 89 | 20.2
branch | 0 | 36 | 0.0
condition | 0 | 9 | 0.0
subroutine | 6 | 16 | 37.5
pod | 6 | 7 | 85.7
total | 30 | 157 | 19.1

line | stmt | bran | cond | sub | pod | time | code
--- | --- | --- | --- | --- | --- | --- | ---
1 |  |  |  |  |  |  | package Prancer::Response;
2 |  |  |  |  |  |  |
3 | 4 |  |  | 4 |  | 10 | use strict;
| 4 |  |  |  |  | 5 |
| 4 |  |  |  |  | 111 |
4 | 4 |  |  | 4 |  | 10 | use warnings FATAL => 'all';
| 4 |  |  |  |  | 4 |
| 4 |  |  |  |  | 99 |
5 |  |  |  |  |  |  |
6 | 4 |  |  | 4 |  | 9 | use Carp;
| 4 |  |  |  |  | 4 |
| 4 |  |  |  |  | 204 |
7 | 4 |  |  | 4 |  | 831 | use Plack::Response;
| 4 |  |  |  |  | 5166 |
| 4 |  |  |  |  | 94 |
8 | 4 |  |  | 4 |  | 12 | use Hash::MultiValue;
| 4 |  |  |  |  | 4 |
| 4 |  |  |  |  | 51 |
9 | 4 |  |  | 4 |  | 10 | use URI::Escape ();
| 4 |  |  |  |  | 3 |
| 4 |  |  |  |  | 3239 |
10 |  |  |  |  |  |  |
11 |  |  |  |  |  |  | sub new {
12 | 0 |  |  | 0 | 0 |  | my ($class, $env) = @_;
13 | 0 |  |  |  |  |  | return bless({
14 |  |  |  |  |  |  | '_response' => Plack::Response->new($env),
15 |  |  |  |  |  |  | '_cookies' => Hash::MultiValue->new(),
16 |  |  |  |  |  |  | '_headers' => Hash::MultiValue->new(),
17 |  |  |  |  |  |  | }, $class);
18 |  |  |  |  |  |  | }
19 |  |  |  |  |  |  |
20 |  |  |  |  |  |  | # set a single header
21 |  |  |  |  |  |  | # or get all the keys
22 |  |  |  |  |  |  | sub header {
23 | 0 |  |  | 0 | 1 |  | my $self = shift;
24 |  |  |  |  |  |  |
25 |  |  |  |  |  |  | # return the keys if nothing is asked for
26 | 0 | 0 |  |  |  |  | return keys(%{$self->headers()}) unless @_;
| 0 |  |  |  |  |  |
27 |  |  |  |  |  |  |
28 |  |  |  |  |  |  | # if given just a key return that
29 | 0 | 0 |  |  |  |  | if (@_ == 1) {
30 | 0 |  |  |  |  |  | my $key = shift;
31 | 0 | 0 |  |  |  |  | return $self->headers->{$key} unless wantarray;
32 | 0 |  |  |  |  |  | return $self->headers->get_all($key);
33 |  |  |  |  |  |  | }
34 |  |  |  |  |  |  |
35 |  |  |  |  |  |  | # if we are given multiple args assume they are headers in key/value pairs
36 | 0 | 0 |  |  |  |  | croak "odd number of headers" unless (@_ % 2 == 0);
37 | 0 |  |  |  |  |  | while (@_) {
38 | 0 |  |  |  |  |  | my ($key, $value) = (shift(@_), shift(@_));
39 | 0 | 0 |  |  |  |  | $self->headers->add($key => [@{$self->headers->get_all($key) || []}, $value]);
| 0 |  |  |  |  |  |
40 |  |  |  |  |  |  | }
41 |  |  |  |  |  |  |
42 | 0 |  |  |  |  |  | return;
43 |  |  |  |  |  |  | }
44 |  |  |  |  |  |  |
45 |  |  |  |  |  |  | # get all the headers that have been set
46 |  |  |  |  |  |  | sub headers {
47 | 0 |  |  | 0 | 1 |  | my $self = shift;
48 | 0 |  |  |  |  |  | return $self->{'_headers'};
49 |  |  |  |  |  |  | }
50 |  |  |  |  |  |  |
51 |  |  |  |  |  |  | # set a single cookie
52 |  |  |  |  |  |  | # or get all the keys
53 |  |  |  |  |  |  | sub cookie {
54 | 0 |  |  | 0 | 1 |  | my $self = shift;
55 |  |  |  |  |  |  |
56 |  |  |  |  |  |  | # return the keys if nothing is asked for
57 | 0 | 0 |  |  |  |  | return keys(%{$self->cookies()}) unless @_;
| 0 |  |  |  |  |  |
58 |  |  |  |  |  |  |
59 |  |  |  |  |  |  | # if given just a key return that
60 | 0 | 0 |  |  |  |  | if (@_ == 1) {
61 | 0 |  |  |  |  |  | my $key = shift;
62 | 0 | 0 |  |  |  |  | return $self->cookies->{$key} unless wantarray;
63 | 0 |  |  |  |  |  | return $self->cookies->get_all($key);
64 |  |  |  |  |  |  | }
65 |  |  |  |  |  |  |
66 |  |  |  |  |  |  | # if we are given multiple args assume they are cookies in key/value pairs
67 | 0 | 0 |  |  |  |  | croak "odd number of cookies" unless (@_ % 2 == 0);
68 | 0 |  |  |  |  |  | while (@_) {
69 | 0 |  |  |  |  |  | my ($key, $value) = (shift(@_), shift(@_));
70 |  |  |  |  |  |  |
71 |  |  |  |  |  |  | # take a moment to validate the cookie
72 |  |  |  |  |  |  | # TODO
73 |  |  |  |  |  |  |
74 | 0 | 0 |  |  |  |  | $self->cookies->add($key => [@{$self->cookies->get_all($key) || []}, $value]);
| 0 |  |  |  |  |  |
75 |  |  |  |  |  |  | }
76 |  |  |  |  |  |  |
77 | 0 |  |  |  |  |  | return;
78 |  |  |  |  |  |  | }
79 |  |  |  |  |  |  |
80 |  |  |  |  |  |  | sub cookies {
81 | 0 |  |  | 0 | 1 |  | my $self = shift;
82 | 0 |  |  |  |  |  | return $self->{'_cookies'};
83 |  |  |  |  |  |  | }
84 |  |  |  |  |  |  |
85 |  |  |  |  |  |  | sub body {
86 | 0 |  |  | 0 | 1 |  | my $self = shift;
87 |  |  |  |  |  |  |
88 |  |  |  |  |  |  | # make the response be a callback
89 | 0 | 0 | 0 |  |  |  | if (ref($_[0]) && ref($_[0]) eq "CODE") {
90 | 0 |  |  |  |  |  | $self->{'_callback'} = shift;
91 | 0 |  |  |  |  |  | return;
92 |  |  |  |  |  |  | }
93 |  |  |  |  |  |  |
94 |  |  |  |  |  |  | # just add this to the body, whatever it is
95 | 0 |  |  |  |  |  | return $self->{'_response'}->body(@_);
96 |  |  |  |  |  |  | }
97 |  |  |  |  |  |  |
98 |  |  |  |  |  |  | sub finalize {
99 | 0 |  |  | 0 | 1 |  | my ($self, $status) = @_;
100 | 0 |  |  |  |  |  | $self->{'_response'}->status($status);
101 |  |  |  |  |  |  |
102 |  |  |  |  |  |  | # add headers
103 | 0 |  |  |  |  |  | for my $key (keys %{$self->headers()}) {
| 0 |  |  |  |  |  |
104 | 0 |  |  |  |  |  | for my $value (@{$self->headers->get_all($key)}) {
| 0 |  |  |  |  |  |
105 | 0 |  |  |  |  |  | $self->{'_response'}->header($key => $value);
106 |  |  |  |  |  |  | }
107 |  |  |  |  |  |  | }
108 |  |  |  |  |  |  |
109 |  |  |  |  |  |  | # add cookies
110 | 0 |  |  |  |  |  | for my $key (keys %{$self->cookies()}) {
| 0 |  |  |  |  |  |
111 | 0 |  |  |  |  |  | for my $value (@{$self->cookies->get_all($key)}) {
| 0 |  |  |  |  |  |
112 | 0 |  |  |  |  |  | $self->{'_response'}->header('Set-Cookie', $self->_bake_cookie($key, $value));
113 |  |  |  |  |  |  | }
114 |  |  |  |  |  |  | }
115 |  |  |  |  |  |  |
116 | 0 | 0 | 0 |  |  |  | if (defined($self->{'_callback'}) &&
|  |  | 0 |  |  |  |
117 |  |  |  |  |  |  | ref($self->{'_callback'}) &&
118 |  |  |  |  |  |  | ref($self->{'_callback'}) eq "CODE") {
119 |  |  |  |  |  |  |
120 |  |  |  |  |  |  | # empty the body out just in case
121 | 0 |  |  |  |  |  | $self->{'_response'}->body("");
122 |  |  |  |  |  |  |
123 |  |  |  |  |  |  | return sub {
124 | 0 |  |  | 0 |  |  | my $responder = shift;
125 |  |  |  |  |  |  | # finalize will always return a three element array. the third
126 |  |  |  |  |  |  | # element is supposed to be the body. because we don't have a body
127 |  |  |  |  |  |  | # yet (it's in the callback) use splice to exclude the third
128 |  |  |  |  |  |  | # element (aka the body) and just return the status code and the
129 |  |  |  |  |  |  | # list of headers.
130 | 0 |  |  |  |  |  | my $writer = $responder->([splice(@{$self->{'_response'}->finalize()}, 0, 2)]);
| 0 |  |  |  |  |  |
131 | 0 |  |  |  |  |  | return $self->{'_callback'}->($writer);
132 |  |  |  |  |  |  | }
133 | 0 |  |  |  |  |  | }
134 |  |  |  |  |  |  |
135 |  |  |  |  |  |  | # just return a normal response
136 | 0 |  |  |  |  |  | return $self->{'_response'}->finalize();
137 |  |  |  |  |  |  | }
138 |  |  |  |  |  |  |
139 |  |  |  |  |  |  | sub _bake_cookie {
140 | 0 |  |  | 0 |  |  | my ($self, $key, $value) = @_;
141 |  |  |  |  |  |  |
142 | 0 |  |  |  |  |  | my @cookie = (URI::Escape::uri_escape($key) . "=" . URI::Escape::uri_escape($value->{'value'}));
143 | 0 | 0 |  |  |  |  | push(@cookie, "domain=" . $value->{'domain'}) if $value->{'domain'};
144 | 0 | 0 |  |  |  |  | push(@cookie, "path=" . $value->{'path'}) if $value->{'path'};
145 | 0 | 0 |  |  |  |  | push(@cookie, "expires=" . $self->_cookie_date($self->expires())) if $value->{'expires'};
146 | 0 | 0 |  |  |  |  | push(@cookie, "secure") if $value->{'secure'};
147 | 0 | 0 |  |  |  |  | push(@cookie, "HttpOnly") if $value->{'httponly'};
148 | 0 |  |  |  |  |  | return join("; ", @cookie);
149 |  |  |  |  |  |  |
150 |  |  |  |  |  |  | }
151 |  |  |  |  |  |  |
152 |  |  |  |  |  |  | my @MON = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
153 |  |  |  |  |  |  | my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );
154 |  |  |  |  |  |  |
155 |  |  |  |  |  |  | sub _cookie_date {
156 | 0 |  |  | 0 |  |  | my ($self, $expires) = @_;
157 |  |  |  |  |  |  |
158 | 0 | 0 |  |  |  |  | if ($expires =~ /^\d+$/x) {
159 |  |  |  |  |  |  | # all numbers -> epoch date
160 |  |  |  |  |  |  | # (cookies use '-' as date separator, HTTP uses ' ')
161 | 0 |  |  |  |  |  | my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($expires);
162 | 0 |  |  |  |  |  | $year += 1900;
163 |  |  |  |  |  |  |
164 | 0 |  |  |  |  |  | return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
165 |  |  |  |  |  |  | $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
166 |  |  |  |  |  |  | }
167 |  |  |  |  |  |  |
168 | 0 |  |  |  |  |  | return $expires;
169 |  |  |  |  |  |  | }
170 |  |  |  |  |  |  |
171 |  |  |  |  |  |  | 1;
172 |  |  |  |  |  |  |
173 |  |  |  |  |  |  | =head1 NAME
174 |  |  |  |  |  |  |
175 |  |  |  |  |  |  | Prancer::Response
176 |  |  |  |  |  |  |
177 |  |  |  |  |  |  | =head1 SYNOPSIS
178 |  |  |  |  |  |  |
179 |  |  |  |  |  |  | sub handle {
180 |  |  |  |  |  |  |
181 |  |  |  |  |  |  | ...
182 |  |  |  |  |  |  |
183 |  |  |  |  |  |  | my $response = context->response();
184 |  |  |  |  |  |  | status(Prancer::Const::OK);
185 |  |  |  |  |  |  | response->header("Content-Type" => "text/plain");
186 |  |  |  |  |  |  | response->body("hello, goodbye");
187 |  |  |  |  |  |  | finalize;
188 |  |  |  |  |  |  | }
189 |  |  |  |  |  |  |
190 |  |  |  |  |  |  | # or using a callback
191 |  |  |  |  |  |  | sub handle {
192 |  |  |  |  |  |  |
193 |  |  |  |  |  |  | ...
194 |  |  |  |  |  |  |
195 |  |  |  |  |  |  | status(Prancer::Const::OK);
196 |  |  |  |  |  |  | $response->header("Content-Type" => "text/plain");
197 |  |  |  |  |  |  | $response->callback(sub {
198 |  |  |  |  |  |  | my $writer = shift;
199 |  |  |  |  |  |  | $writer->write("What's up?");
200 |  |  |  |  |  |  | $writer->close();
201 |  |  |  |  |  |  | });
202 |  |  |  |  |  |  | finalize;
203 |  |  |  |  |  |  | }
204 |  |  |  |  |  |  |
205 |  |  |  |  |  |  | =head1 ATTRIBUTES
206 |  |  |  |  |  |  |
207 |  |  |  |  |  |  | =over 4
208 |  |  |  |  |  |  |
209 |  |  |  |  |  |  | =item header
210 |  |  |  |  |  |  |
211 |  |  |  |  |  |  | If called with no arguments this will return the names of all headers that have
212 |  |  |  |  |  |  | been set to be sent with the response. Otherwise, this method expects a list of
213 |  |  |  |  |  |  | headers to add to the response. For example:
214 |  |  |  |  |  |  |
215 |  |  |  |  |  |  | $response->header("Content-Type" => "text/plain");
216 |  |  |  |  |  |  | $response->header("Content-Length" => 1234, "X-Foo" => "bar");
217 |  |  |  |  |  |  |
218 |  |  |  |  |  |  | If the header has already been set this will add another value to it and the
219 |  |  |  |  |  |  | response will include the same header multiple times. To replace a header that
220 |  |  |  |  |  |  | has already been set, remove the existing value first:
221 |  |  |  |  |  |  |
222 |  |  |  |  |  |  | $response->headers->remove("X-Foo");
223 |  |  |  |  |  |  |
224 |  |  |  |  |  |  | =item headers
225 |  |  |  |  |  |  |
226 |  |  |  |  |  |  | Returns a L<Hash::MultiValue> of all headers that have been set to be sent with
227 |  |  |  |  |  |  | the response.
228 |  |  |  |  |  |  |
229 |  |  |  |  |  |  | =item cookie
230 |  |  |  |  |  |  |
231 |  |  |  |  |  |  | If called with no arguments this will return the names of all cookes that have
232 |  |  |  |  |  |  | been set to be sent with the response. Otherwise, this method expects a list of
233 |  |  |  |  |  |  | cookies to add to the response. For example:
234 |  |  |  |  |  |  |
235 |  |  |  |  |  |  | $response->cookie('foo' => {
236 |  |  |  |  |  |  | 'value' => 'test',
237 |  |  |  |  |  |  | 'path' => "/",
238 |  |  |  |  |  |  | 'domain' => '.example.com',
239 |  |  |  |  |  |  | 'expires' => time + 24 * 60 * 60,
240 |  |  |  |  |  |  | });
241 |  |  |  |  |  |  |
242 |  |  |  |  |  |  | The hashref may contain things such as C<value>, C<domain>, C<expires>,
243 |  |  |  |  |  |  | C<path>, C<httponly>, and C<secure>. C<expires> can take a string or an integer
244 |  |  |  |  |  |  | (as an epoch time) and B<does not> convert string formats like C<+3M>.
245 |  |  |  |  |  |  |
246 |  |  |  |  |  |  | =item cookies
247 |  |  |  |  |  |  |
248 |  |  |  |  |  |  | Returns a L<Hash::MultiValue> of all cookies that have been set to be sent with
249 |  |  |  |  |  |  | the response.
250 |  |  |  |  |  |  |
251 |  |  |  |  |  |  | =item body
252 |  |  |  |  |  |  |
253 |  |  |  |  |  |  | Send buffered output to the client. Anything sent to the client with this
254 |  |  |  |  |  |  | method will be buffered until C<finalize> is called. For example:
255 |  |  |  |  |  |  |
256 |  |  |  |  |  |  | $response->body("hello");
257 |  |  |  |  |  |  | $response->body("goodbye", "world");
258 |  |  |  |  |  |  |
259 |  |  |  |  |  |  | The body may also be a callback to send a streaming response to the client.
260 |  |  |  |  |  |  | Any headers or response codes set in the callback will be ignored as they must
261 |  |  |  |  |  |  | all be set beforehand. Any body set before or after a callback is set will also
262 |  |  |  |  |  |  | be ignored. For example:
263 |  |  |  |  |  |  |
264 |  |  |  |  |  |  | $response->body(sub {
265 |  |  |  |  |  |  | my $writer = shift;
266 |  |  |  |  |  |  | $writer->write("Hello, world!");
267 |  |  |  |  |  |  | $writer->close();
268 |  |  |  |  |  |  | });
269 |  |  |  |  |  |  |
270 |  |  |  |  |  |  | =item finalize
271 |  |  |  |  |  |  |
272 |  |  |  |  |  |  | This requires one argument: the HTTP status code of the response. It will then
273 |  |  |  |  |  |  | send a PSGI compatible result. For example:
274 |  |  |  |  |  |  |
275 |  |  |  |  |  |  | # send a 200 response
276 |  |  |  |  |  |  | $response->finalize(Prancer::Const::OK);
277 |  |  |  |  |  |  |
278 |  |  |  |  |  |  | # or hard code it
279 |  |  |  |  |  |  | $response->finalize(405);
280 |  |  |  |  |  |  |
281 |  |  |  |  |  |  | =back
282 |  |  |  |  |  |  |
283 |  |  |  |  |  |  | =cut
284 |  |  |  |  |  |  |