← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 05.Domain_and_Item.t
  Run on Tue May 4 17:21:41 2010
Reported on Tue May 4 17:22:39 2010

File /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Headers.pm
Statements Executed 14707
Statement Execution Time 20.0ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
615517.07ms7.40msHTTP::Headers::::_headerHTTP::Headers::_header
247532.49ms5.56msHTTP::Headers::::headerHTTP::Headers::header
205322.02ms2.12msHTTP::Headers::::content_typeHTTP::Headers::content_type
122111.35ms4.08msHTTP::Headers::::push_headerHTTP::Headers::push_header
41111.07ms2.49msHTTP::Headers::::scanHTTP::Headers::scan
4111679µs711µsHTTP::Headers::::remove_headerHTTP::Headers::remove_header
8322521µs521µsHTTP::Headers::::newHTTP::Headers::new
8222520µs1.31msHTTP::Headers::::content_is_xhtmlHTTP::Headers::content_is_xhtml
8221503µs775µsHTTP::Headers::::_sorted_field_namesHTTP::Headers::_sorted_field_names
4111445µs1.57msHTTP::Headers::::content_is_htmlHTTP::Headers::content_is_html
8222413µs1.52msHTTP::Headers::::init_headerHTTP::Headers::init_header
77932363µs363µsHTTP::Headers::::CORE:matchHTTP::Headers::CORE:match (opcode)
4111344µs651µsHTTP::Headers::::header_field_namesHTTP::Headers::header_field_names
8212273µs273µsHTTP::Headers::::CORE:sortHTTP::Headers::CORE:sort (opcode)
4111264µs757µsHTTP::Headers::::content_lengthHTTP::Headers::content_length
16822117µs117µsHTTP::Headers::::CORE:substHTTP::Headers::CORE:subst (opcode)
141222µs22µsHTTP::Headers::::CORE:substcontHTTP::Headers::CORE:substcont (opcode)
11115µs18µsHTTP::Headers::::BEGIN@3HTTP::Headers::BEGIN@3
1116µs33µsHTTP::Headers::::BEGIN@6HTTP::Headers::BEGIN@6
1113µs3µsHTTP::Headers::::BEGIN@4HTTP::Headers::BEGIN@4
0000s0sHTTP::Headers::::__ANON__[:254]HTTP::Headers::__ANON__[:254]
0000s0sHTTP::Headers::::__ANON__[:266]HTTP::Headers::__ANON__[:266]
0000s0sHTTP::Headers::::__ANON__[:268]HTTP::Headers::__ANON__[:268]
0000s0sHTTP::Headers::::_basic_authHTTP::Headers::_basic_auth
0000s0sHTTP::Headers::::_date_headerHTTP::Headers::_date_header
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_textHTTP::Headers::content_is_text
0000s0sHTTP::Headers::::content_is_xmlHTTP::Headers::content_is_xml
0000s0sHTTP::Headers::::content_languageHTTP::Headers::content_language
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::::if_modified_sinceHTTP::Headers::if_modified_since
0000s0sHTTP::Headers::::if_unmodified_sinceHTTP::Headers::if_unmodified_since
0000s0sHTTP::Headers::::last_modifiedHTTP::Headers::last_modified
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::::refererHTTP::Headers::referer
0000s0sHTTP::Headers::::remove_content_headersHTTP::Headers::remove_content_headers
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
3328µs221µs
# spent 18µs (15+3) within HTTP::Headers::BEGIN@3 which was called # once (15µs+3µs) by LWP::UserAgent::BEGIN@10 at line 3
use strict;
# spent 18µs making 1 call to HTTP::Headers::BEGIN@3 # spent 3µs making 1 call to strict::import
4324µs13µs
# spent 3µs within HTTP::Headers::BEGIN@4 which was called # once (3µs+0s) by LWP::UserAgent::BEGIN@10 at line 4
use Carp ();
# spent 3µs making 1 call to HTTP::Headers::BEGIN@4
5
632.02ms261µs
# spent 33µs (6+28) within HTTP::Headers::BEGIN@6 which was called # once (6µs+28µs) by LWP::UserAgent::BEGIN@10 at line 6
use vars qw($VERSION $TRANSLATE_UNDERSCORE);
# spent 33µs making 1 call to HTTP::Headers::BEGIN@6 # spent 28µs making 1 call to vars::import
71900ns$VERSION = "5.827";
8
9# The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used
10# as a replacement for '-' in header field names.
111500ns$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
1914µsmy @general_headers = qw(
20 Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
21 Via Warning
22);
23
2414µ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
3112µsmy @response_headers = qw(
32 Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
33 Vary WWW-Authenticate
34);
35
3612µsmy @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
41117µsmy %entity_header = map { lc($_) => 1 } @entity_headers;
42
43116µ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.
521100nsmy %header_order;
5310smy %standard_case;
54
55{
5632µs my $i = 0;
57 for (@header_order) {
5814159µs my $lc = lc $_;
59 $header_order{$lc} = ++$i;
60 $standard_case{$lc} = $_;
61 }
62}
63
64
65
66sub new
67
# spent 521µs within HTTP::Headers::new which was called 83 times, avg 6µs/call: # 82 times (512µs+0s) by HTTP::Message::new at line 36 of HTTP/Message.pm, avg 6µs/call # once (10µs+0s) by LWP::UserAgent::default_headers at line 643 of LWP/UserAgent.pm
{
68332655µs my($class) = shift;
69 my $self = bless {}, $class;
70 $self->header(@_) if @_; # set up initial headers
71 $self;
72}
73
74
75sub header
76
# spent 5.56ms (2.49+3.07) within HTTP::Headers::header which was called 247 times, avg 23µs/call: # 123 times (1.46ms+1.91ms) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 27µs/call # 41 times (450µs+561µs) by LWP::UserAgent::prepare_request at line 217 of LWP/UserAgent.pm, avg 25µs/call # 41 times (318µs+304µs) by LWP::Protocol::http::request at line 185 of LWP/Protocol/http.pm, avg 15µs/call # 41 times (251µs+269µs) by LWP::Protocol::http::request at line 203 of LWP/Protocol/http.pm, avg 13µs/call # once (16µs+27µs) by LWP::UserAgent::default_header at line 654 of LWP/UserAgent.pm
{
7716881.29ms my $self = shift;
78 Carp::croak('Usage: $h->header($field, ...)') unless @_;
79 my(@old);
80 my %seen;
81 while (@_) {
82741919µs my $field = shift;
83 my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET';
84 @old = $self->_header($field, shift, $op);
# spent 3.07ms making 247 calls to HTTP::Headers::_header, avg 12µs/call
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
# spent 4.08ms (1.35+2.73) within HTTP::Headers::push_header which was called 122 times, avg 33µs/call: # 122 times (1.35ms+2.73ms) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 33µs/call
{
100285617µs my $self = shift;
101 return $self->_header(@_, 'PUSH_H') if @_ == 2;
# spent 864µs making 81 calls to HTTP::Headers::_header, avg 11µs/call
102 while (@_) {
103164481µs1641.87ms $self->_header(splice(@_, 0, 2), 'PUSH_H');
# spent 1.87ms making 164 calls to HTTP::Headers::_header, avg 11µs/call
104 }
105}
106
107
108sub init_header
109
# spent 1.52ms (413µs+1.10) within HTTP::Headers::init_header which was called 82 times, avg 19µs/call: # 41 times (236µs+545µs) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 19µs/call # 41 times (177µs+560µs) by LWP::Protocol::http::_fixup_header at line 98 of LWP/Protocol/http.pm, avg 18µs/call
{
110164371µs Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
111 shift->_header(@_, 'INIT');
# spent 1.10ms making 82 calls to HTTP::Headers::_header, avg 13µs/call
112}
113
114
115sub remove_header
116
# spent 711µs (679+32) within HTTP::Headers::remove_header which was called 41 times, avg 17µs/call: # 41 times (679µs+32µs) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 17µs/call
{
117205363µs my($self, @fields) = @_;
118 my $field;
119 my @values;
120 foreach $field (@fields) {
121123359µs4132µs $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
# spent 32µs making 41 calls to HTTP::Headers::CORE:match, avg 778ns/call
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 $c;
142}
143
144
145sub _header
146
# spent 7.40ms (7.07+332µs) within HTTP::Headers::_header which was called 615 times, avg 12µs/call: # 247 times (2.93ms+140µs) by HTTP::Headers::header at line 84, avg 12µs/call # 164 times (1.78ms+87µs) by HTTP::Headers::push_header at line 103, avg 11µs/call # 82 times (1.08ms+28µs) by HTTP::Headers::init_header at line 111, avg 13µs/call # 81 times (810µs+53µs) by HTTP::Headers::push_header at line 101, avg 11µs/call # 41 times (468µs+24µs) by HTTP::Headers::content_length at line 387, avg 12µs/call
{
14739404.31ms my($self, $field, $val, $op) = @_;
148
14924601.21ms615294µs unless ($field =~ /^:/) {
# spent 294µs making 615 calls to HTTP::Headers::CORE:match, avg 479ns/call
150 $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
151 my $old = $field;
152 $field = lc $field;
153888µs unless(defined $standard_case{$field}) {
154 # generate a %standard_case entry for this field
155 $old =~ s/\b(\w)/\u$1/g;
# spent 22µs making 14 calls to HTTP::Headers::CORE:substcont, avg 2µs/call # spent 16µs making 4 calls to HTTP::Headers::CORE:subst, avg 4µs/call
156 $standard_case{$field} = $old;
157 }
158 }
159
160 $op ||= defined($val) ? 'SET' : 'GET';
1617351.09ms if ($op eq 'PUSH_H') {
162 # Like PUSH but where we don't care about the return value
163 if (exists $self->{$field}) {
164 my $h = $self->{$field};
165 if (ref($h) eq 'ARRAY') {
166 push(@$h, ref($val) eq "ARRAY" ? @$val : $val);
167 }
168 else {
169 $self->{$field} = [$h, ref($val) eq "ARRAY" ? @$val : $val]
170 }
171 return;
172 }
173 $self->{$field} = $val;
174 return;
175 }
176
177 my $h = $self->{$field};
178 my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ());
179
18016583µs unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
181495541µs if (defined($val)) {
182 my @new = ($op eq 'PUSH') ? @old : ();
1834142µs if (ref($val) ne 'ARRAY') {
184 push(@new, $val);
185 }
186 else {
187 push(@new, @$val);
188 }
189 $self->{$field} = @new > 1 ? \@new : $new[0];
190 }
191 elsif ($op ne 'PUSH') {
192 delete $self->{$field};
193 }
194 }
195 @old;
196}
197
198
199sub _sorted_field_names
200
# spent 775µs (503+273) within HTTP::Headers::_sorted_field_names which was called 82 times, avg 9µs/call: # 41 times (222µs+246µs) by HTTP::Headers::scan at line 221, avg 11µs/call # 41 times (280µs+27µs) by HTTP::Headers::header_field_names at line 211, avg 7µs/call
{
201164831µs my $self = shift;
202 return sort {
203 ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
# spent 273µs making 82 calls to HTTP::Headers::CORE:sort, avg 3µs/call
204 $a cmp $b
205 } keys %$self
206}
207
208
209
# spent 651µs (344+307) within HTTP::Headers::header_field_names which was called 41 times, avg 16µs/call: # 41 times (344µs+307µs) by LWP::UserAgent::prepare_request at line 215 of LWP/UserAgent.pm, avg 16µs/call
sub header_field_names {
21082334µs my $self = shift;
211 return map $standard_case{$_} || $_, $self->_sorted_field_names
# spent 307µs making 41 calls to HTTP::Headers::_sorted_field_names, avg 7µs/call
212 if wantarray;
213 return keys %$self;
214}
215
216
217sub scan
218
# spent 2.49ms (1.07+1.42) within HTTP::Headers::scan which was called 41 times, avg 61µs/call: # 41 times (1.07ms+1.42ms) by LWP::Protocol::http::request at line 167 of LWP/Protocol/http.pm, avg 61µs/call
{
219123261µs my($self, $sub) = @_;
220 my $key;
221 foreach $key ($self->_sorted_field_names) {
# spent 468µs making 41 calls to HTTP::Headers::_sorted_field_names, avg 11µs/call
222369391µs12336µs next if $key =~ /^_/;
# spent 36µs making 123 calls to HTTP::Headers::CORE:match, avg 294ns/call
223 my $vals = $self->{$key};
224123212µs if (ref($vals) eq 'ARRAY') {
225 my $val;
226 for $val (@$vals) {
227 &$sub($standard_case{$key} || $key, $val);
228 }
229 }
230 else {
231 &$sub($standard_case{$key} || $key, $vals);
# spent 912µs making 123 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:167], avg 7µs/call
232 }
233 }
234}
235
236
237sub as_string
238{
239 my($self, $endl) = @_;
240 $endl = "\n" unless defined $endl;
241
242 my @result = ();
243 $self->scan(sub {
244 my($field, $val) = @_;
245 $field =~ s/^://;
246 if ($val =~ /\n/) {
247 # must handle header values with embedded newlines with care
248 $val =~ s/\s+$//; # trailing newlines and space must go
249 $val =~ s/\n\n+/\n/g; # no empty lines
250 $val =~ s/\n([^\040\t])/\n $1/g; # intial space for continuation
251 $val =~ s/\n/$endl/g; # substitute with requested line ending
252 }
253 push(@result, "$field: $val");
254 });
255
256 join($endl, @result, '');
257}
258
259
26033µsif (eval { require Storable; 1 }) {
261 *clone = \&Storable::dclone;
262} else {
263 *clone = sub {
264 my $self = shift;
265 my $clone = new HTTP::Headers;
266 $self->scan(sub { $clone->push_header(@_);} );
267 $clone;
268 };
269}
270
271
272sub _date_header
273{
274 require HTTP::Date;
275 my($self, $header, $time) = @_;
276 my($old) = $self->_header($header);
277 if (defined $time) {
278 $self->_header($header, HTTP::Date::time2str($time));
279 }
280 $old =~ s/;.*// if defined($old);
281 HTTP::Date::str2time($old);
282}
283
284
285sub date { shift->_date_header('Date', @_); }
286sub expires { shift->_date_header('Expires', @_); }
287sub if_modified_since { shift->_date_header('If-Modified-Since', @_); }
288sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); }
289sub last_modified { shift->_date_header('Last-Modified', @_); }
290
291# This is used as a private LWP extension. The Client-Date header is
292# added as a timestamp to a response when it has been received.
293sub client_date { shift->_date_header('Client-Date', @_); }
294
295# The retry_after field is dual format (can also be a expressed as
296# number of seconds from now), so we don't provide an easy way to
297# access it until we have know how both these interfaces can be
298# addressed. One possibility is to return a negative value for
299# relative seconds and a positive value for epoch based time values.
300#sub retry_after { shift->_date_header('Retry-After', @_); }
301
302
# spent 2.12ms (2.02+101µs) within HTTP::Headers::content_type which was called 205 times, avg 10µs/call: # 82 times (885µs+33µs) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 11µs/call # 82 times (743µs+44µs) by HTTP::Headers::content_is_xhtml at line 353, avg 10µs/call # 41 times (394µs+24µs) by HTTP::Headers::content_is_html at line 349, avg 10µs/call
sub content_type {
30315171.52ms my $self = shift;
304 my $ct = $self->{'content-type'};
305 $self->{'content-type'} = shift if @_;
306 $ct = $ct->[0] if ref($ct) eq 'ARRAY';
307 return '' unless defined($ct) && length($ct);
308 my @ct = split(/;\s*/, $ct, 2);
309 for ($ct[0]) {
310328696µs164101µs s/\s+//g;
# spent 101µs making 164 calls to HTTP::Headers::CORE:subst, avg 616ns/call
311 $_ = lc($_);
312 }
313 wantarray ? @ct : $ct[0];
314}
315
316sub content_type_charset {
317 my $self = shift;
318 require HTTP::Headers::Util;
319 my $h = $self->{'content-type'};
320 $h = $h->[0] if ref($h);
321 $h = "" unless defined $h;
322 my @v = HTTP::Headers::Util::split_header_words($h);
323 if (@v) {
324 my($ct, undef, %ct_param) = @{$v[0]};
325 my $charset = $ct_param{charset};
326 if ($ct) {
327 $ct = lc($ct);
328 $ct =~ s/\s+//;
329 }
330 if ($charset) {
331 $charset = uc($charset);
332 $charset =~ s/^\s+//; $charset =~ s/\s+\z//;
333 undef($charset) if $charset eq "";
334 }
335 return $ct, $charset if wantarray;
336 return $charset;
337 }
338 return undef, undef if wantarray;
339 return undef;
340}
341
342sub content_is_text {
343 my $self = shift;
344 return $self->content_type =~ m,^text/,;
345}
346
347
# spent 1.57ms (445µs+1.12) within HTTP::Headers::content_is_html which was called 41 times, avg 38µs/call: # 41 times (445µs+1.12ms) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 38µs/call
sub content_is_html {
34882354µs my $self = shift;
349 return $self->content_type eq 'text/html' || $self->content_is_xhtml;
# spent 704µs making 41 calls to HTTP::Headers::content_is_xhtml, avg 17µs/call # spent 418µs making 41 calls to HTTP::Headers::content_type, avg 10µs/call
350}
351
352
# spent 1.31ms (520µs+787µs) within HTTP::Headers::content_is_xhtml which was called 82 times, avg 16µs/call: # 41 times (320µs+384µs) by HTTP::Headers::content_is_html at line 349, avg 17µs/call # 41 times (201µs+403µs) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 15µs/call
sub content_is_xhtml {
353164462µs82787µs my $ct = shift->content_type;
# spent 787µs making 82 calls to HTTP::Headers::content_type, avg 10µs/call
354 return $ct eq "application/xhtml+xml" ||
355 $ct eq "application/vnd.wap.xhtml+xml";
356}
357
358sub content_is_xml {
359 my $ct = shift->content_type;
360 return 1 if $ct eq "text/xml";
361 return 1 if $ct eq "application/xml";
362 return 1 if $ct =~ /\+xml$/;
363 return 0;
364}
365
366sub referer {
367 my $self = shift;
368 if (@_ && $_[0] =~ /#/) {
369 # Strip fragment per RFC 2616, section 14.36.
370 my $uri = shift;
371 if (ref($uri)) {
372 $uri = $uri->clone;
373 $uri->fragment(undef);
374 }
375 else {
376 $uri =~ s/\#.*//;
377 }
378 unshift @_, $uri;
379 }
380 ($self->_header('Referer', @_))[0];
381}
3821400ns*referrer = \&referer; # on tchrist's request
383
384sub title { (shift->_header('Title', @_))[0] }
385sub content_encoding { (shift->_header('Content-Encoding', @_))[0] }
386sub content_language { (shift->_header('Content-Language', @_))[0] }
38741249µs41493µs
# spent 757µs (264+493) within HTTP::Headers::content_length which was called 41 times, avg 18µs/call: # 41 times (264µs+493µs) by HTTP::Message::__ANON__[/usr/local/lib/perl5/site_perl/5.10.1/HTTP/Message.pm:622] at line 622 of HTTP/Message.pm, avg 18µs/call
sub content_length { (shift->_header('Content-Length', @_))[0] }
# spent 493µs making 41 calls to HTTP::Headers::_header, avg 12µs/call
388
389sub user_agent { (shift->_header('User-Agent', @_))[0] }
390sub server { (shift->_header('Server', @_))[0] }
391
392sub from { (shift->_header('From', @_))[0] }
393sub warning { (shift->_header('Warning', @_))[0] }
394
395sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] }
396sub authorization { (shift->_header('Authorization', @_))[0] }
397
398sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] }
399sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] }
400
401sub authorization_basic { shift->_basic_auth("Authorization", @_) }
402sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) }
403
404sub _basic_auth {
405 require MIME::Base64;
406 my($self, $h, $user, $passwd) = @_;
407 my($old) = $self->_header($h);
408 if (defined $user) {
409 Carp::croak("Basic authorization user name can't contain ':'")
410 if $user =~ /:/;
411 $passwd = '' unless defined $passwd;
412 $self->_header($h => 'Basic ' .
413 MIME::Base64::encode("$user:$passwd", ''));
414 }
415 if (defined $old && $old =~ s/^\s*Basic\s+//) {
416 my $val = MIME::Base64::decode($old);
417 return $val unless wantarray;
418 return split(/:/, $val, 2);
419 }
420 return;
421}
422
423
424142µs1;
425
426__END__
427
428=head1 NAME
429
430HTTP::Headers - Class encapsulating HTTP Message headers
431
432=head1 SYNOPSIS
433
434 require HTTP::Headers;
435 $h = HTTP::Headers->new;
436
437 $h->header('Content-Type' => 'text/plain'); # set
438 $ct = $h->header('Content-Type'); # get
439 $h->remove_header('Content-Type'); # delete
440
441=head1 DESCRIPTION
442
443The C<HTTP::Headers> class encapsulates HTTP-style message headers.
444The headers consist of attribute-value pairs also called fields, which
445may be repeated, and which are printed in a particular order. The
446field names are cases insensitive.
447
448Instances of this class are usually created as member variables of the
449C<HTTP::Request> and C<HTTP::Response> classes, internal to the
450library.
451
452The following methods are available:
453
454=over 4
455
456=item $h = HTTP::Headers->new
457
458Constructs a new C<HTTP::Headers> object. You might pass some initial
459attribute-value pairs as parameters to the constructor. I<E.g.>:
460
461 $h = HTTP::Headers->new(
462 Date => 'Thu, 03 Feb 1994 00:00:00 GMT',
463 Content_Type => 'text/html; version=3.2',
464 Content_Base => 'http://www.perl.org/');
465
466The constructor arguments are passed to the C<header> method which is
467described below.
468
469=item $h->clone
470
471Returns a copy of this C<HTTP::Headers> object.
472
473=item $h->header( $field )
474
475=item $h->header( $field => $value )
476
477=item $h->header( $f1 => $v1, $f2 => $v2, ... )
478
479Get or set the value of one or more header fields. The header field
480name ($field) is not case sensitive. To make the life easier for perl
481users who wants to avoid quoting before the => operator, you can use
482'_' as a replacement for '-' in header names.
483
484The header() method accepts multiple ($field => $value) pairs, which
485means that you can update several fields with a single invocation.
486
487The $value argument may be a plain string or a reference to an array
488of strings for a multi-valued field. If the $value is provided as
489C<undef> then the field is removed. If the $value is not given, then
490that header field will remain unchanged.
491
492The old value (or values) of the last of the header fields is returned.
493If no such field exists C<undef> will be returned.
494
495A multi-valued field will be returned as separate values in list
496context and will be concatenated with ", " as separator in scalar
497context. The HTTP spec (RFC 2616) promise that joining multiple
498values in this way will not change the semantic of a header field, but
499in practice there are cases like old-style Netscape cookies (see
500L<HTTP::Cookies>) where "," is used as part of the syntax of a single
501field value.
502
503Examples:
504
505 $header->header(MIME_Version => '1.0',
506 User_Agent => 'My-Web-Client/0.01');
507 $header->header(Accept => "text/html, text/plain, image/*");
508 $header->header(Accept => [qw(text/html text/plain image/*)]);
509 @accepts = $header->header('Accept'); # get multiple values
510 $accepts = $header->header('Accept'); # get values as a single string
511
512=item $h->push_header( $field => $value )
513
514=item $h->push_header( $f1 => $v1, $f2 => $v2, ... )
515
516Add a new field value for the specified header field. Previous values
517for the same field are retained.
518
519As for the header() method, the field name ($field) is not case
520sensitive and '_' can be used as a replacement for '-'.
521
522The $value argument may be a scalar or a reference to a list of
523scalars.
524
525 $header->push_header(Accept => 'image/jpeg');
526 $header->push_header(Accept => [map "image/$_", qw(gif png tiff)]);
527
528=item $h->init_header( $field => $value )
529
530Set the specified header to the given value, but only if no previous
531value for that field is set.
532
533The header field name ($field) is not case sensitive and '_'
534can be used as a replacement for '-'.
535
536The $value argument may be a scalar or a reference to a list of
537scalars.
538
539=item $h->remove_header( $field, ... )
540
541This function removes the header fields with the specified names.
542
543The header field names ($field) are not case sensitive and '_'
544can be used as a replacement for '-'.
545
546The return value is the values of the fields removed. In scalar
547context the number of fields removed is returned.
548
549Note that if you pass in multiple field names then it is generally not
550possible to tell which of the returned values belonged to which field.
551
552=item $h->remove_content_headers
553
554This will remove all the header fields used to describe the content of
555a message. All header field names prefixed with C<Content-> falls
556into this category, as well as C<Allow>, C<Expires> and
557C<Last-Modified>. RFC 2616 denote these fields as I<Entity Header
558Fields>.
559
560The return value is a new C<HTTP::Headers> object that contains the
561removed headers only.
562
563=item $h->clear
564
565This will remove all header fields.
566
567=item $h->header_field_names
568
569Returns the list of distinct names for the fields present in the
570header. The field names have case as suggested by HTTP spec, and the
571names are returned in the recommended "Good Practice" order.
572
573In scalar context return the number of distinct field names.
574
575=item $h->scan( \&process_header_field )
576
577Apply a subroutine to each header field in turn. The callback routine
578is called with two parameters; the name of the field and a single
579value (a string). If a header field is multi-valued, then the
580routine is called once for each value. The field name passed to the
581callback routine has case as suggested by HTTP spec, and the headers
582will be visited in the recommended "Good Practice" order.
583
584Any return values of the callback routine are ignored. The loop can
585be broken by raising an exception (C<die>), but the caller of scan()
586would have to trap the exception itself.
587
588=item $h->as_string
589
590=item $h->as_string( $eol )
591
592Return the header fields as a formatted MIME header. Since it
593internally uses the C<scan> method to build the string, the result
594will use case as suggested by HTTP spec, and it will follow
595recommended "Good Practice" of ordering the header fields. Long header
596values are not folded.
597
598The optional $eol parameter specifies the line ending sequence to
599use. The default is "\n". Embedded "\n" characters in header field
600values will be substituted with this line ending sequence.
601
602=back
603
604=head1 CONVENIENCE METHODS
605
606The most frequently used headers can also be accessed through the
607following convenience Methods. Most of these methods can both be used to read
608and to set the value of a header. The header value is set if you pass
609an argument to the method. The old header value is always returned.
610If the given header did not exist then C<undef> is returned.
611
612Methods that deal with dates/times always convert their value to system
613time (seconds since Jan 1, 1970) and they also expect this kind of
614value when the header value is set.
615
616=over 4
617
618=item $h->date
619
620This header represents the date and time at which the message was
621originated. I<E.g.>:
622
623 $h->date(time); # set current date
624
625=item $h->expires
626
627This header gives the date and time after which the entity should be
628considered stale.
629
630=item $h->if_modified_since
631
632=item $h->if_unmodified_since
633
634These header fields are used to make a request conditional. If the requested
635resource has (or has not) been modified since the time specified in this field,
636then the server will return a C<304 Not Modified> response instead of
637the document itself.
638
639=item $h->last_modified
640
641This header indicates the date and time at which the resource was last
642modified. I<E.g.>:
643
644 # check if document is more than 1 hour old
645 if (my $last_mod = $h->last_modified) {
646 if ($last_mod < time - 60*60) {
647 ...
648 }
649 }
650
651=item $h->content_type
652
653The Content-Type header field indicates the media type of the message
654content. I<E.g.>:
655
656 $h->content_type('text/html');
657
658The value returned will be converted to lower case, and potential
659parameters will be chopped off and returned as a separate value if in
660an array context. If there is no such header field, then the empty
661string is returned. This makes it safe to do the following:
662
663 if ($h->content_type eq 'text/html') {
664 # we enter this place even if the real header value happens to
665 # be 'TEXT/HTML; version=3.0'
666 ...
667 }
668
669=item $h->content_type_charset
670
671Returns the upper-cased charset specified in the Content-Type header. In list
672context return the lower-cased bare content type followed by the upper-cased
673charset. Both values will be C<undef> if not specified in the header.
674
675=item $h->content_is_text
676
677Returns TRUE if the Content-Type header field indicate that the
678content is textual.
679
680=item $h->content_is_html
681
682Returns TRUE if the Content-Type header field indicate that the
683content is some kind of HTML (including XHTML). This method can't be
684used to set Content-Type.
685
686=item $h->content_is_xhtml
687
688Returns TRUE if the Content-Type header field indicate that the
689content is XHTML. This method can't be used to set Content-Type.
690
691=item $h->content_is_xml
692
693Returns TRUE if the Content-Type header field indicate that the
694content is XML. This method can't be used to set Content-Type.
695
696=item $h->content_encoding
697
698The Content-Encoding header field is used as a modifier to the
699media type. When present, its value indicates what additional
700encoding mechanism has been applied to the resource.
701
702=item $h->content_length
703
704A decimal number indicating the size in bytes of the message content.
705
706=item $h->content_language
707
708The natural language(s) of the intended audience for the message
709content. The value is one or more language tags as defined by RFC
7101766. Eg. "no" for some kind of Norwegian and "en-US" for English the
711way it is written in the US.
712
713=item $h->title
714
715The title of the document. In libwww-perl this header will be
716initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element
717of HTML documents. I<This header is no longer part of the HTTP
718standard.>
719
720=item $h->user_agent
721
722This header field is used in request messages and contains information
723about the user agent originating the request. I<E.g.>:
724
725 $h->user_agent('Mozilla/5.0 (compatible; MSIE 7.0; Windows NT 6.0)');
726
727=item $h->server
728
729The server header field contains information about the software being
730used by the originating server program handling the request.
731
732=item $h->from
733
734This header should contain an Internet e-mail address for the human
735user who controls the requesting user agent. The address should be
736machine-usable, as defined by RFC822. E.g.:
737
738 $h->from('King Kong <king@kong.com>');
739
740I<This header is no longer part of the HTTP standard.>
741
742=item $h->referer
743
744Used to specify the address (URI) of the document from which the
745requested resource address was obtained.
746
747The "Free On-line Dictionary of Computing" as this to say about the
748word I<referer>:
749
750 <World-Wide Web> A misspelling of "referrer" which
751 somehow made it into the {HTTP} standard. A given {web
752 page}'s referer (sic) is the {URL} of whatever web page
753 contains the link that the user followed to the current
754 page. Most browsers pass this information as part of a
755 request.
756
757 (1998-10-19)
758
759By popular demand C<referrer> exists as an alias for this method so you
760can avoid this misspelling in your programs and still send the right
761thing on the wire.
762
763When setting the referrer, this method removes the fragment from the
764given URI if it is present, as mandated by RFC2616. Note that
765the removal does I<not> happen automatically if using the header(),
766push_header() or init_header() methods to set the referrer.
767
768=item $h->www_authenticate
769
770This header must be included as part of a C<401 Unauthorized> response.
771The field value consist of a challenge that indicates the
772authentication scheme and parameters applicable to the requested URI.
773
774=item $h->proxy_authenticate
775
776This header must be included in a C<407 Proxy Authentication Required>
777response.
778
779=item $h->authorization
780
781=item $h->proxy_authorization
782
783A user agent that wishes to authenticate itself with a server or a
784proxy, may do so by including these headers.
785
786=item $h->authorization_basic
787
788This method is used to get or set an authorization header that use the
789"Basic Authentication Scheme". In array context it will return two
790values; the user name and the password. In scalar context it will
791return I<"uname:password"> as a single string value.
792
793When used to set the header value, it expects two arguments. I<E.g.>:
794
795 $h->authorization_basic($uname, $password);
796
797The method will croak if the $uname contains a colon ':'.
798
799=item $h->proxy_authorization_basic
800
801Same as authorization_basic() but will set the "Proxy-Authorization"
802header instead.
803
804=back
805
806=head1 NON-CANONICALIZED FIELD NAMES
807
808The header field name spelling is normally canonicalized including the
809'_' to '-' translation. There are some application where this is not
810appropriate. Prefixing field names with ':' allow you to force a
811specific spelling. For example if you really want a header field name
812to show up as C<foo_bar> instead of "Foo-Bar", you might set it like
813this:
814
815 $h->header(":foo_bar" => 1);
816
817These field names are returned with the ':' intact for
818$h->header_field_names and the $h->scan callback, but the colons do
819not show in $h->as_string.
820
821=head1 COPYRIGHT
822
823Copyright 1995-2005 Gisle Aas.
824
825This library is free software; you can redistribute it and/or
826modify it under the same terms as Perl itself.
827
# spent 363µs within HTTP::Headers::CORE:match which was called 779 times, avg 465ns/call: # 615 times (294µs+0s) by HTTP::Headers::_header at line 149 of HTTP/Headers.pm, avg 479ns/call # 123 times (36µs+0s) by HTTP::Headers::scan at line 222 of HTTP/Headers.pm, avg 294ns/call # 41 times (32µs+0s) by HTTP::Headers::remove_header at line 121 of HTTP/Headers.pm, avg 778ns/call
sub HTTP::Headers::CORE:match; # xsub
# spent 273µs within HTTP::Headers::CORE:sort which was called 82 times, avg 3µs/call: # 82 times (273µs+0s) by HTTP::Headers::_sorted_field_names at line 203 of HTTP/Headers.pm, avg 3µs/call
sub HTTP::Headers::CORE:sort; # xsub
# spent 117µs within HTTP::Headers::CORE:subst which was called 168 times, avg 699ns/call: # 164 times (101µs+0s) by HTTP::Headers::content_type at line 310 of HTTP/Headers.pm, avg 616ns/call # 4 times (16µs+0s) by HTTP::Headers::_header at line 155 of HTTP/Headers.pm, avg 4µs/call
sub HTTP::Headers::CORE:subst; # xsub
# spent 22µs within HTTP::Headers::CORE:substcont which was called 14 times, avg 2µs/call: # 14 times (22µs+0s) by HTTP::Headers::_header at line 155 of HTTP/Headers.pm, avg 2µs/call
sub HTTP::Headers::CORE:substcont; # xsub