← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:51 2015

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