File Coverage

blib/lib/Plack/Middleware/Lint.pm
Criterion Covered Total %
statement 96 108 88.8
branch 56 72 77.7
condition 29 41 70.7
subroutine 13 13 100.0
pod 1 5 20.0
total 195 239 81.5


line stmt bran cond sub pod time code
1             package Plack::Middleware::Lint;
2 44     44   133050 use strict;
  44         92  
  44         1096  
3 44     44   215 no warnings;
  44         48  
  44         1084  
4 44     44   178 use Carp ();
  44         85  
  44         682  
5 44     44   493 use parent qw(Plack::Middleware);
  44         338  
  44         181  
6 44     44   1660 use Scalar::Util qw(blessed reftype);
  44         48  
  44         1694  
7 44     44   183 use Plack::Util;
  44         84  
  44         48215  
8              
9             sub wrap {
10 27     27 0 4320 my($self, $app) = @_;
11              
12 27 50 33     86 unless (reftype $app eq 'CODE' or overload::Method($app, '&{}')) {
13 0 0       0 die("PSGI app should be a code reference: ", (defined $app ? $app : "undef"));
14             }
15              
16 27         73 $self->SUPER::wrap($app);
17             }
18              
19             sub call {
20 34     34 1 52 my $self = shift;
21 34         46 my $env = shift;
22              
23 34         83 $self->validate_env($env);
24 26         93 my $res = $self->app->($env);
25 26         196 return $self->validate_res($res);
26             }
27              
28             sub validate_env {
29 34     34 0 64 my ($self, $env) = @_;
30 34 100       62 unless ($env->{REQUEST_METHOD}) {
31 1         7 die('Missing env param: REQUEST_METHOD');
32             }
33 33 100       125 unless ($env->{REQUEST_METHOD} =~ /^[A-Z]+$/) {
34 1         7 die("Invalid env param: REQUEST_METHOD($env->{REQUEST_METHOD})");
35             }
36 32 50       61 unless (defined($env->{SCRIPT_NAME})) { # allows empty string
37 0         0 die('Missing mandatory env param: SCRIPT_NAME');
38             }
39 32 100       82 if ($env->{SCRIPT_NAME} eq '/') {
40 1         8 die('SCRIPT_NAME must not be /');
41             }
42 31 50       50 unless (defined($env->{PATH_INFO})) { # allows empty string
43 0         0 die('Missing mandatory env param: PATH_INFO');
44             }
45 31 100 100     179 if ($env->{PATH_INFO} ne '' && $env->{PATH_INFO} !~ m!^/!) {
46 1         6 die('PATH_INFO must begin with / ($env->{PATH_INFO})');
47             }
48 30 50       56 unless (defined($env->{SERVER_NAME})) {
49 0         0 die('Missing mandatory env param: SERVER_NAME');
50             }
51 30 50       57 if ($env->{SERVER_NAME} eq '') {
52 0         0 die('SERVER_NAME must not be empty string');
53             }
54 30 100       44 unless (defined($env->{SERVER_PORT})) {
55 1         6 die('Missing mandatory env param: SERVER_PORT');
56             }
57 29 50       60 if ($env->{SERVER_PORT} eq '') {
58 0         0 die('SERVER_PORT must not be empty string');
59             }
60 29 100 66     117 if (defined($env->{SERVER_PROTOCOL}) and $env->{SERVER_PROTOCOL} !~ m{^HTTP/\d}) {
61 1         7 die("Invalid SERVER_PROTOCOL: $env->{SERVER_PROTOCOL}");
62             }
63 28         52 for my $param (qw/version url_scheme input errors multithread multiprocess/) {
64 168 50       315 unless (exists $env->{"psgi.$param"}) {
65 0         0 die("Missing psgi.$param");
66             }
67             }
68 28 100       60 unless (ref($env->{'psgi.version'}) eq 'ARRAY') {
69 1         7 die("psgi.version should be ArrayRef: $env->{'psgi.version'}");
70             }
71 27 50       37 unless (scalar(@{$env->{'psgi.version'}}) == 2) {
  27         49  
72 0         0 die('psgi.version should contain 2 elements, not ', scalar(@{$env->{'psgi.version'}}));
  0         0  
73             }
74 27 50       89 unless ($env->{'psgi.url_scheme'} =~ /^https?$/) {
75 0         0 die("psgi.url_scheme should be 'http' or 'https': ", $env->{'psgi.url_scheme'});
76             }
77 27 50       56 if ($env->{"psgi.version"}->[1] == 1) { # 1.1
78 27         44 for my $param (qw(streaming nonblocking run_once)) {
79 81 50       145 unless (exists $env->{"psgi.$param"}) {
80 0         0 die("Missing psgi.$param");
81             }
82             }
83             }
84 27 100       47 if ($env->{HTTP_CONTENT_TYPE}) {
85 1         6 die('HTTP_CONTENT_TYPE should not exist');
86             }
87 26 50       57 if ($env->{HTTP_CONTENT_LENGTH}) {
88 0         0 die('HTTP_CONTENT_LENGTH should not exist');
89             }
90             }
91              
92             sub is_possibly_fh {
93 5     5 0 42 my $fh = shift;
94              
95             ref $fh eq 'GLOB' &&
96 1         7 *{$fh}{IO} &&
97 5 100 100     44 *{$fh}{IO}->can('getline');
  1         16  
98             }
99              
100             sub validate_res {
101 28     28 0 45 my ($self, $res, $streaming) = @_;
102              
103 28 100 100     85 unless (ref($res) eq 'ARRAY' or ref($res) eq 'CODE') {
104 1         17 die("Response should be array ref or code ref: $res");
105             }
106              
107 27 100       56 if (ref $res eq 'CODE') {
108 2     2   16 return $self->response_cb($res, sub { $self->validate_res(@_, 1) });
  2         5  
109             }
110              
111 25 50 33     51 unless (@$res == 3 || ($streaming && @$res == 2)) {
      66        
112 1         7 die('Response needs to be 3 element array, or 2 element in streaming');
113             }
114              
115 24 100 66     134 unless ($res->[0] =~ /^\d+$/ && $res->[0] >= 100) {
116 1         9 die("Status code needs to be an integer greater than or equal to 100: $res->[0]");
117             }
118              
119 23 100       56 unless (ref $res->[1] eq 'ARRAY') {
120 1         8 die("Headers needs to be an array ref: $res->[1]");
121             }
122              
123 22         27 my @copy = @{$res->[1]};
  22         44  
124 22 100       62 unless (@copy % 2 == 0) {
125 1         9 die('The number of response headers needs to be even, not odd(', scalar(@copy), ')');
126             }
127              
128 21         67 while(my($key, $val) = splice(@copy, 0, 2)) {
129 16 100       34 if (lc $key eq 'status') {
130 1         9 die('Response headers MUST NOT contain a key named Status');
131             }
132 15 100       59 if ($key =~ /[:\r\n]|[-_]$/) {
133 4         34 die("Response headers MUST NOT contain a key with : or newlines, or that end in - or _. Header: $key");
134             }
135 11 100       45 unless ($key =~ /^[a-zA-Z][0-9a-zA-Z\-_]*$/) {
136 2         19 die("Response headers MUST consist only of letters, digits, _ or - and MUST start with a letter. Header: $key");
137             }
138 9 100       25 if ($val =~ /[\000-\037]/) {
139 2         20 die("Response headers MUST NOT contain characters below octal \037. Header: $key. Value: $val");
140             }
141 7 100       26 unless (defined $val) {
142 2         20 die("Response headers MUST be a defined string. Header: $key");
143             }
144             }
145              
146             # @$res == 2 is only right in psgi.streaming, and it's already checked.
147 10 50 66     56 unless (@$res == 2 ||
      66        
      100        
      33        
      66        
148             ref $res->[2] eq 'ARRAY' ||
149             Plack::Util::is_real_fh($res->[2]) ||
150             is_possibly_fh($res->[2]) ||
151             (blessed($res->[2]) && $res->[2]->can('getline'))) {
152 4         64 die("Body should be an array ref or filehandle: $res->[2]");
153             }
154              
155 6 100 100     26 if (ref $res->[2] eq 'ARRAY' && grep _has_wide_char($_), @{$res->[2]}) {
  5         17  
156 1         8 die("Body must be bytes and should not contain wide characters (UTF-8 strings)");
157             }
158              
159 5         25 return $res;
160             }
161              
162             # NOTE: Some modules like HTML:: or XML:: could possibly generate
163             # ASCII/Latin-1 strings with utf8 flags on. They're actually safe to
164             # print, so there's no need to give warnings about it.
165             sub _has_wide_char {
166 5     5   10 my $str = shift;
167 5 100       40 utf8::is_utf8($str) && $str =~ /[^\x00-\xff]/;
168             }
169              
170             1;
171             __END__