← Index
NYTProf Performance Profile   « line view »
For script/ponapi
  Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename/usr/local/share/perl/5.18.2/HTTP/Headers/Fast.pm
StatementsExecuted 17700429 statements in 33.7s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
8000083110.6s13.8sHTTP::Headers::Fast::::_header_setHTTP::Headers::Fast::_header_set
400004438.09s24.2sHTTP::Headers::Fast::::headerHTTP::Headers::Fast::header
1000010213.30s3.30sHTTP::Headers::Fast::::_standardize_field_nameHTTP::Headers::Fast::_standardize_field_name
100001112.98s7.31sHTTP::Headers::Fast::::scanHTTP::Headers::Fast::scan
200002112.66s3.48sHTTP::Headers::Fast::::_header_getHTTP::Headers::Fast::_header_get
200002221.78s17.4sHTTP::Headers::Fast::::newHTTP::Headers::Fast::new
10000111801ms1.44sHTTP::Headers::Fast::::_sorted_field_namesHTTP::Headers::Fast::_sorted_field_names
10000111719ms1.94sHTTP::Headers::Fast::::__ANON__[:561]HTTP::Headers::Fast::__ANON__[:561]
100001021718ms718msHTTP::Headers::Fast::::CORE:matchHTTP::Headers::Fast::CORE:match (opcode)
10000111634ms634msHTTP::Headers::Fast::::CORE:sortHTTP::Headers::Fast::CORE:sort (opcode)
10000111450ms450msHTTP::Headers::Fast::::content_typeHTTP::Headers::Fast::content_type
142141µs41µsHTTP::Headers::Fast::::CORE:substHTTP::Headers::Fast::CORE:subst (opcode)
11124µs33µsHTTP::Headers::Fast::::BEGIN@3HTTP::Headers::Fast::BEGIN@3
11121µs42µsHTTP::Headers::Fast::::BEGIN@2HTTP::Headers::Fast::BEGIN@2
11119µs51µsHTTP::Headers::Fast::::BEGIN@551HTTP::Headers::Fast::BEGIN@551
101117µs17µsHTTP::Headers::Fast::::CORE:substcontHTTP::Headers::Fast::CORE:substcont (opcode)
11115µs15µsHTTP::Headers::Fast::::BEGIN@4HTTP::Headers::Fast::BEGIN@4
1116µs6µsHTTP::Headers::Fast::::BEGIN@5HTTP::Headers::Fast::BEGIN@5
0000s0sHTTP::Headers::Fast::::_as_stringHTTP::Headers::Fast::_as_string
0000s0sHTTP::Headers::Fast::::_basic_authHTTP::Headers::Fast::_basic_auth
0000s0sHTTP::Headers::Fast::::_date_headerHTTP::Headers::Fast::_date_header
0000s0sHTTP::Headers::Fast::::_flattenHTTP::Headers::Fast::_flatten
0000s0sHTTP::Headers::Fast::::_headerHTTP::Headers::Fast::_header
0000s0sHTTP::Headers::Fast::::_header_pushHTTP::Headers::Fast::_header_push
0000s0sHTTP::Headers::Fast::::_process_newlineHTTP::Headers::Fast::_process_newline
0000s0sHTTP::Headers::Fast::::_split_header_wordsHTTP::Headers::Fast::_split_header_words
0000s0sHTTP::Headers::Fast::::as_stringHTTP::Headers::Fast::as_string
0000s0sHTTP::Headers::Fast::::as_string_without_sortHTTP::Headers::Fast::as_string_without_sort
0000s0sHTTP::Headers::Fast::::authorization_basicHTTP::Headers::Fast::authorization_basic
0000s0sHTTP::Headers::Fast::::clearHTTP::Headers::Fast::clear
0000s0sHTTP::Headers::Fast::::client_dateHTTP::Headers::Fast::client_date
0000s0sHTTP::Headers::Fast::::cloneHTTP::Headers::Fast::clone
0000s0sHTTP::Headers::Fast::::content_is_htmlHTTP::Headers::Fast::content_is_html
0000s0sHTTP::Headers::Fast::::content_is_xhtmlHTTP::Headers::Fast::content_is_xhtml
0000s0sHTTP::Headers::Fast::::content_is_xmlHTTP::Headers::Fast::content_is_xml
0000s0sHTTP::Headers::Fast::::content_type_charsetHTTP::Headers::Fast::content_type_charset
0000s0sHTTP::Headers::Fast::::dateHTTP::Headers::Fast::date
0000s0sHTTP::Headers::Fast::::expiresHTTP::Headers::Fast::expires
0000s0sHTTP::Headers::Fast::::flattenHTTP::Headers::Fast::flatten
0000s0sHTTP::Headers::Fast::::flatten_without_sortHTTP::Headers::Fast::flatten_without_sort
0000s0sHTTP::Headers::Fast::::header_field_namesHTTP::Headers::Fast::header_field_names
0000s0sHTTP::Headers::Fast::::if_modified_sinceHTTP::Headers::Fast::if_modified_since
0000s0sHTTP::Headers::Fast::::if_unmodified_sinceHTTP::Headers::Fast::if_unmodified_since
0000s0sHTTP::Headers::Fast::::init_headerHTTP::Headers::Fast::init_header
0000s0sHTTP::Headers::Fast::::isaHTTP::Headers::Fast::isa
0000s0sHTTP::Headers::Fast::::last_modifiedHTTP::Headers::Fast::last_modified
0000s0sHTTP::Headers::Fast::::proxy_authorization_basicHTTP::Headers::Fast::proxy_authorization_basic
0000s0sHTTP::Headers::Fast::::push_headerHTTP::Headers::Fast::push_header
0000s0sHTTP::Headers::Fast::::refererHTTP::Headers::Fast::referer
0000s0sHTTP::Headers::Fast::::remove_content_headersHTTP::Headers::Fast::remove_content_headers
0000s0sHTTP::Headers::Fast::::remove_headerHTTP::Headers::Fast::remove_header
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1package HTTP::Headers::Fast;
2237µs264µ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
use strict;
# spent 42µs making 1 call to HTTP::Headers::Fast::BEGIN@2 # spent 22µs making 1 call to strict::import
3237µs242µ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
use warnings;
# spent 33µs making 1 call to HTTP::Headers::Fast::BEGIN@3 # spent 9µs making 1 call to warnings::import
4270µs115µ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
use 5.00800;
# spent 15µs making 1 call to HTTP::Headers::Fast::BEGIN@4
524.70ms16µ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
use Carp ();
# spent 6µs making 1 call to HTTP::Headers::Fast::BEGIN@5
6
711µsour $VERSION = '0.20';
8
91400nsour $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".
181200nsmy $OP_GET = 0;
191100nsmy $OP_SET = 1;
201200nsmy $OP_INIT = 2;
211100nsmy $OP_PUSH = 3;
22
2313µsmy @general_headers = qw(
24 Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
25 Via Warning
26);
27
2816µsmy @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
3512µsmy @response_headers = qw(
36 Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
37 Vary WWW-Authenticate
38);
39
4013µsmy @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
45116µsmy %entity_header = map { lc($_) => 1 } @entity_headers;
46
4719µsmy @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.
521400nsmy %header_order;
531800nsour %standard_case;
54
55{
562900ns my $i = 0;
5711µs for (@header_order) {
584715µs my $lc = lc $_;
594739µs $header_order{$lc} = ++$i;
604743µ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
sub new {
65200002170ms my ($class) = shift;
66200002458ms my $self = bless {}, $class;
67200002433ms10000115.6s $self->header(@_) if @_; # set up initial headers
# spent 15.6s making 100001 calls to HTTP::Headers::Fast::header, avg 156µs/call
68200002803ms $self;
69}
70
71sub 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
sub header {
78400004145ms my $self = shift;
79400004183ms Carp::croak('Usage: $h->header($field, ...)') unless @_;
8040000494.2ms my (@old);
81
824000041.15s3000035.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 {
8710000136.2ms my %seen;
88100001186ms while (@_) {
89600006177ms my $field = shift;
906000061.06s if ( $seen{ lc $field }++ ) {
91 @old = $self->_header_push($field, shift);
92 } else {
936000061.19s60000610.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 }
97400004145ms return @old if wantarray;
984000041.95s return $old[0] if @old <= 1;
99 join( ", ", @old );
100}
101
102sub clear {
103 my $self = shift;
104 %$self = ();
105}
106
107sub 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
143sub init_header {
144 Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
145 shift->_header( @_, $OP_INIT );
146}
147
148sub 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
160sub 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
1761100nsmy %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
sub _standardize_field_name {
1781000010301ms my $field = shift;
179
1801000010746ms $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
18110000105.42s if (my $cache = $field_name{$field}) {
182 return $cache;
183 }
184
185102µs my $old = $field;
186108µs $field = lc $field;
187106µs unless ( defined $standard_case{$field} ) {
188 # generate a %standard_case entry for this field
189281µs1235µ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
19023µs $standard_case{$field} = $old;
191 }
1921010µs $field_name{$old} = $field;
1931022µ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
sub _header_get {
197200002182ms my ($self, $field, $skip_standardize) = @_;
198
1992000021.32s400004824ms $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
201200002177ms my $h = $self->{$field};
2022000021.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
sub _header_set {
206800008474ms my ($self, $field, $val) = @_;
207
2088000084.78s16000163.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
210800008365ms my $h = $self->{$field};
211800008679ms my @old = ref($h) eq 'ARRAY' ? @$h : ( defined($h) ? ($h) : () );
212800008320ms if ( defined($val) ) {
213800008198ms if (ref $val eq 'ARRAY' && scalar(@$val) == 1) {
214 $val = $val->[0];
215 }
216800008792ms $self->{$field} = $val;
217 } else {
218 delete $self->{$field};
219 }
2208000083.55s return @old;
221}
222
223sub _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
242sub _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
sub _sorted_field_names {
27110000146.6ms my $self = shift;
272 return [ sort {
2731000011.65s100001634ms ( $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
278sub 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
sub scan {
28610000160.4ms my ( $self, $sub ) = @_;
287100001660ms1000011.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
288300003224ms next if substr($key, 0, 1) eq '_';
289300003132ms my $vals = $self->{$key};
290300003200ms if ( ref($vals) eq 'ARRAY' ) {
291 for my $val (@$vals) {
292 $sub->( $standard_case{$key} || $key, $val );
293 }
294 }
295 else {
296300003423ms3000032.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
301sub _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
312sub _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
341sub as_string {
342 my ( $self, $endl ) = @_;
343 $endl = "\n" unless defined $endl;
344 $self->_as_string($endl, $self->_sorted_field_names);
345}
346
347sub as_string_without_sort {
348 my ( $self, $endl ) = @_;
349 $endl = "\n" unless defined $endl;
350 $self->_as_string($endl, [keys(%$self)]);
351}
352
353sub _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
375sub flatten {
376 $_[0]->_flatten($_[0]->_sorted_field_names);
377}
378
379
380sub flatten_without_sort {
381 $_[0]->_flatten([keys %{$_[0]}]);
382}
383
384{
38521µ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
395sub _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
408sub date { shift->_date_header( 'date', @_ ); }
409sub expires { shift->_date_header( 'expires', @_ ); }
410sub if_modified_since { shift->_date_header( 'if-modified-since', @_ ); }
411sub if_unmodified_since { shift->_date_header( 'if-unmodified-since', @_ ); }
412sub 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.
416sub 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
sub content_type {
42610000142.8ms my $self = shift;
42710000164.4ms my $ct = $self->{'content-type'};
428100001110ms $self->{'content-type'} = shift if @_;
42910000147.3ms $ct = $ct->[0] if ref($ct) eq 'ARRAY';
430100001463ms 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
439sub 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
464sub _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
512sub content_is_html {
513 my $self = shift;
514 return $self->content_type eq 'text/html' || $self->content_is_xhtml;
515}
516
517sub 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
523sub 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
531sub 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}
54812µs*referrer = \&referer; # on tchrist's request
549
5501900nsfor my $key (qw/content-length content-language content-encoding title user-agent server from warnings www-authenticate authorization proxy-authenticate proxy-authorization/) {
5512498µs283µ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
no strict 'refs';
# spent 51µs making 1 call to HTTP::Headers::Fast::BEGIN@551 # spent 32µs making 1 call to strict::unimport
5521266µs1223µ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
*{$meth} = sub {
55410000145.5ms my $self = shift;
555100001828ms1000011.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 }
5611266µs };
562}
563
564sub authorization_basic { shift->_basic_auth( "Authorization", @_ ) }
565sub proxy_authorization_basic {
566 shift->_basic_auth( "Proxy-Authorization", @_ );
567}
568
569sub _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
588129µs1;
589__END__
 
# spent 718ms within HTTP::Headers::Fast::CORE:match which was called 1000010 times, avg 718ns/call: # 800008 times (544ms+0s) by HTTP::Headers::Fast::_header_set at line 208, avg 680ns/call # 200002 times (174ms+0s) by HTTP::Headers::Fast::_header_get at line 199, avg 870ns/call
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:sort; # opcode
# spent 41µs within HTTP::Headers::Fast::CORE:subst which was called 14 times, avg 3µs/call: # 12 times (23µs+0s) by Plack::Request::BEGIN@7 at line 552, avg 2µs/call # 2 times (19µs+0s) by HTTP::Headers::Fast::_standardize_field_name at line 189, avg 9µ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
sub HTTP::Headers::Fast::CORE:substcont; # opcode