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