Filename | /usr/local/share/perl/5.18.2/HTTP/Headers/Fast.pm |
Statements | Executed 17700429 statements in 33.7s |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
800008 | 3 | 1 | 10.6s | 13.8s | _header_set | HTTP::Headers::Fast::
400004 | 4 | 3 | 8.09s | 24.2s | header | HTTP::Headers::Fast::
1000010 | 2 | 1 | 3.30s | 3.30s | _standardize_field_name | HTTP::Headers::Fast::
100001 | 1 | 1 | 2.98s | 7.31s | scan | HTTP::Headers::Fast::
200002 | 1 | 1 | 2.66s | 3.48s | _header_get | HTTP::Headers::Fast::
200002 | 2 | 2 | 1.78s | 17.4s | new | HTTP::Headers::Fast::
100001 | 1 | 1 | 801ms | 1.44s | _sorted_field_names | HTTP::Headers::Fast::
100001 | 1 | 1 | 719ms | 1.94s | __ANON__[:561] | HTTP::Headers::Fast::
1000010 | 2 | 1 | 718ms | 718ms | CORE:match (opcode) | HTTP::Headers::Fast::
100001 | 1 | 1 | 634ms | 634ms | CORE:sort (opcode) | HTTP::Headers::Fast::
100001 | 1 | 1 | 450ms | 450ms | content_type | HTTP::Headers::Fast::
14 | 2 | 1 | 41µs | 41µs | CORE:subst (opcode) | HTTP::Headers::Fast::
1 | 1 | 1 | 24µs | 33µs | BEGIN@3 | HTTP::Headers::Fast::
1 | 1 | 1 | 21µs | 42µs | BEGIN@2 | HTTP::Headers::Fast::
1 | 1 | 1 | 19µs | 51µs | BEGIN@551 | HTTP::Headers::Fast::
10 | 1 | 1 | 17µs | 17µs | CORE:substcont (opcode) | HTTP::Headers::Fast::
1 | 1 | 1 | 15µs | 15µs | BEGIN@4 | HTTP::Headers::Fast::
1 | 1 | 1 | 6µs | 6µs | BEGIN@5 | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _as_string | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _basic_auth | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _date_header | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _flatten | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _header | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _header_push | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _process_newline | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | _split_header_words | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | as_string | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | as_string_without_sort | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | authorization_basic | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | clear | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | client_date | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | clone | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | content_is_html | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | content_is_xhtml | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | content_is_xml | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | content_type_charset | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | date | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | expires | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | flatten | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | flatten_without_sort | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | header_field_names | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | if_modified_since | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | if_unmodified_since | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | init_header | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | isa | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | last_modified | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | proxy_authorization_basic | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | push_header | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | referer | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | remove_content_headers | HTTP::Headers::Fast::
0 | 0 | 0 | 0s | 0s | remove_header | HTTP::Headers::Fast::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package HTTP::Headers::Fast; | ||||
2 | 2 | 37µs | 2 | 64µs | # spent 42µs (21+22) within HTTP::Headers::Fast::BEGIN@2 which was called:
# once (21µs+22µs) by Plack::Request::BEGIN@7 at line 2 # spent 42µs making 1 call to HTTP::Headers::Fast::BEGIN@2
# spent 22µs making 1 call to strict::import |
3 | 2 | 37µs | 2 | 42µs | # spent 33µs (24+9) within HTTP::Headers::Fast::BEGIN@3 which was called:
# once (24µs+9µs) by Plack::Request::BEGIN@7 at line 3 # spent 33µs making 1 call to HTTP::Headers::Fast::BEGIN@3
# spent 9µs making 1 call to warnings::import |
4 | 2 | 70µs | 1 | 15µs | # spent 15µs within HTTP::Headers::Fast::BEGIN@4 which was called:
# once (15µs+0s) by Plack::Request::BEGIN@7 at line 4 # spent 15µs making 1 call to HTTP::Headers::Fast::BEGIN@4 |
5 | 2 | 4.70ms | 1 | 6µs | # spent 6µs within HTTP::Headers::Fast::BEGIN@5 which was called:
# once (6µs+0s) by Plack::Request::BEGIN@7 at line 5 # spent 6µs making 1 call to HTTP::Headers::Fast::BEGIN@5 |
6 | |||||
7 | 1 | 1µs | our $VERSION = '0.20'; | ||
8 | |||||
9 | 1 | 400ns | our $TRANSLATE_UNDERSCORE = 1; | ||
10 | |||||
11 | # "Good Practice" order of HTTP message headers: | ||||
12 | # - General-Headers | ||||
13 | # - Request-Headers | ||||
14 | # - Response-Headers | ||||
15 | # - Entity-Headers | ||||
16 | |||||
17 | # yappo says "Readonly sucks". | ||||
18 | 1 | 200ns | my $OP_GET = 0; | ||
19 | 1 | 100ns | my $OP_SET = 1; | ||
20 | 1 | 200ns | my $OP_INIT = 2; | ||
21 | 1 | 100ns | my $OP_PUSH = 3; | ||
22 | |||||
23 | 1 | 3µs | my @general_headers = qw( | ||
24 | Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade | ||||
25 | Via Warning | ||||
26 | ); | ||||
27 | |||||
28 | 1 | 6µs | my @request_headers = qw( | ||
29 | Accept Accept-Charset Accept-Encoding Accept-Language | ||||
30 | Authorization Expect From Host | ||||
31 | If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since | ||||
32 | Max-Forwards Proxy-Authorization Range Referer TE User-Agent | ||||
33 | ); | ||||
34 | |||||
35 | 1 | 2µs | my @response_headers = qw( | ||
36 | Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server | ||||
37 | Vary WWW-Authenticate | ||||
38 | ); | ||||
39 | |||||
40 | 1 | 3µs | my @entity_headers = qw( | ||
41 | Allow Content-Encoding Content-Language Content-Length Content-Location | ||||
42 | Content-MD5 Content-Range Content-Type Expires Last-Modified | ||||
43 | ); | ||||
44 | |||||
45 | 1 | 16µs | my %entity_header = map { lc($_) => 1 } @entity_headers; | ||
46 | |||||
47 | 1 | 9µs | my @header_order = | ||
48 | ( @general_headers, @request_headers, @response_headers, @entity_headers, ); | ||||
49 | |||||
50 | # Make alternative representations of @header_order. This is used | ||||
51 | # for sorting and case matching. | ||||
52 | 1 | 400ns | my %header_order; | ||
53 | 1 | 800ns | our %standard_case; | ||
54 | |||||
55 | { | ||||
56 | 2 | 900ns | my $i = 0; | ||
57 | 1 | 1µs | for (@header_order) { | ||
58 | 47 | 15µs | my $lc = lc $_; | ||
59 | 47 | 39µs | $header_order{$lc} = ++$i; | ||
60 | 47 | 43µs | $standard_case{$lc} = $_; | ||
61 | } | ||||
62 | } | ||||
63 | |||||
64 | # spent 17.4s (1.78+15.6) within HTTP::Headers::Fast::new which was called 200002 times, avg 87µs/call:
# 100001 times (1.25s+15.6s) by Plack::Request::headers at line 129 of Plack/Request.pm, avg 169µs/call
# 100001 times (533ms+0s) by Plack::Response::headers at line 34 of Plack/Response.pm, avg 5µs/call | ||||
65 | 200002 | 170ms | my ($class) = shift; | ||
66 | 200002 | 458ms | my $self = bless {}, $class; | ||
67 | 200002 | 433ms | 100001 | 15.6s | $self->header(@_) if @_; # set up initial headers # spent 15.6s making 100001 calls to HTTP::Headers::Fast::header, avg 156µs/call |
68 | 200002 | 803ms | $self; | ||
69 | } | ||||
70 | |||||
71 | sub isa { | ||||
72 | my ($self, $klass) = @_; | ||||
73 | my $proto = ref $self || $self; | ||||
74 | return ($proto eq $klass || $klass eq 'HTTP::Headers') ? 1 : 0; | ||||
75 | } | ||||
76 | |||||
77 | # spent 24.2s (8.09+16.1) within HTTP::Headers::Fast::header which was called 400004 times, avg 60µs/call:
# 100001 times (5.25s+10.4s) by HTTP::Headers::Fast::new at line 67, avg 156µs/call
# 100001 times (917ms+2.26s) by Plack::Response::header at line 53 of Plack/Response.pm, avg 32µs/call
# 100001 times (916ms+1.83s) by PONAPI::Server::_ponapi_query_params at line 242 of lib/PONAPI/Server.pm, avg 27µs/call
# 100001 times (1.01s+1.65s) by PONAPI::Server::_ponapi_check_headers at line 218 of lib/PONAPI/Server.pm, avg 27µs/call | ||||
78 | 400004 | 145ms | my $self = shift; | ||
79 | 400004 | 183ms | Carp::croak('Usage: $h->header($field, ...)') unless @_; | ||
80 | 400004 | 94.2ms | my (@old); | ||
81 | |||||
82 | 400004 | 1.15s | 300003 | 5.74s | if (@_ == 1) { # spent 3.48s making 200002 calls to HTTP::Headers::Fast::_header_get, avg 17µs/call
# spent 2.26s making 100001 calls to HTTP::Headers::Fast::_header_set, avg 23µs/call |
83 | @old = $self->_header_get(@_); | ||||
84 | } elsif( @_ == 2 ) { | ||||
85 | @old = $self->_header_set(@_); | ||||
86 | } else { | ||||
87 | 100001 | 36.2ms | my %seen; | ||
88 | 100001 | 186ms | while (@_) { | ||
89 | 600006 | 177ms | my $field = shift; | ||
90 | 600006 | 1.06s | if ( $seen{ lc $field }++ ) { | ||
91 | @old = $self->_header_push($field, shift); | ||||
92 | } else { | ||||
93 | 600006 | 1.19s | 600006 | 10.4s | @old = $self->_header_set($field, shift); # spent 10.4s making 600006 calls to HTTP::Headers::Fast::_header_set, avg 17µs/call |
94 | } | ||||
95 | } | ||||
96 | } | ||||
97 | 400004 | 145ms | return @old if wantarray; | ||
98 | 400004 | 1.95s | return $old[0] if @old <= 1; | ||
99 | join( ", ", @old ); | ||||
100 | } | ||||
101 | |||||
102 | sub clear { | ||||
103 | my $self = shift; | ||||
104 | %$self = (); | ||||
105 | } | ||||
106 | |||||
107 | sub push_header { | ||||
108 | my $self = shift; | ||||
109 | |||||
110 | if (@_ == 2) { | ||||
111 | my ($field, $val) = @_; | ||||
112 | $field = _standardize_field_name($field) unless $field =~ /^:/; | ||||
113 | |||||
114 | my $h = $self->{$field}; | ||||
115 | if (!defined $h) { | ||||
116 | $h = []; | ||||
117 | $self->{$field} = $h; | ||||
118 | } elsif (ref $h ne 'ARRAY') { | ||||
119 | $h = [ $h ]; | ||||
120 | $self->{$field} = $h; | ||||
121 | } | ||||
122 | |||||
123 | push @$h, ref $val ne 'ARRAY' ? $val : @$val; | ||||
124 | } else { | ||||
125 | while ( my ($field, $val) = splice( @_, 0, 2 ) ) { | ||||
126 | $field = _standardize_field_name($field) unless $field =~ /^:/; | ||||
127 | |||||
128 | my $h = $self->{$field}; | ||||
129 | if (!defined $h) { | ||||
130 | $h = []; | ||||
131 | $self->{$field} = $h; | ||||
132 | } elsif (ref $h ne 'ARRAY') { | ||||
133 | $h = [ $h ]; | ||||
134 | $self->{$field} = $h; | ||||
135 | } | ||||
136 | |||||
137 | push @$h, ref $val ne 'ARRAY' ? $val : @$val; | ||||
138 | } | ||||
139 | } | ||||
140 | return (); | ||||
141 | } | ||||
142 | |||||
143 | sub init_header { | ||||
144 | Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3; | ||||
145 | shift->_header( @_, $OP_INIT ); | ||||
146 | } | ||||
147 | |||||
148 | sub remove_header { | ||||
149 | my ( $self, @fields ) = @_; | ||||
150 | my $field; | ||||
151 | my @values; | ||||
152 | for my $field (@fields) { | ||||
153 | $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE; | ||||
154 | my $v = delete $self->{ lc $field }; | ||||
155 | push( @values, ref($v) eq 'ARRAY' ? @$v : $v ) if defined $v; | ||||
156 | } | ||||
157 | return @values; | ||||
158 | } | ||||
159 | |||||
160 | sub remove_content_headers { | ||||
161 | my $self = shift; | ||||
162 | unless ( defined(wantarray) ) { | ||||
163 | |||||
164 | # fast branch that does not create return object | ||||
165 | delete @$self{ grep $entity_header{$_} || /^content-/, keys %$self }; | ||||
166 | return; | ||||
167 | } | ||||
168 | |||||
169 | my $c = ref($self)->new; | ||||
170 | for my $f ( grep $entity_header{$_} || /^content-/, keys %$self ) { | ||||
171 | $c->{$f} = delete $self->{$f}; | ||||
172 | } | ||||
173 | $c; | ||||
174 | } | ||||
175 | |||||
176 | 1 | 100ns | my %field_name; | ||
177 | # spent 3.30s (3.30+35µs) within HTTP::Headers::Fast::_standardize_field_name which was called 1000010 times, avg 3µs/call:
# 800008 times (2.65s+25µs) by HTTP::Headers::Fast::_header_set at line 208, avg 3µs/call
# 200002 times (650ms+10µs) by HTTP::Headers::Fast::_header_get at line 199, avg 3µs/call | ||||
178 | 1000010 | 301ms | my $field = shift; | ||
179 | |||||
180 | 1000010 | 746ms | $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; | ||
181 | 1000010 | 5.42s | if (my $cache = $field_name{$field}) { | ||
182 | return $cache; | ||||
183 | } | ||||
184 | |||||
185 | 10 | 2µs | my $old = $field; | ||
186 | 10 | 8µs | $field = lc $field; | ||
187 | 10 | 6µs | unless ( defined $standard_case{$field} ) { | ||
188 | # generate a %standard_case entry for this field | ||||
189 | 2 | 81µs | 12 | 35µs | $old =~ s/\b(\w)/\u$1/g; # spent 19µs making 2 calls to HTTP::Headers::Fast::CORE:subst, avg 9µs/call
# spent 17µs making 10 calls to HTTP::Headers::Fast::CORE:substcont, avg 2µs/call |
190 | 2 | 3µs | $standard_case{$field} = $old; | ||
191 | } | ||||
192 | 10 | 10µs | $field_name{$old} = $field; | ||
193 | 10 | 22µs | return $field; | ||
194 | } | ||||
195 | |||||
196 | # spent 3.48s (2.66+824ms) within HTTP::Headers::Fast::_header_get which was called 200002 times, avg 17µs/call:
# 200002 times (2.66s+824ms) by HTTP::Headers::Fast::header at line 82, avg 17µs/call | ||||
197 | 200002 | 182ms | my ($self, $field, $skip_standardize) = @_; | ||
198 | |||||
199 | 200002 | 1.32s | 400004 | 824ms | $field = _standardize_field_name($field) unless $skip_standardize || $field =~ /^:/; # spent 650ms making 200002 calls to HTTP::Headers::Fast::_standardize_field_name, avg 3µs/call
# spent 174ms making 200002 calls to HTTP::Headers::Fast::CORE:match, avg 870ns/call |
200 | |||||
201 | 200002 | 177ms | my $h = $self->{$field}; | ||
202 | 200002 | 1.21s | return (ref($h) eq 'ARRAY') ? @$h : ( defined($h) ? ($h) : () ); | ||
203 | } | ||||
204 | |||||
205 | # spent 13.8s (10.6+3.20) within HTTP::Headers::Fast::_header_set which was called 800008 times, avg 17µs/call:
# 600006 times (8.12s+2.25s) by HTTP::Headers::Fast::header at line 93, avg 17µs/call
# 100001 times (1.57s+682ms) by HTTP::Headers::Fast::header at line 82, avg 23µs/call
# 100001 times (956ms+262ms) by HTTP::Headers::Fast::__ANON__[/usr/local/share/perl/5.18.2/HTTP/Headers/Fast.pm:561] at line 555, avg 12µs/call | ||||
206 | 800008 | 474ms | my ($self, $field, $val) = @_; | ||
207 | |||||
208 | 800008 | 4.78s | 1600016 | 3.20s | $field = _standardize_field_name($field) unless $field =~ /^:/; # spent 2.65s making 800008 calls to HTTP::Headers::Fast::_standardize_field_name, avg 3µs/call
# spent 544ms making 800008 calls to HTTP::Headers::Fast::CORE:match, avg 680ns/call |
209 | |||||
210 | 800008 | 365ms | my $h = $self->{$field}; | ||
211 | 800008 | 679ms | my @old = ref($h) eq 'ARRAY' ? @$h : ( defined($h) ? ($h) : () ); | ||
212 | 800008 | 320ms | if ( defined($val) ) { | ||
213 | 800008 | 198ms | if (ref $val eq 'ARRAY' && scalar(@$val) == 1) { | ||
214 | $val = $val->[0]; | ||||
215 | } | ||||
216 | 800008 | 792ms | $self->{$field} = $val; | ||
217 | } else { | ||||
218 | delete $self->{$field}; | ||||
219 | } | ||||
220 | 800008 | 3.55s | return @old; | ||
221 | } | ||||
222 | |||||
223 | sub _header_push { | ||||
224 | my ($self, $field, $val) = @_; | ||||
225 | |||||
226 | $field = _standardize_field_name($field) unless $field =~ /^:/; | ||||
227 | |||||
228 | my $h = $self->{$field}; | ||||
229 | if (ref($h) eq 'ARRAY') { | ||||
230 | my @old = @$h; | ||||
231 | push @$h, ref $val ne 'ARRAY' ? $val : @$val; | ||||
232 | return @old; | ||||
233 | } elsif (defined $h) { | ||||
234 | $self->{$field} = [$h, ref $val ne 'ARRAY' ? $val : @$val ]; | ||||
235 | return ($h); | ||||
236 | } else { | ||||
237 | $self->{$field} = ref $val ne 'ARRAY' ? $val : @$val; | ||||
238 | return (); | ||||
239 | } | ||||
240 | } | ||||
241 | |||||
242 | sub _header { | ||||
243 | my ($self, $field, $val, $op) = @_; | ||||
244 | |||||
245 | $field = _standardize_field_name($field) unless $field =~ /^:/; | ||||
246 | |||||
247 | $op ||= defined($val) ? $OP_SET : $OP_GET; | ||||
248 | |||||
249 | my $h = $self->{$field}; | ||||
250 | my @old = ref($h) eq 'ARRAY' ? @$h : ( defined($h) ? ($h) : () ); | ||||
251 | |||||
252 | unless ( $op == $OP_GET || ( $op == $OP_INIT && @old ) ) { | ||||
253 | if ( defined($val) ) { | ||||
254 | my @new = ( $op == $OP_PUSH ) ? @old : (); | ||||
255 | if ( ref($val) ne 'ARRAY' ) { | ||||
256 | push( @new, $val ); | ||||
257 | } | ||||
258 | else { | ||||
259 | push( @new, @$val ); | ||||
260 | } | ||||
261 | $self->{$field} = @new > 1 ? \@new : $new[0]; | ||||
262 | } | ||||
263 | elsif ( $op != $OP_PUSH ) { | ||||
264 | delete $self->{$field}; | ||||
265 | } | ||||
266 | } | ||||
267 | @old; | ||||
268 | } | ||||
269 | |||||
270 | # spent 1.44s (801ms+634ms) within HTTP::Headers::Fast::_sorted_field_names which was called 100001 times, avg 14µs/call:
# 100001 times (801ms+634ms) by HTTP::Headers::Fast::scan at line 287, avg 14µs/call | ||||
271 | 100001 | 46.6ms | my $self = shift; | ||
272 | return [ sort { | ||||
273 | 100001 | 1.65s | 100001 | 634ms | ( $header_order{$a} || 999 ) <=> ( $header_order{$b} || 999 ) # spent 634ms making 100001 calls to HTTP::Headers::Fast::CORE:sort, avg 6µs/call |
274 | || $a cmp $b | ||||
275 | } keys %$self ]; | ||||
276 | } | ||||
277 | |||||
278 | sub header_field_names { | ||||
279 | my $self = shift; | ||||
280 | return map $standard_case{$_} || $_, @{ $self->_sorted_field_names } | ||||
281 | if wantarray; | ||||
282 | return keys %$self; | ||||
283 | } | ||||
284 | |||||
285 | # spent 7.31s (2.98+4.33) within HTTP::Headers::Fast::scan which was called 100001 times, avg 73µs/call:
# 100001 times (2.98s+4.33s) by Plack::Response::finalize at line 96 of Plack/Response.pm, avg 73µs/call | ||||
286 | 100001 | 60.4ms | my ( $self, $sub ) = @_; | ||
287 | 100001 | 660ms | 100001 | 1.44s | for my $key (@{ $self->_sorted_field_names }) { # spent 1.44s making 100001 calls to HTTP::Headers::Fast::_sorted_field_names, avg 14µs/call |
288 | 300003 | 224ms | next if substr($key, 0, 1) eq '_'; | ||
289 | 300003 | 132ms | my $vals = $self->{$key}; | ||
290 | 300003 | 200ms | if ( ref($vals) eq 'ARRAY' ) { | ||
291 | for my $val (@$vals) { | ||||
292 | $sub->( $standard_case{$key} || $key, $val ); | ||||
293 | } | ||||
294 | } | ||||
295 | else { | ||||
296 | 300003 | 423ms | 300003 | 2.89s | $sub->( $standard_case{$key} || $key, $vals ); # spent 2.89s making 300003 calls to Plack::Response::__ANON__[Plack/Response.pm:96], avg 10µs/call |
297 | } | ||||
298 | } | ||||
299 | } | ||||
300 | |||||
301 | sub _process_newline { | ||||
302 | local $_ = shift; | ||||
303 | my $endl = shift; | ||||
304 | # must handle header values with embedded newlines with care | ||||
305 | s/\s+$//; # trailing newlines and space must go | ||||
306 | s/\n(\x0d?\n)+/\n/g; # no empty lines | ||||
307 | s/\n([^\040\t])/\n $1/g; # intial space for continuation | ||||
308 | s/\n/$endl/g; # substitute with requested line ending | ||||
309 | $_; | ||||
310 | } | ||||
311 | |||||
312 | sub _as_string { | ||||
313 | my ($self, $endl, $fieldnames) = @_; | ||||
314 | |||||
315 | my @result; | ||||
316 | for my $key ( @$fieldnames ) { | ||||
317 | next if index($key, '_') == 0; | ||||
318 | my $vals = $self->{$key}; | ||||
319 | if ( ref($vals) eq 'ARRAY' ) { | ||||
320 | for my $val (@$vals) { | ||||
321 | my $field = $standard_case{$key} || $key; | ||||
322 | $field =~ s/^://; | ||||
323 | if ( index($val, "\n") >= 0 ) { | ||||
324 | $val = _process_newline($val, $endl); | ||||
325 | } | ||||
326 | push @result, $field . ': ' . $val; | ||||
327 | } | ||||
328 | } else { | ||||
329 | my $field = $standard_case{$key} || $key; | ||||
330 | $field =~ s/^://; | ||||
331 | if ( index($vals, "\n") >= 0 ) { | ||||
332 | $vals = _process_newline($vals, $endl); | ||||
333 | } | ||||
334 | push @result, $field . ': ' . $vals; | ||||
335 | } | ||||
336 | } | ||||
337 | |||||
338 | join( $endl, @result, '' ); | ||||
339 | } | ||||
340 | |||||
341 | sub as_string { | ||||
342 | my ( $self, $endl ) = @_; | ||||
343 | $endl = "\n" unless defined $endl; | ||||
344 | $self->_as_string($endl, $self->_sorted_field_names); | ||||
345 | } | ||||
346 | |||||
347 | sub as_string_without_sort { | ||||
348 | my ( $self, $endl ) = @_; | ||||
349 | $endl = "\n" unless defined $endl; | ||||
350 | $self->_as_string($endl, [keys(%$self)]); | ||||
351 | } | ||||
352 | |||||
353 | sub _flatten { | ||||
354 | my ($self, $keys) = @_; | ||||
355 | my @headers; | ||||
356 | for my $key ( @{$keys} ) { | ||||
357 | next if substr($key, 0, 1) eq '_'; | ||||
358 | my $vals = $self->{$key}; | ||||
359 | if ( ref($vals) eq 'ARRAY' ) { | ||||
360 | for my $val (@$vals) { | ||||
361 | $val =~ s/\015\012[\040|\011]+/chr(32)/ge; # replace LWS with a single SP | ||||
362 | $val =~ s/\015|\012//g; # remove CR and LF since the char is invalid here | ||||
363 | push @headers, $standard_case{$key} || $key, $val; | ||||
364 | } | ||||
365 | } | ||||
366 | else { | ||||
367 | $vals =~ s/\015\012[\040|\011]+/chr(32)/ge; # replace LWS with a single SP | ||||
368 | $vals =~ s/\015|\012//g; # remove CR and LF since the char is invalid here | ||||
369 | push @headers, $standard_case{$key} || $key, $vals; | ||||
370 | } | ||||
371 | } | ||||
372 | return \@headers; | ||||
373 | } | ||||
374 | |||||
375 | sub flatten { | ||||
376 | $_[0]->_flatten($_[0]->_sorted_field_names); | ||||
377 | } | ||||
378 | |||||
379 | |||||
380 | sub flatten_without_sort { | ||||
381 | $_[0]->_flatten([keys %{$_[0]}]); | ||||
382 | } | ||||
383 | |||||
384 | { | ||||
385 | 2 | 1µs | my $storable_required; | ||
386 | sub clone { | ||||
387 | unless ($storable_required) { | ||||
388 | require Storable; | ||||
389 | $storable_required++; | ||||
390 | } | ||||
391 | goto &Storable::dclone; | ||||
392 | } | ||||
393 | } | ||||
394 | |||||
395 | sub _date_header { | ||||
396 | require HTTP::Date; | ||||
397 | my ( $self, $header, $time ) = @_; | ||||
398 | my $old; | ||||
399 | if ( defined $time ) { | ||||
400 | ($old) = $self->_header_set( $header, HTTP::Date::time2str($time) ); | ||||
401 | } else { | ||||
402 | ($old) = $self->_header_get($header, 1); | ||||
403 | } | ||||
404 | $old =~ s/;.*// if defined($old); | ||||
405 | HTTP::Date::str2time($old); | ||||
406 | } | ||||
407 | |||||
408 | sub date { shift->_date_header( 'date', @_ ); } | ||||
409 | sub expires { shift->_date_header( 'expires', @_ ); } | ||||
410 | sub if_modified_since { shift->_date_header( 'if-modified-since', @_ ); } | ||||
411 | sub if_unmodified_since { shift->_date_header( 'if-unmodified-since', @_ ); } | ||||
412 | sub last_modified { shift->_date_header( 'last-modified', @_ ); } | ||||
413 | |||||
414 | # This is used as a private LWP extension. The Client-Date header is | ||||
415 | # added as a timestamp to a response when it has been received. | ||||
416 | sub client_date { shift->_date_header( 'client-date', @_ ); } | ||||
417 | |||||
418 | # The retry_after field is dual format (can also be a expressed as | ||||
419 | # number of seconds from now), so we don't provide an easy way to | ||||
420 | # access it until we have know how both these interfaces can be | ||||
421 | # addressed. One possibility is to return a negative value for | ||||
422 | # relative seconds and a positive value for epoch based time values. | ||||
423 | #sub retry_after { shift->_date_header('Retry-After', @_); } | ||||
424 | |||||
425 | # spent 450ms within HTTP::Headers::Fast::content_type which was called 100001 times, avg 5µs/call:
# 100001 times (450ms+0s) by Plack::Response::content_type at line 60 of Plack/Response.pm, avg 5µs/call | ||||
426 | 100001 | 42.8ms | my $self = shift; | ||
427 | 100001 | 64.4ms | my $ct = $self->{'content-type'}; | ||
428 | 100001 | 110ms | $self->{'content-type'} = shift if @_; | ||
429 | 100001 | 47.3ms | $ct = $ct->[0] if ref($ct) eq 'ARRAY'; | ||
430 | 100001 | 463ms | return '' unless defined($ct) && length($ct); | ||
431 | my @ct = split( /;\s*/, $ct, 2 ); | ||||
432 | for ( $ct[0] ) { | ||||
433 | s/\s+//g; | ||||
434 | $_ = lc($_); | ||||
435 | } | ||||
436 | wantarray ? @ct : $ct[0]; | ||||
437 | } | ||||
438 | |||||
439 | sub content_type_charset { | ||||
440 | my $self = shift; | ||||
441 | my $h = $self->{'content-type'}; | ||||
442 | $h = $h->[0] if ref($h); | ||||
443 | $h = "" unless defined $h; | ||||
444 | my @v = _split_header_words($h); | ||||
445 | if (@v) { | ||||
446 | my($ct, undef, %ct_param) = @{$v[0]}; | ||||
447 | my $charset = $ct_param{charset}; | ||||
448 | if ($ct) { | ||||
449 | $ct = lc($ct); | ||||
450 | $ct =~ s/\s+//; | ||||
451 | } | ||||
452 | if ($charset) { | ||||
453 | $charset = uc($charset); | ||||
454 | $charset =~ s/^\s+//; $charset =~ s/\s+\z//; | ||||
455 | undef($charset) if $charset eq ""; | ||||
456 | } | ||||
457 | return $ct, $charset if wantarray; | ||||
458 | return $charset; | ||||
459 | } | ||||
460 | return undef, undef if wantarray; | ||||
461 | return undef; | ||||
462 | } | ||||
463 | |||||
464 | sub _split_header_words | ||||
465 | { | ||||
466 | my(@val) = @_; | ||||
467 | my @res; | ||||
468 | for (@val) { | ||||
469 | my @cur; | ||||
470 | while (length) { | ||||
471 | if (s/^\s*(=*[^\s=;,]+)//) { # 'token' or parameter 'attribute' | ||||
472 | push(@cur, $1); | ||||
473 | # a quoted value | ||||
474 | if (s/^\s*=\s*\"([^\"\\]*(?:\\.[^\"\\]*)*)\"//) { | ||||
475 | my $val = $1; | ||||
476 | $val =~ s/\\(.)/$1/g; | ||||
477 | push(@cur, $val); | ||||
478 | # some unquoted value | ||||
479 | } | ||||
480 | elsif (s/^\s*=\s*([^;,\s]*)//) { | ||||
481 | my $val = $1; | ||||
482 | $val =~ s/\s+$//; | ||||
483 | push(@cur, $val); | ||||
484 | # no value, a lone token | ||||
485 | } | ||||
486 | else { | ||||
487 | push(@cur, undef); | ||||
488 | } | ||||
489 | } | ||||
490 | elsif (s/^\s*,//) { | ||||
491 | push(@res, [@cur]) if @cur; | ||||
492 | @cur = (); | ||||
493 | } | ||||
494 | elsif (s/^\s*;// || s/^\s+//) { | ||||
495 | # continue | ||||
496 | } | ||||
497 | else { | ||||
498 | die "This should not happen: '$_'"; | ||||
499 | } | ||||
500 | } | ||||
501 | push(@res, \@cur) if @cur; | ||||
502 | } | ||||
503 | |||||
504 | for my $arr (@res) { | ||||
505 | for (my $i = @$arr - 2; $i >= 0; $i -= 2) { | ||||
506 | $arr->[$i] = lc($arr->[$i]); | ||||
507 | } | ||||
508 | } | ||||
509 | return @res; | ||||
510 | } | ||||
511 | |||||
512 | sub content_is_html { | ||||
513 | my $self = shift; | ||||
514 | return $self->content_type eq 'text/html' || $self->content_is_xhtml; | ||||
515 | } | ||||
516 | |||||
517 | sub content_is_xhtml { | ||||
518 | my $ct = shift->content_type; | ||||
519 | return $ct eq "application/xhtml+xml" | ||||
520 | || $ct eq "application/vnd.wap.xhtml+xml"; | ||||
521 | } | ||||
522 | |||||
523 | sub content_is_xml { | ||||
524 | my $ct = shift->content_type; | ||||
525 | return 1 if $ct eq "text/xml"; | ||||
526 | return 1 if $ct eq "application/xml"; | ||||
527 | return 1 if $ct =~ /\+xml$/; | ||||
528 | return 0; | ||||
529 | } | ||||
530 | |||||
531 | sub referer { | ||||
532 | my $self = shift; | ||||
533 | if ( @_ && $_[0] =~ /#/ ) { | ||||
534 | |||||
535 | # Strip fragment per RFC 2616, section 14.36. | ||||
536 | my $uri = shift; | ||||
537 | if ( ref($uri) ) { | ||||
538 | $uri = $uri->clone; | ||||
539 | $uri->fragment(undef); | ||||
540 | } | ||||
541 | else { | ||||
542 | $uri =~ s/\#.*//; | ||||
543 | } | ||||
544 | unshift @_, $uri; | ||||
545 | } | ||||
546 | ( $self->_header( 'Referer', @_ ) )[0]; | ||||
547 | } | ||||
548 | 1 | 2µs | *referrer = \&referer; # on tchrist's request | ||
549 | |||||
550 | 1 | 900ns | for my $key (qw/content-length content-language content-encoding title user-agent server from warnings www-authenticate authorization proxy-authenticate proxy-authorization/) { | ||
551 | 2 | 498µs | 2 | 83µs | # spent 51µs (19+32) within HTTP::Headers::Fast::BEGIN@551 which was called:
# once (19µs+32µs) by Plack::Request::BEGIN@7 at line 551 # spent 51µs making 1 call to HTTP::Headers::Fast::BEGIN@551
# spent 32µs making 1 call to strict::unimport |
552 | 12 | 66µs | 12 | 23µs | (my $meth = $key) =~ s/-/_/g; # spent 23µs making 12 calls to HTTP::Headers::Fast::CORE:subst, avg 2µs/call |
553 | # spent 1.94s (719ms+1.22) within HTTP::Headers::Fast::__ANON__[/usr/local/share/perl/5.18.2/HTTP/Headers/Fast.pm:561] which was called 100001 times, avg 19µs/call:
# 100001 times (719ms+1.22s) by Plack::Response::content_length at line 56 of Plack/Response.pm, avg 19µs/call | ||||
554 | 100001 | 45.5ms | my $self = shift; | ||
555 | 100001 | 828ms | 100001 | 1.22s | if (@_) { # spent 1.22s making 100001 calls to HTTP::Headers::Fast::_header_set, avg 12µs/call |
556 | ( $self->_header_set( $key, @_ ) )[0] | ||||
557 | } else { | ||||
558 | my $h = $self->{$key}; | ||||
559 | (ref($h) eq 'ARRAY') ? $h->[0] : $h; | ||||
560 | } | ||||
561 | 12 | 66µs | }; | ||
562 | } | ||||
563 | |||||
564 | sub authorization_basic { shift->_basic_auth( "Authorization", @_ ) } | ||||
565 | sub proxy_authorization_basic { | ||||
566 | shift->_basic_auth( "Proxy-Authorization", @_ ); | ||||
567 | } | ||||
568 | |||||
569 | sub _basic_auth { | ||||
570 | require MIME::Base64; | ||||
571 | my ( $self, $h, $user, $passwd ) = @_; | ||||
572 | my ($old) = $self->_header($h); | ||||
573 | if ( defined $user ) { | ||||
574 | Carp::croak("Basic authorization user name can't contain ':'") | ||||
575 | if $user =~ /:/; | ||||
576 | $passwd = '' unless defined $passwd; | ||||
577 | $self->_header( | ||||
578 | $h => 'Basic ' . MIME::Base64::encode( "$user:$passwd", '' ) ); | ||||
579 | } | ||||
580 | if ( defined $old && $old =~ s/^\s*Basic\s+// ) { | ||||
581 | my $val = MIME::Base64::decode($old); | ||||
582 | return $val unless wantarray; | ||||
583 | return split( /:/, $val, 2 ); | ||||
584 | } | ||||
585 | return; | ||||
586 | } | ||||
587 | |||||
588 | 1 | 29µs | 1; | ||
589 | __END__ | ||||
sub HTTP::Headers::Fast::CORE:match; # opcode | |||||
# spent 634ms within HTTP::Headers::Fast::CORE:sort which was called 100001 times, avg 6µs/call:
# 100001 times (634ms+0s) by HTTP::Headers::Fast::_sorted_field_names at line 273, avg 6µs/call | |||||
sub HTTP::Headers::Fast::CORE:subst; # opcode | |||||
# spent 17µs within HTTP::Headers::Fast::CORE:substcont which was called 10 times, avg 2µs/call:
# 10 times (17µs+0s) by HTTP::Headers::Fast::_standardize_field_name at line 189, avg 2µs/call |