Profile of HTTP/Headers/Fast.pm

← 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
Statements | Executed 17700429 statements in 33.7s

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
800008 | 3 | 1 | 10.6s | 13.8s | HTTP::Headers::Fast::::_header_setHTTP::Headers::Fast::_header_set
400004 | 4 | 3 | 8.09s | 24.2s | HTTP::Headers::Fast::::headerHTTP::Headers::Fast::header
1000010 | 2 | 1 | 3.30s | 3.30s | HTTP::Headers::Fast::::_standardize_field_nameHTTP::Headers::Fast::_standardize_field_name
100001 | 1 | 1 | 2.98s | 7.31s | HTTP::Headers::Fast::::scanHTTP::Headers::Fast::scan
200002 | 1 | 1 | 2.66s | 3.48s | HTTP::Headers::Fast::::_header_getHTTP::Headers::Fast::_header_get
200002 | 2 | 2 | 1.78s | 17.4s | HTTP::Headers::Fast::::newHTTP::Headers::Fast::new
100001 | 1 | 1 | 801ms | 1.44s | HTTP::Headers::Fast::::_sorted_field_namesHTTP::Headers::Fast::_sorted_field_names
100001 | 1 | 1 | 719ms | 1.94s | HTTP::Headers::Fast::::__ANON__[:561]HTTP::Headers::Fast::__ANON__[:561]
1000010 | 2 | 1 | 718ms | 718ms | HTTP::Headers::Fast::::CORE:matchHTTP::Headers::Fast::CORE:match (opcode)
100001 | 1 | 1 | 634ms | 634ms | HTTP::Headers::Fast::::CORE:sortHTTP::Headers::Fast::CORE:sort (opcode)
100001 | 1 | 1 | 450ms | 450ms | HTTP::Headers::Fast::::content_typeHTTP::Headers::Fast::content_type
14 | 2 | 1 | 41µs | 41µs | HTTP::Headers::Fast::::CORE:substHTTP::Headers::Fast::CORE:subst (opcode)
1 | 1 | 1 | 24µs | 33µs | HTTP::Headers::Fast::::BEGIN@3HTTP::Headers::Fast::BEGIN@3
1 | 1 | 1 | 21µs | 42µs | HTTP::Headers::Fast::::BEGIN@2HTTP::Headers::Fast::BEGIN@2
1 | 1 | 1 | 19µs | 51µs | HTTP::Headers::Fast::::BEGIN@551HTTP::Headers::Fast::BEGIN@551
10 | 1 | 1 | 17µs | 17µs | HTTP::Headers::Fast::::CORE:substcontHTTP::Headers::Fast::CORE:substcont (opcode)
1 | 1 | 1 | 15µs | 15µs | HTTP::Headers::Fast::::BEGIN@4HTTP::Headers::Fast::BEGIN@4
1 | 1 | 1 | 6µs | 6µs | HTTP::Headers::Fast::::BEGIN@5HTTP::Headers::Fast::BEGIN@5
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_as_stringHTTP::Headers::Fast::_as_string
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_basic_authHTTP::Headers::Fast::_basic_auth
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_date_headerHTTP::Headers::Fast::_date_header
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_flattenHTTP::Headers::Fast::_flatten
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_headerHTTP::Headers::Fast::_header
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_header_pushHTTP::Headers::Fast::_header_push
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_process_newlineHTTP::Headers::Fast::_process_newline
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::_split_header_wordsHTTP::Headers::Fast::_split_header_words
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::as_stringHTTP::Headers::Fast::as_string
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::as_string_without_sortHTTP::Headers::Fast::as_string_without_sort
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::authorization_basicHTTP::Headers::Fast::authorization_basic
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::clearHTTP::Headers::Fast::clear
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::client_dateHTTP::Headers::Fast::client_date
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::cloneHTTP::Headers::Fast::clone
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::content_is_htmlHTTP::Headers::Fast::content_is_html
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::content_is_xhtmlHTTP::Headers::Fast::content_is_xhtml
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::content_is_xmlHTTP::Headers::Fast::content_is_xml
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::content_type_charsetHTTP::Headers::Fast::content_type_charset
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::dateHTTP::Headers::Fast::date
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::expiresHTTP::Headers::Fast::expires
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::flattenHTTP::Headers::Fast::flatten
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::flatten_without_sortHTTP::Headers::Fast::flatten_without_sort
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::header_field_namesHTTP::Headers::Fast::header_field_names
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::if_modified_sinceHTTP::Headers::Fast::if_modified_since
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::if_unmodified_sinceHTTP::Headers::Fast::if_unmodified_since
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::init_headerHTTP::Headers::Fast::init_header
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::isaHTTP::Headers::Fast::isa
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::last_modifiedHTTP::Headers::Fast::last_modified
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::proxy_authorization_basicHTTP::Headers::Fast::proxy_authorization_basic
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::push_headerHTTP::Headers::Fast::push_header
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::refererHTTP::Headers::Fast::referer
0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::::remove_content_headersHTTP::Headers::Fast::remove_content_headers
0 | 0 | 0 | 0s | 0s | HTTP::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
--- | --- | --- | --- | --- | ---
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 use strict; # 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 use warnings; # 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 use 5.00800; # 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 use Carp (); # 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 sub new {
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 sub header {
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 sub _standardize_field_name {
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 sub _header_get {
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 sub _header_set {
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 sub _sorted_field_names {
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 sub scan {
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 sub content_type {
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 no strict 'refs'; # 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 *{$meth} = sub {
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__
|  |  |  |  | # 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