← Index
NYTProf Performance Profile   « block view • line view • sub view »
For 01.HTTP.t
  Run on Tue May 4 15:25:55 2010
Reported on Tue May 4 15:26:04 2010

File /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Headers.pm
Statements Executed 1255
Statement Execution Time 4.03ms
Subroutines — ordered by exclusive time
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
4551675µs744µsHTTP::Headers::::_headerHTTP::Headers::_header
1953225µs561µsHTTP::Headers::::headerHTTP::Headers::header
1532165µs173µsHTTP::Headers::::content_typeHTTP::Headers::content_type
811101µs361µsHTTP::Headers::::push_headerHTTP::Headers::push_header
31197µs226µsHTTP::Headers::::scanHTTP::Headers::scan
31150µs53µsHTTP::Headers::::remove_headerHTTP::Headers::remove_header
62146µs69µsHTTP::Headers::::_sorted_field_namesHTTP::Headers::_sorted_field_names
72244µs44µsHTTP::Headers::::newHTTP::Headers::new
62241µs105µsHTTP::Headers::::content_is_xhtmlHTTP::Headers::content_is_xhtml
62240µs144µsHTTP::Headers::::init_headerHTTP::Headers::init_header
31136µs126µsHTTP::Headers::::content_is_htmlHTTP::Headers::content_is_html
573233µs33µsHTTP::Headers::::CORE:matchHTTP::Headers::CORE:match (opcode)
141228µs28µsHTTP::Headers::::CORE:substcontHTTP::Headers::CORE:substcont (opcode)
31127µs53µsHTTP::Headers::::header_field_namesHTTP::Headers::header_field_names
162224µs24µsHTTP::Headers::::CORE:substHTTP::Headers::CORE:subst (opcode)
61223µs23µsHTTP::Headers::::CORE:sortHTTP::Headers::CORE:sort (opcode)
31122µs66µsHTTP::Headers::::content_lengthHTTP::Headers::content_length
11115µs18µsHTTP::Headers::::BEGIN@3HTTP::Headers::BEGIN@3
1116µs44µ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
3321µ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
4320µ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.08ms282µs
# spent 44µs (6+38) within HTTP::Headers::BEGIN@6 which was called # once (6µs+38µs) by LWP::UserAgent::BEGIN@10 at line 6
use vars qw($VERSION $TRANSLATE_UNDERSCORE);
# spent 44µs making 1 call to HTTP::Headers::BEGIN@6 # spent 38µs making 1 call to vars::import
71700ns$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
1912µsmy @general_headers = qw(
20 Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade
21 Via Warning
22);
23
2413µ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
3111µsmy @response_headers = qw(
32 Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server
33 Vary WWW-Authenticate
34);
35
3611µ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
41112µsmy %entity_header = map { lc($_) => 1 } @entity_headers;
42
43111µ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{
5621µs my $i = 0;
571600ns for (@header_order) {
58476µs my $lc = lc $_;
594719µs $header_order{$lc} = ++$i;
604722µs $standard_case{$lc} = $_;
61 }
62}
63
64
65
66sub new
67
# spent 44µs within HTTP::Headers::new which was called 7 times, avg 6µs/call: # 6 times (35µ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
{
682858µ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 561µs (225+336) within HTTP::Headers::header which was called 19 times, avg 30µs/call: # 9 times (122µs+227µ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 39µs/call # 3 times (30µs+34µs) by LWP::UserAgent::prepare_request at line 217 of LWP/UserAgent.pm, avg 21µs/call # 3 times (37µs+25µs) by LWP::Protocol::http::request at line 185 of LWP/Protocol/http.pm, avg 21µs/call # 3 times (21µs+23µs) by LWP::Protocol::http::request at line 203 of LWP/Protocol/http.pm, avg 15µs/call # once (15µs+26µs) by LWP::UserAgent::default_header at line 654 of LWP/UserAgent.pm
{
77187207µs 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);
# spent 336µs making 19 calls to HTTP::Headers::_header, avg 18µ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 361µs (101+261) within HTTP::Headers::push_header which was called 8 times, avg 45µs/call: # 8 times (101µs+261µ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 45µs/call
{
1003181µs my $self = shift;
101 return $self->_header(@_, 'PUSH_H') if @_ == 2;
# spent 110µs making 5 calls to HTTP::Headers::_header, avg 22µs/call
102 while (@_) {
103 $self->_header(splice(@_, 0, 2), 'PUSH_H');
# spent 152µs making 12 calls to HTTP::Headers::_header, avg 13µs/call
104 }
105}
106
107
108sub init_header
109
# spent 144µs (40+103) within HTTP::Headers::init_header which was called 6 times, avg 24µs/call: # 3 times (20µs+61µs) by LWP::Protocol::http::_fixup_header at line 98 of LWP/Protocol/http.pm, avg 27µs/call # 3 times (20µs+43µ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 21µs/call
{
1101237µs Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3;
111 shift->_header(@_, 'INIT');
# spent 103µs making 6 calls to HTTP::Headers::_header, avg 17µs/call
112}
113
114
115sub remove_header
116
# spent 53µs (50+3) within HTTP::Headers::remove_header which was called 3 times, avg 18µs/call: # 3 times (50µs+3µ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
{
1172457µs my($self, @fields) = @_;
118 my $field;
119 my @values;
120 foreach $field (@fields) {
121 $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE;
# spent 3µs making 3 calls to HTTP::Headers::CORE:match, avg 867ns/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 744µs (675+69) within HTTP::Headers::_header which was called 45 times, avg 17µs/call: # 19 times (305µs+31µs) by HTTP::Headers::header at line 84, avg 18µs/call # 12 times (145µs+7µs) by HTTP::Headers::push_header at line 103, avg 13µs/call # 6 times (100µs+4µs) by HTTP::Headers::init_header at line 111, avg 17µs/call # 5 times (84µs+26µs) by HTTP::Headers::push_header at line 101, avg 22µs/call # 3 times (42µs+2µs) by HTTP::Headers::content_length at line 387, avg 15µs/call
{
147586748µs my($self, $field, $val, $op) = @_;
148
149 unless ($field =~ /^:/) {
# spent 26µs making 45 calls to HTTP::Headers::CORE:match, avg 589ns/call
150 $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE;
151 my $old = $field;
152 $field = lc $field;
153 unless(defined $standard_case{$field}) {
154 # generate a %standard_case entry for this field
155 $old =~ s/\b(\w)/\u$1/g;
# spent 28µs making 14 calls to HTTP::Headers::CORE:substcont, avg 2µs/call # spent 15µ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';
161 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
180 unless ($op eq 'GET' || ($op eq 'INIT' && @old)) {
181 if (defined($val)) {
182 my @new = ($op eq 'PUSH') ? @old : ();
183 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 69µs (46+23) within HTTP::Headers::_sorted_field_names which was called 6 times, avg 12µs/call: # 3 times (22µs+20µs) by HTTP::Headers::scan at line 221, avg 14µs/call # 3 times (24µs+3µs) by HTTP::Headers::header_field_names at line 211, avg 9µs/call
{
2011276µs my $self = shift;
202 return sort {
203 ($header_order{$a} || 999) <=> ($header_order{$b} || 999) ||
# spent 23µs making 6 calls to HTTP::Headers::CORE:sort, avg 4µs/call
204 $a cmp $b
205 } keys %$self
206}
207
208
209
# spent 53µs (27+26) within HTTP::Headers::header_field_names which was called 3 times, avg 18µs/call: # 3 times (27µs+26µs) by LWP::UserAgent::prepare_request at line 215 of LWP/UserAgent.pm, avg 18µs/call
sub header_field_names {
210625µs my $self = shift;
211 return map $standard_case{$_} || $_, $self->_sorted_field_names
# spent 26µs making 3 calls to HTTP::Headers::_sorted_field_names, avg 9µs/call
212 if wantarray;
213 return keys %$self;
214}
215
216
217sub scan
218
# spent 226µs (97+129) within HTTP::Headers::scan which was called 3 times, avg 75µs/call: # 3 times (97µs+129µs) by LWP::Protocol::http::request at line 167 of LWP/Protocol/http.pm, avg 75µs/call
{
2194583µs my($self, $sub) = @_;
220 my $key;
221 foreach $key ($self->_sorted_field_names) {
# spent 43µs making 3 calls to HTTP::Headers::_sorted_field_names, avg 14µs/call
222 next if $key =~ /^_/;
# spent 4µs making 9 calls to HTTP::Headers::CORE:match, avg 389ns/call
223 my $vals = $self->{$key};
224 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 82µs making 9 calls to LWP::Protocol::http::__ANON__[LWP/Protocol/http.pm:167], avg 9µ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
2603115µ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 173µs (165+9) within HTTP::Headers::content_type which was called 15 times, avg 12µs/call: # 6 times (71µs+3µ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 12µs/call # 6 times (61µs+4µs) by HTTP::Headers::content_is_xhtml at line 353, avg 11µs/call # 3 times (33µs+2µs) by HTTP::Headers::content_is_html at line 349, avg 12µs/call
sub content_type {
303135184µs 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]) {
310 s/\s+//g;
# spent 9µs making 12 calls to HTTP::Headers::CORE:subst, avg 725ns/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 126µs (36+90) within HTTP::Headers::content_is_html which was called 3 times, avg 42µs/call: # 3 times (36µs+90µ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 42µs/call
sub content_is_html {
348627µs my $self = shift;
349 return $self->content_type eq 'text/html' || $self->content_is_xhtml;
# spent 56µs making 3 calls to HTTP::Headers::content_is_xhtml, avg 19µs/call # spent 35µs making 3 calls to HTTP::Headers::content_type, avg 12µs/call
350}
351
352
# spent 105µs (41+64) within HTTP::Headers::content_is_xhtml which was called 6 times, avg 17µs/call: # 3 times (25µs+31µs) by HTTP::Headers::content_is_html at line 349, avg 19µs/call # 3 times (16µ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 16µs/call
sub content_is_xhtml {
3531239µs664µs my $ct = shift->content_type;
# spent 64µs making 6 calls to HTTP::Headers::content_type, avg 11µ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}
38211µs*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] }
387326µs344µs
# spent 66µs (22+44) within HTTP::Headers::content_length which was called 3 times, avg 22µs/call: # 3 times (22µs+44µ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 22µs/call
sub content_length { (shift->_header('Content-Length', @_))[0] }
# spent 44µs making 3 calls to HTTP::Headers::_header, avg 15µ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
424167µ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 33µs within HTTP::Headers::CORE:match which was called 57 times, avg 572ns/call: # 45 times (26µs+0s) by HTTP::Headers::_header at line 149 of HTTP/Headers.pm, avg 589ns/call # 9 times (4µs+0s) by HTTP::Headers::scan at line 222 of HTTP/Headers.pm, avg 389ns/call # 3 times (3µs+0s) by HTTP::Headers::remove_header at line 121 of HTTP/Headers.pm, avg 867ns/call
sub HTTP::Headers::CORE:match; # xsub
# spent 23µs within HTTP::Headers::CORE:sort which was called 6 times, avg 4µs/call: # 6 times (23µs+0s) by HTTP::Headers::_sorted_field_names at line 203 of HTTP/Headers.pm, avg 4µs/call
sub HTTP::Headers::CORE:sort; # xsub
# spent 24µs within HTTP::Headers::CORE:subst which was called 16 times, avg 1µs/call: # 12 times (9µs+0s) by HTTP::Headers::content_type at line 310 of HTTP/Headers.pm, avg 725ns/call # 4 times (15µs+0s) by HTTP::Headers::_header at line 155 of HTTP/Headers.pm, avg 4µs/call
sub HTTP::Headers::CORE:subst; # xsub
# spent 28µs within HTTP::Headers::CORE:substcont which was called 14 times, avg 2µs/call: # 14 times (28µs+0s) by HTTP::Headers::_header at line 155 of HTTP/Headers.pm, avg 2µs/call
sub HTTP::Headers::CORE:substcont; # xsub