← 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.pm
StatementsExecuted 165 statements in 4.02ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
11113µs33µsHTTP::Headers::::BEGIN@3HTTP::Headers::BEGIN@3
11113µs22µsHTTP::Headers::::BEGIN@4HTTP::Headers::BEGIN@4
1115µs5µsHTTP::Headers::::BEGIN@6HTTP::Headers::BEGIN@6
0000s0sHTTP::Headers::::__ANON__[:308]HTTP::Headers::__ANON__[:308]
0000s0sHTTP::Headers::::__ANON__[:310]HTTP::Headers::__ANON__[:310]
0000s0sHTTP::Headers::::_basic_authHTTP::Headers::_basic_auth
0000s0sHTTP::Headers::::_date_headerHTTP::Headers::_date_header
0000s0sHTTP::Headers::::_headerHTTP::Headers::_header
0000s0sHTTP::Headers::::_process_newlineHTTP::Headers::_process_newline
0000s0sHTTP::Headers::::_sorted_field_namesHTTP::Headers::_sorted_field_names
0000s0sHTTP::Headers::::as_stringHTTP::Headers::as_string
0000s0sHTTP::Headers::::authorizationHTTP::Headers::authorization
0000s0sHTTP::Headers::::authorization_basicHTTP::Headers::authorization_basic
0000s0sHTTP::Headers::::clearHTTP::Headers::clear
0000s0sHTTP::Headers::::client_dateHTTP::Headers::client_date
0000s0sHTTP::Headers::::content_encodingHTTP::Headers::content_encoding
0000s0sHTTP::Headers::::content_is_htmlHTTP::Headers::content_is_html
0000s0sHTTP::Headers::::content_is_textHTTP::Headers::content_is_text
0000s0sHTTP::Headers::::content_is_xhtmlHTTP::Headers::content_is_xhtml
0000s0sHTTP::Headers::::content_is_xmlHTTP::Headers::content_is_xml
0000s0sHTTP::Headers::::content_languageHTTP::Headers::content_language
0000s0sHTTP::Headers::::content_lengthHTTP::Headers::content_length
0000s0sHTTP::Headers::::content_typeHTTP::Headers::content_type
0000s0sHTTP::Headers::::content_type_charsetHTTP::Headers::content_type_charset
0000s0sHTTP::Headers::::dateHTTP::Headers::date
0000s0sHTTP::Headers::::expiresHTTP::Headers::expires
0000s0sHTTP::Headers::::flattenHTTP::Headers::flatten
0000s0sHTTP::Headers::::fromHTTP::Headers::from
0000s0sHTTP::Headers::::headerHTTP::Headers::header
0000s0sHTTP::Headers::::header_field_namesHTTP::Headers::header_field_names
0000s0sHTTP::Headers::::if_modified_sinceHTTP::Headers::if_modified_since
0000s0sHTTP::Headers::::if_unmodified_sinceHTTP::Headers::if_unmodified_since
0000s0sHTTP::Headers::::init_headerHTTP::Headers::init_header
0000s0sHTTP::Headers::::last_modifiedHTTP::Headers::last_modified
0000s0sHTTP::Headers::::newHTTP::Headers::new
0000s0sHTTP::Headers::::proxy_authenticateHTTP::Headers::proxy_authenticate
0000s0sHTTP::Headers::::proxy_authorizationHTTP::Headers::proxy_authorization
0000s0sHTTP::Headers::::proxy_authorization_basicHTTP::Headers::proxy_authorization_basic
0000s0sHTTP::Headers::::push_headerHTTP::Headers::push_header
0000s0sHTTP::Headers::::refererHTTP::Headers::referer
0000s0sHTTP::Headers::::remove_content_headersHTTP::Headers::remove_content_headers
0000s0sHTTP::Headers::::remove_headerHTTP::Headers::remove_header
0000s0sHTTP::Headers::::scanHTTP::Headers::scan
0000s0sHTTP::Headers::::serverHTTP::Headers::server
0000s0sHTTP::Headers::::titleHTTP::Headers::title
0000s0sHTTP::Headers::::user_agentHTTP::Headers::user_agent
0000s0sHTTP::Headers::::warningHTTP::Headers::warning
0000s0sHTTP::Headers::::www_authenticateHTTP::Headers::www_authenticate
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;
2
3234µs252µs
# spent 33µs (13+19) within HTTP::Headers::BEGIN@3 which was called: # once (13µs+19µs) by HTTP::Body::BEGIN@25 at line 3
use strict;
# spent 33µs making 1 call to HTTP::Headers::BEGIN@3 # spent 19µs making 1 call to strict::import
4235µs231µs
# spent 22µs (13+9) within HTTP::Headers::BEGIN@4 which was called: # once (13µs+9µs) by HTTP::Body::BEGIN@25 at line 4
use warnings;
# spent 22µs making 1 call to HTTP::Headers::BEGIN@4 # spent 9µs making 1 call to warnings::import
5
623.63ms15µs
# spent 5µs within HTTP::Headers::BEGIN@6 which was called: # once (5µs+0s) by HTTP::Body::BEGIN@25 at line 6
use Carp ();
# spent 5µs making 1 call to HTTP::Headers::BEGIN@6
7
81800nsour $VERSION = "6.11";
9
10# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
11# as a replacement for '-' in header field names.
121500nsour $TRANSLATE_UNDERSCORE = 1 unless defined $TRANSLATE_UNDERSCORE;
13
14# "Good Practice" order of HTTP message headers:
15# - General-Headers
16# - Request-Headers
17# - Response-Headers
18# - Entity-Headers
19
2013µsmy @general_headers = qw(
21 Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
22 Via Warning
23);
24
2514µsmy @request_headers = qw(
26 Accept Accept-Charset Accept-Encoding Accept-Language
27 Authorization Expect From Host
28 If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
29 Max-Forwards Proxy-Authorization Range Referer TE User-Agent
30);
31
3212µsmy @response_headers = qw(
33 Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
34 Vary WWW-Authenticate
35);
36
3712µsmy @entity_headers = qw(
38 Allow Content-Encoding Content-Language Content-Length Content-Location
39 Content-MD5 Content-Range Content-Type Expires Last-Modified
40);
41
42113µsmy %entity_header = map { lc($_) => 1 } @entity_headers;
43
4418µsmy @header_order = (
45 @general_headers,
46 @request_headers,
47 @response_headers,
48 @entity_headers,
49);
50
51# Make alternative representations of @header_order. This is used
52# for sorting and case matching.
531200nsmy %header_order;
541100nsmy %standard_case;
55
56{
5721µs my $i = 0;
5811µs for (@header_order) {
594712µs my $lc = lc $_;
604731µs $header_order{$lc} = ++$i;
614738µs $standard_case{$lc} = $_;
62 }
63}
64
- -
67sub new
68{
69 my($class) = shift;
70 my $self = bless {}, $class;
71 $self->header(@_) if @_; # set up initial headers
72 $self;
73}
74
75
76sub header
77{
78 my $self = shift;
79 Carp::croak('Usage: $h->header($field, ...)') unless @_;
80 my(@old);
81 my %seen;
82 while (@_) {
83 my $field = shift;
84 my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
85 @old = $self->_header($field, shift, $op);
86 }
87 return @old if wantarray;
88 return $old[0] if @old <= 1;
89 join(", ", @old);
90}
91
92sub clear
93{
94 my $self = shift;
95 %$self = ();
96}
97
98
99sub push_header
100{
101 my $self = shift;
102 return $self->_header(@_, 'PUSH_H') if @_ == 2;
103 while (@_) {
104 $self->_header(splice(@_, 0, 2), 'PUSH_H');
105 }
106}
107
108
109sub init_header
110{
111 Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
112 shift->_header(@_, 'INIT');
113}
114
115
116sub remove_header
117{
118 my($self, @fields) = @_;
119 my $field;
120 my @values;
121 foreach $field (@fields) {
122 $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
123 my $v = delete $self->{lc $field};
124 push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v;
125 }
126 return @values;
127}
128
129sub remove_content_headers
130{
131 my $self = shift;
132 unless (defined(wantarray)) {
133 # fast branch that does not create return object
134 delete @$self{grep $entity_header{$_} || /^content-/, keys %$self};
135 return;
136 }
137
138 my $c = ref($self)->new;
139 for my $f (grep $entity_header{$_} || /^content-/, keys %$self) {
140 $c->{$f} = delete $self->{$f};
141 }
142 if (exists $self->{'::std_case'}) {
143 $c->{'::std_case'} = $self->{'::std_case'};
144 }
145 $c;
146}
147
148
149sub _header
150{
151 my($self, $field, $val, $op) = @_;
152
153 Carp::croak("Illegal field name '$field'")
154 if rindex($field, ':') > 1 || !length($field);
155
156 unless ($field =~ /^:/) {
157 $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
158 my $old = $field;
159 $field = lc $field;
160 unless($standard_case{$field} || $self->{'::std_case'}{$field}) {
161 # generate a %std_case entry for this field
162 $old =~ s/\b(\w)/\u$1/g;
163 $self->{'::std_case'}{$field} = $old;
164 }
165 }
166
167 $op ||= defined($val) ? 'SET' : 'GET';
168 if ($op eq 'PUSH_H') {
169 # Like PUSH but where we don't care about the return value
170 if (exists $self->{$field}) {
171 my $h = $self->{$field};
172 if (ref($h) eq 'ARRAY') {
173 push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
174 }
175 else {
176 $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
177 }
178 return;
179 }
180 $self->{$field} = $val;
181 return;
182 }
183
184 my $h = $self->{$field};
185 my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
186
187 unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
188 if (defined($val)) {
189 my @new = ($op eq 'PUSH') ? @old : ();
190 if (ref($val) ne 'ARRAY') {
191 push(@new, $val);
192 }
193 else {
194 push(@new, @$val);
195 }
196 $self->{$field} = @new > 1 ? \@new : $new[0];
197 }
198 elsif ($op ne 'PUSH') {
199 delete $self->{$field};
200 }
201 }
202 @old;
203}
204
205
206sub _sorted_field_names
207{
208 my $self = shift;
209 return [ sort {
210 ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
211 $a cmp $b
212 } grep !/^::/, keys %$self ];
213}
214
215
216sub header_field_names {
217 my $self = shift;
218 return map $standard_case{$_} || $self->{'::std_case'}{$_} || $_, @{ $self->_sorted_field_names },
219 if wantarray;
220 return grep !/^::/, keys %$self;
221}
222
223
224sub scan
225{
226 my($self, $sub) = @_;
227 my $key;
228 for $key (@{ $self->_sorted_field_names }) {
229 my $vals = $self->{$key};
230 if (ref($vals) eq 'ARRAY') {
231 my $val;
232 for $val (@$vals) {
233 $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $val);
234 }
235 }
236 else {
237 $sub->($standard_case{$key} || $self->{'::std_case'}{$key} || $key, $vals);
238 }
239 }
240}
241
242sub flatten {
243 my($self)=@_;
244
245 (
246 map {
247 my $k = $_;
248 map {
249 ( $k => $_ )
250 } $self->header($_);
251 } $self->header_field_names
252 );
253}
254
255sub as_string
256{
257 my($self, $endl) = @_;
258 $endl = "\n" unless defined $endl;
259
260 my @result = ();
261 for my $key (@{ $self->_sorted_field_names }) {
262 next if index($key, '_') == 0;
263 my $vals = $self->{$key};
264 if ( ref($vals) eq 'ARRAY' ) {
265 for my $val (@$vals) {
266 $val = '' if not defined $val;
267 my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
268 $field =~ s/^://;
269 if ( index($val, "\n") >= 0 ) {
270 $val = _process_newline($val, $endl);
271 }
272 push @result, $field . ': ' . $val;
273 }
274 }
275 else {
276 $vals = '' if not defined $vals;
277 my $field = $standard_case{$key} || $self->{'::std_case'}{$key} || $key;
278 $field =~ s/^://;
279 if ( index($vals, "\n") >= 0 ) {
280 $vals = _process_newline($vals, $endl);
281 }
282 push @result, $field . ': ' . $vals;
283 }
284 }
285
286 join($endl, @result, '');
287}
288
289sub _process_newline {
290 local $_ = shift;
291 my $endl = shift;
292 # must handle header values with embedded newlines with care
293 s/\s+$//; # trailing newlines and space must go
294 s/\n(\x0d?\n)+/\n/g; # no empty lines
295 s/\n([^\040\t])/\n $1/g; # initial space for continuation
296 s/\n/$endl/g; # substitute with requested line ending
297 $_;
298}
299
- -
3023172µsif (eval { require Storable; 1 }) {
303 *clone = \&Storable::dclone;
304} else {
305 *clone = sub {
306 my $self = shift;
307 my $clone = HTTP::Headers->new;
308 $self->scan(sub { $clone->push_header(@_);} );
309 $clone;
310 };
311}
312
313
314sub _date_header
315{
316 require HTTP::Date;
317 my($self, $header, $time) = @_;
318 my($old) = $self->_header($header);
319 if (defined $time) {
320 $self->_header($header, HTTP::Date::time2str($time));
321 }
322 $old =~ s/;.*// if defined($old);
323 HTTP::Date::str2time($old);
324}
325
326
327sub date { shift->_date_header('Date', @_); }
328sub expires { shift->_date_header('Expires', @_); }
329sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
330sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
331sub last_modified { shift->_date_header('Last-Modified', @_); }
332
333# This is used as a private LWP extension. The Client-Date header is
334# added as a timestamp to a response when it has been received.
335sub client_date { shift->_date_header('Client-Date', @_); }
336
337# The retry_after field is dual format (can also be a expressed as
338# number of seconds from now), so we don't provide an easy way to
339# access it until we have know how both these interfaces can be
340# addressed. One possibility is to return a negative value for
341# relative seconds and a positive value for epoch based time values.
342#sub retry_after { shift->_date_header('Retry-After', @_); }
343
344sub content_type {
345 my $self = shift;
346 my $ct = $self->{'content-type'};
347 $self->{'content-type'} = shift if @_;
348 $ct = $ct->[0] if ref($ct) eq 'ARRAY';
349 return '' unless defined($ct) && length($ct);
350 my @ct = split(/;\s*/, $ct, 2);
351 for ($ct[0]) {
352 s/\s+//g;
353 $_ = lc($_);
354 }
355 wantarray ? @ct : $ct[0];
356}
357
358sub content_type_charset {
359 my $self = shift;
360 require HTTP::Headers::Util;
361 my $h = $self->{'content-type'};
362 $h = $h->[0] if ref($h);
363 $h = "" unless defined $h;
364 my @v = HTTP::Headers::Util::split_header_words($h);
365 if (@v) {
366 my($ct, undef, %ct_param) = @{$v[0]};
367 my $charset = $ct_param{charset};
368 if ($ct) {
369 $ct = lc($ct);
370 $ct =~ s/\s+//;
371 }
372 if ($charset) {
373 $charset = uc($charset);
374 $charset =~ s/^\s+//; $charset =~ s/\s+\z//;
375 undef($charset) if $charset eq "";
376 }
377 return $ct, $charset if wantarray;
378 return $charset;
379 }
380 return undef, undef if wantarray;
381 return undef;
382}
383
384sub content_is_text {
385 my $self = shift;
386 return $self->content_type =~ m,^text/,;
387}
388
389sub content_is_html {
390 my $self = shift;
391 return $self->content_type eq 'text/html' || $self->content_is_xhtml;
392}
393
394sub content_is_xhtml {
395 my $ct = shift->content_type;
396 return $ct eq "application/xhtml+xml" ||
397 $ct eq "application/vnd.wap.xhtml+xml";
398}
399
400sub content_is_xml {
401 my $ct = shift->content_type;
402 return 1 if $ct eq "text/xml";
403 return 1 if $ct eq "application/xml";
404 return 1 if $ct =~ /\+xml$/;
405 return 0;
406}
407
408sub referer {
409 my $self = shift;
410 if (@_ && $_[0] =~ /#/) {
411 # Strip fragment per RFC 2616, section 14.36.
412 my $uri = shift;
413 if (ref($uri)) {
414 $uri = $uri->clone;
415 $uri->fragment(undef);
416 }
417 else {
418 $uri =~ s/\#.*//;
419 }
420 unshift @_, $uri;
421 }
422 ($self->_header('Referer', @_))[0];
423}
42411µs*referrer = \&referer; # on tchrist's request
425
426sub title { (shift->_header('Title', @_))[0] }
427sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
428sub content_language { (shift->_header('Content-Language', @_))[0] }
429sub content_length { (shift->_header('Content-Length', @_))[0] }
430
431sub user_agent { (shift->_header('User-Agent', @_))[0] }
432sub server { (shift->_header('Server', @_))[0] }
433
434sub from { (shift->_header('From', @_))[0] }
435sub warning { (shift->_header('Warning', @_))[0] }
436
437sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
438sub authorization { (shift->_header('Authorization', @_))[0] }
439
440sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
441sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
442
443sub authorization_basic { shift->_basic_auth("Authorization", @_) }
444sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
445
446sub _basic_auth {
447 require MIME::Base64;
448 my($self, $h, $user, $passwd) = @_;
449 my($old) = $self->_header($h);
450 if (defined $user) {
451 Carp::croak("Basic authorization user name can't contain ':'")
452 if $user =~ /:/;
453 $passwd = '' unless defined $passwd;
454 $self->_header($h => 'Basic ' .
455 MIME::Base64::encode("$user:$passwd", ''));
456 }
457 if (defined $old && $old =~ s/^\s*Basic\s+//) {
458 my $val = MIME::Base64::decode($old);
459 return $val unless wantarray;
460 return split(/:/, $val, 2);
461 }
462 return;
463}
464
465
466127µs1;
467
468__END__