File Coverage

blib/lib/Plack/Middleware/ConditionalGET.pm
Criterion Covered Total %
statement 36 36 100.0
branch 14 14 100.0
condition n/a
subroutine 9 9 100.0
pod 1 3 33.3
total 60 62 96.7


line stmt bran cond sub pod time code
1             package Plack::Middleware::ConditionalGET;
2 2     2   12 use strict;
  2         4  
  2         63  
3 2     2   10 use parent qw( Plack::Middleware );
  2         3  
  2         11  
4 2     2   146 use Plack::Util;
  2         4  
  2         503  
5              
6             sub call {
7 11     11 1 21 my $self = shift;
8 11         14 my $env = shift;
9              
10 11         36 my $res = $self->app->($env);
11 11 100       94 return $res unless $env->{REQUEST_METHOD} =~ /^(GET|HEAD)$/;
12              
13             $self->response_cb($res, sub {
14 10     10   15 my $res = shift;
15              
16 10         25 my $h = Plack::Util::headers($res->[1]);
17              
18             # check both ETag and If-Modified-Since, and at least one should exist
19             # and all present headers should match, not either.
20 10 100       32 my @checks = ( $self->etag_matches($h, $env), $self->not_modified_since($h, $env) )
21             or return;
22              
23 9 100       57 unless (grep !$_, @checks) {
24 5         8 $res->[0] = 304;
25 5         29 $h->remove($_) for qw( Content-Type Content-Length Content-Disposition );
26 5 100       11 if ($res->[2]) {
27 4         29 $res->[2] = [];
28             } else {
29             return sub {
30 4 100       17 return defined $_[0] ? '' : undef;
31 1         47 };
32             }
33             }
34 10         59 });
35             }
36              
37 2     2   13 no warnings 'uninitialized';
  2         4  
  2         384  
38              
39             # RFC 2616 14.25 says it's OK and expected to use 'eq' :)
40             # > Note: When handling an If-Modified-Since header field, some
41             # > servers will use an exact date comparison function, rather than a
42             # > less-than function, for deciding whether to send a 304 ...
43              
44             sub etag_matches {
45 10     10 0 14 my($self, $h, $env) = @_;
46 10 100       54 return unless $h->exists('ETag');
47 6         25 $h->get('ETag') eq _value($env->{HTTP_IF_NONE_MATCH});
48             }
49              
50             sub not_modified_since {
51 10     10 0 22 my($self, $h, $env) = @_;
52 10 100       29 return unless $h->exists('Last-Modified');
53 6         20 $h->get('Last-Modified') eq _value($env->{HTTP_IF_MODIFIED_SINCE});
54             }
55              
56             sub _value {
57 12     12   28 my $str = shift;
58             # IE sends wrong formatted value(i.e. "Thu, 03 Dec 2009 01:46:32 GMT; length=17936")
59 12         19 $str =~ s/;.*$//;
60 12         44 return $str;
61             }
62              
63             1;
64              
65             __END__