| 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 | HTTP::Headers::Fast::_header_set |
| 400004 | 4 | 3 | 8.09s | 24.2s | HTTP::Headers::Fast::header |
| 1000010 | 2 | 1 | 3.30s | 3.30s | HTTP::Headers::Fast::_standardize_field_name |
| 100001 | 1 | 1 | 2.98s | 7.31s | HTTP::Headers::Fast::scan |
| 200002 | 1 | 1 | 2.66s | 3.48s | HTTP::Headers::Fast::_header_get |
| 200002 | 2 | 2 | 1.78s | 17.4s | HTTP::Headers::Fast::new |
| 100001 | 1 | 1 | 801ms | 1.44s | HTTP::Headers::Fast::_sorted_field_names |
| 100001 | 1 | 1 | 719ms | 1.94s | HTTP::Headers::Fast::__ANON__[:561] |
| 1000010 | 2 | 1 | 718ms | 718ms | HTTP::Headers::Fast::CORE:match (opcode) |
| 100001 | 1 | 1 | 634ms | 634ms | HTTP::Headers::Fast::CORE:sort (opcode) |
| 100001 | 1 | 1 | 450ms | 450ms | HTTP::Headers::Fast::content_type |
| 14 | 2 | 1 | 41µs | 41µs | HTTP::Headers::Fast::CORE:subst (opcode) |
| 1 | 1 | 1 | 24µs | 33µs | HTTP::Headers::Fast::BEGIN@3 |
| 1 | 1 | 1 | 21µs | 42µs | HTTP::Headers::Fast::BEGIN@2 |
| 1 | 1 | 1 | 19µs | 51µs | HTTP::Headers::Fast::BEGIN@551 |
| 10 | 1 | 1 | 17µs | 17µs | HTTP::Headers::Fast::CORE:substcont (opcode) |
| 1 | 1 | 1 | 15µs | 15µs | HTTP::Headers::Fast::BEGIN@4 |
| 1 | 1 | 1 | 6µs | 6µs | HTTP::Headers::Fast::BEGIN@5 |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_as_string |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_basic_auth |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_date_header |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_flatten |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_header |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_header_push |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_process_newline |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::_split_header_words |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::as_string |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::as_string_without_sort |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::authorization_basic |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::clear |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::client_date |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::clone |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::content_is_html |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::content_is_xhtml |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::content_is_xml |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::content_type_charset |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::date |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::expires |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::flatten |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::flatten_without_sort |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::header_field_names |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::if_modified_since |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::if_unmodified_since |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::init_header |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::isa |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::last_modified |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::proxy_authorization_basic |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::push_header |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::referer |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::remove_content_headers |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::Fast::remove_header |
| 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 |