| File | /usr/local/lib/perl5/site_perl/5.10.1/HTTP/Headers.pm |
| Statements Executed | 1255 |
| Statement Execution Time | 4.03ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 45 | 5 | 1 | 675µs | 744µs | HTTP::Headers::_header |
| 19 | 5 | 3 | 225µs | 561µs | HTTP::Headers::header |
| 15 | 3 | 2 | 165µs | 173µs | HTTP::Headers::content_type |
| 8 | 1 | 1 | 101µs | 361µs | HTTP::Headers::push_header |
| 3 | 1 | 1 | 97µs | 226µs | HTTP::Headers::scan |
| 3 | 1 | 1 | 50µs | 53µs | HTTP::Headers::remove_header |
| 6 | 2 | 1 | 46µs | 69µs | HTTP::Headers::_sorted_field_names |
| 7 | 2 | 2 | 44µs | 44µs | HTTP::Headers::new |
| 6 | 2 | 2 | 41µs | 105µs | HTTP::Headers::content_is_xhtml |
| 6 | 2 | 2 | 40µs | 144µs | HTTP::Headers::init_header |
| 3 | 1 | 1 | 36µs | 126µs | HTTP::Headers::content_is_html |
| 57 | 3 | 2 | 33µs | 33µs | HTTP::Headers::CORE:match (opcode) |
| 14 | 1 | 2 | 28µs | 28µs | HTTP::Headers::CORE:substcont (opcode) |
| 3 | 1 | 1 | 27µs | 53µs | HTTP::Headers::header_field_names |
| 16 | 2 | 2 | 24µs | 24µs | HTTP::Headers::CORE:subst (opcode) |
| 6 | 1 | 2 | 23µs | 23µs | HTTP::Headers::CORE:sort (opcode) |
| 3 | 1 | 1 | 22µs | 66µs | HTTP::Headers::content_length |
| 1 | 1 | 1 | 15µs | 18µs | HTTP::Headers::BEGIN@3 |
| 1 | 1 | 1 | 6µs | 44µs | HTTP::Headers::BEGIN@6 |
| 1 | 1 | 1 | 3µs | 3µs | HTTP::Headers::BEGIN@4 |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::__ANON__[:254] |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::__ANON__[:266] |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::__ANON__[:268] |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::_basic_auth |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::_date_header |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::as_string |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::authorization |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::authorization_basic |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::clear |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::client_date |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::content_encoding |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::content_is_text |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::content_is_xml |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::content_language |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::content_type_charset |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::date |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::expires |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::from |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::if_modified_since |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::if_unmodified_since |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::last_modified |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::proxy_authenticate |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::proxy_authorization |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::proxy_authorization_basic |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::referer |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::remove_content_headers |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::server |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::title |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::user_agent |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::warning |
| 0 | 0 | 0 | 0s | 0s | HTTP::Headers::www_authenticate |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package HTTP::Headers; | ||||
| 2 | |||||
| 3 | 3 | 21µs | 2 | 21µ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 # spent 18µs making 1 call to HTTP::Headers::BEGIN@3
# spent 3µs making 1 call to strict::import |
| 4 | 3 | 20µs | 1 | 3µs | # spent 3µs within HTTP::Headers::BEGIN@4 which was called
# once (3µs+0s) by LWP::UserAgent::BEGIN@10 at line 4 # spent 3µs making 1 call to HTTP::Headers::BEGIN@4 |
| 5 | |||||
| 6 | 3 | 2.08ms | 2 | 82µ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 # spent 44µs making 1 call to HTTP::Headers::BEGIN@6
# spent 38µs making 1 call to vars::import |
| 7 | 1 | 700ns | $VERSION = "5.827"; | ||
| 8 | |||||
| 9 | # The $TRANSLATE_UNDERSCORE variable controls whether '_' can be used | ||||
| 10 | # as a replacement for '-' in header field names. | ||||
| 11 | 1 | 500ns | $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 | |||||
| 19 | 1 | 2µs | my @general_headers = qw( | ||
| 20 | Cache-Control Connection Date Pragma Trailer Transfer-Encoding Upgrade | ||||
| 21 | Via Warning | ||||
| 22 | ); | ||||
| 23 | |||||
| 24 | 1 | 3µs | my @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 | |||||
| 31 | 1 | 1µs | my @response_headers = qw( | ||
| 32 | Accept-Ranges Age ETag Location Proxy-Authenticate Retry-After Server | ||||
| 33 | Vary WWW-Authenticate | ||||
| 34 | ); | ||||
| 35 | |||||
| 36 | 1 | 1µs | my @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 | |||||
| 41 | 1 | 12µs | my %entity_header = map { lc($_) => 1 } @entity_headers; | ||
| 42 | |||||
| 43 | 1 | 11µs | my @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. | ||||
| 52 | 1 | 100ns | my %header_order; | ||
| 53 | 1 | 0s | my %standard_case; | ||
| 54 | |||||
| 55 | { | ||||
| 56 | 2 | 1µs | my $i = 0; | ||
| 57 | 1 | 600ns | for (@header_order) { | ||
| 58 | 47 | 6µs | my $lc = lc $_; | ||
| 59 | 47 | 19µs | $header_order{$lc} = ++$i; | ||
| 60 | 47 | 22µs | $standard_case{$lc} = $_; | ||
| 61 | } | ||||
| 62 | } | ||||
| 63 | |||||
| 64 | |||||
| 65 | |||||
| 66 | sub 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 | ||||
| 68 | 7 | 6µs | my($class) = shift; | ||
| 69 | 7 | 20µs | my $self = bless {}, $class; | ||
| 70 | 7 | 3µs | $self->header(@_) if @_; # set up initial headers | ||
| 71 | 7 | 28µs | $self; | ||
| 72 | } | ||||
| 73 | |||||
| 74 | |||||
| 75 | sub 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 | ||||
| 77 | 19 | 7µs | my $self = shift; | ||
| 78 | 19 | 7µs | Carp::croak('Usage: $h->header($field, ...)') unless @_; | ||
| 79 | 19 | 4µs | my(@old); | ||
| 80 | 19 | 4µs | my %seen; | ||
| 81 | 19 | 11µs | while (@_) { | ||
| 82 | 19 | 8µs | my $field = shift; | ||
| 83 | 19 | 28µs | my $op = @_ ? ($seen{lc($field)}++ ? 'PUSH' : 'SET') : 'GET'; | ||
| 84 | 19 | 52µs | 19 | 336µs | @old = $self->_header($field, shift, $op); # spent 336µs making 19 calls to HTTP::Headers::_header, avg 18µs/call |
| 85 | } | ||||
| 86 | 19 | 15µs | return @old if wantarray; | ||
| 87 | 16 | 70µs | return $old[0] if @old <= 1; | ||
| 88 | join(", ", @old); | ||||
| 89 | } | ||||
| 90 | |||||
| 91 | sub clear | ||||
| 92 | { | ||||
| 93 | my $self = shift; | ||||
| 94 | %$self = (); | ||||
| 95 | } | ||||
| 96 | |||||
| 97 | |||||
| 98 | sub 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 | ||||
| 100 | 8 | 3µs | my $self = shift; | ||
| 101 | 8 | 27µs | 5 | 110µs | return $self->_header(@_, 'PUSH_H') if @_ == 2; # spent 110µs making 5 calls to HTTP::Headers::_header, avg 22µs/call |
| 102 | 3 | 15µs | while (@_) { | ||
| 103 | 12 | 35µs | 12 | 152µs | $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 | |||||
| 108 | sub 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 | ||||
| 110 | 6 | 6µs | Carp::croak('Usage: $h->init_header($field, $val)') if @_ != 3; | ||
| 111 | 6 | 31µs | 6 | 103µs | shift->_header(@_, 'INIT'); # spent 103µs making 6 calls to HTTP::Headers::_header, avg 17µs/call |
| 112 | } | ||||
| 113 | |||||
| 114 | |||||
| 115 | sub 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 | ||||
| 117 | 3 | 6µs | my($self, @fields) = @_; | ||
| 118 | 3 | 800ns | my $field; | ||
| 119 | 3 | 800ns | my @values; | ||
| 120 | 3 | 6µs | foreach $field (@fields) { | ||
| 121 | 3 | 15µs | 3 | 3µs | $field =~ tr/_/-/ if $field !~ /^:/ && $TRANSLATE_UNDERSCORE; # spent 3µs making 3 calls to HTTP::Headers::CORE:match, avg 867ns/call |
| 122 | 3 | 6µs | my $v = delete $self->{lc $field}; | ||
| 123 | 3 | 7µs | push(@values, ref($v) eq 'ARRAY' ? @$v : $v) if defined $v; | ||
| 124 | } | ||||
| 125 | 3 | 15µs | return @values; | ||
| 126 | } | ||||
| 127 | |||||
| 128 | sub 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 | |||||
| 145 | sub _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 | ||||
| 147 | 45 | 45µs | my($self, $field, $val, $op) = @_; | ||
| 148 | |||||
| 149 | 45 | 152µs | 45 | 26µs | unless ($field =~ /^:/) { # spent 26µs making 45 calls to HTTP::Headers::CORE:match, avg 589ns/call |
| 150 | 45 | 33µs | $field =~ tr/_/-/ if $TRANSLATE_UNDERSCORE; | ||
| 151 | 45 | 18µs | my $old = $field; | ||
| 152 | 45 | 18µs | $field = lc $field; | ||
| 153 | 45 | 43µs | unless(defined $standard_case{$field}) { | ||
| 154 | # generate a %standard_case entry for this field | ||||
| 155 | 4 | 96µs | 18 | 43µs | $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 | 4 | 7µs | $standard_case{$field} = $old; | ||
| 157 | } | ||||
| 158 | } | ||||
| 159 | |||||
| 160 | 45 | 10µs | $op ||= defined($val) ? 'SET' : 'GET'; | ||
| 161 | 45 | 20µs | if ($op eq 'PUSH_H') { | ||
| 162 | # Like PUSH but where we don't care about the return value | ||||
| 163 | 17 | 9µs | 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 | 17 | 24µs | $self->{$field} = $val; | ||
| 174 | 17 | 53µs | return; | ||
| 175 | } | ||||
| 176 | |||||
| 177 | 28 | 18µs | my $h = $self->{$field}; | ||
| 178 | 28 | 27µs | my @old = ref($h) eq 'ARRAY' ? @$h : (defined($h) ? ($h) : ()); | ||
| 179 | |||||
| 180 | 28 | 17µs | unless ($op eq 'GET' || ($op eq 'INIT' && @old)) { | ||
| 181 | 13 | 7µs | if (defined($val)) { | ||
| 182 | 13 | 9µs | my @new = ($op eq 'PUSH') ? @old : (); | ||
| 183 | 13 | 17µs | if (ref($val) ne 'ARRAY') { | ||
| 184 | push(@new, $val); | ||||
| 185 | } | ||||
| 186 | else { | ||||
| 187 | 3 | 3µs | push(@new, @$val); | ||
| 188 | } | ||||
| 189 | 13 | 35µs | $self->{$field} = @new > 1 ? \@new : $new[0]; | ||
| 190 | } | ||||
| 191 | elsif ($op ne 'PUSH') { | ||||
| 192 | delete $self->{$field}; | ||||
| 193 | } | ||||
| 194 | } | ||||
| 195 | 28 | 87µs | @old; | ||
| 196 | } | ||||
| 197 | |||||
| 198 | |||||
| 199 | sub _sorted_field_names | ||||
| 200 | { | ||||
| 201 | 6 | 3µs | my $self = shift; | ||
| 202 | return sort { | ||||
| 203 | 6 | 73µs | 6 | 23µs | ($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 | ||||
| 210 | 3 | 2µs | my $self = shift; | ||
| 211 | 3 | 23µs | 3 | 26µs | 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 | |||||
| 217 | sub 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 | ||||
| 219 | 3 | 3µs | my($self, $sub) = @_; | ||
| 220 | 3 | 1µs | my $key; | ||
| 221 | 3 | 23µs | 3 | 43µs | foreach $key ($self->_sorted_field_names) { # spent 43µs making 3 calls to HTTP::Headers::_sorted_field_names, avg 14µs/call |
| 222 | 9 | 20µs | 9 | 4µs | next if $key =~ /^_/; # spent 4µs making 9 calls to HTTP::Headers::CORE:match, avg 389ns/call |
| 223 | 9 | 6µs | my $vals = $self->{$key}; | ||
| 224 | 9 | 11µ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 | 9 | 19µs | 9 | 82µs | &$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 | |||||
| 237 | sub 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 | |||||
| 260 | 3 | 115µs | if (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 | |||||
| 272 | sub _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 | |||||
| 285 | sub date { shift->_date_header('Date', @_); } | ||||
| 286 | sub expires { shift->_date_header('Expires', @_); } | ||||
| 287 | sub if_modified_since { shift->_date_header('If-Modified-Since', @_); } | ||||
| 288 | sub if_unmodified_since { shift->_date_header('If-Unmodified-Since', @_); } | ||||
| 289 | sub 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. | ||||
| 293 | sub 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 | ||||
| 303 | 15 | 5µs | my $self = shift; | ||
| 304 | 15 | 9µs | my $ct = $self->{'content-type'}; | ||
| 305 | 15 | 9µs | $self->{'content-type'} = shift if @_; | ||
| 306 | 15 | 6µs | $ct = $ct->[0] if ref($ct) eq 'ARRAY'; | ||
| 307 | 15 | 15µs | return '' unless defined($ct) && length($ct); | ||
| 308 | 12 | 27µs | my @ct = split(/;\s*/, $ct, 2); | ||
| 309 | 12 | 11µs | for ($ct[0]) { | ||
| 310 | 12 | 41µs | 12 | 9µs | s/\s+//g; # spent 9µs making 12 calls to HTTP::Headers::CORE:subst, avg 725ns/call |
| 311 | 12 | 17µs | $_ = lc($_); | ||
| 312 | } | ||||
| 313 | 12 | 44µs | wantarray ? @ct : $ct[0]; | ||
| 314 | } | ||||
| 315 | |||||
| 316 | sub 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 | |||||
| 342 | sub 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 | ||||
| 348 | 3 | 2µs | my $self = shift; | ||
| 349 | 3 | 25µs | 6 | 90µs | 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 | ||||
| 353 | 6 | 11µs | 6 | 64µs | my $ct = shift->content_type; # spent 64µs making 6 calls to HTTP::Headers::content_type, avg 11µs/call |
| 354 | 6 | 28µs | return $ct eq "application/xhtml+xml" || | ||
| 355 | $ct eq "application/vnd.wap.xhtml+xml"; | ||||
| 356 | } | ||||
| 357 | |||||
| 358 | sub 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 | |||||
| 366 | sub 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 | } | ||||
| 382 | 1 | 1µs | *referrer = \&referer; # on tchrist's request | ||
| 383 | |||||
| 384 | sub title { (shift->_header('Title', @_))[0] } | ||||
| 385 | sub content_encoding { (shift->_header('Content-Encoding', @_))[0] } | ||||
| 386 | sub content_language { (shift->_header('Content-Language', @_))[0] } | ||||
| 387 | 3 | 26µs | 3 | 44µ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 # spent 44µs making 3 calls to HTTP::Headers::_header, avg 15µs/call |
| 388 | |||||
| 389 | sub user_agent { (shift->_header('User-Agent', @_))[0] } | ||||
| 390 | sub server { (shift->_header('Server', @_))[0] } | ||||
| 391 | |||||
| 392 | sub from { (shift->_header('From', @_))[0] } | ||||
| 393 | sub warning { (shift->_header('Warning', @_))[0] } | ||||
| 394 | |||||
| 395 | sub www_authenticate { (shift->_header('WWW-Authenticate', @_))[0] } | ||||
| 396 | sub authorization { (shift->_header('Authorization', @_))[0] } | ||||
| 397 | |||||
| 398 | sub proxy_authenticate { (shift->_header('Proxy-Authenticate', @_))[0] } | ||||
| 399 | sub proxy_authorization { (shift->_header('Proxy-Authorization', @_))[0] } | ||||
| 400 | |||||
| 401 | sub authorization_basic { shift->_basic_auth("Authorization", @_) } | ||||
| 402 | sub proxy_authorization_basic { shift->_basic_auth("Proxy-Authorization", @_) } | ||||
| 403 | |||||
| 404 | sub _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 | |||||
| 424 | 1 | 67µs | 1; | ||
| 425 | |||||
| 426 | __END__ | ||||
| 427 | |||||
| 428 | =head1 NAME | ||||
| 429 | |||||
| 430 | HTTP::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 | |||||
| 443 | The C<HTTP::Headers> class encapsulates HTTP-style message headers. | ||||
| 444 | The headers consist of attribute-value pairs also called fields, which | ||||
| 445 | may be repeated, and which are printed in a particular order. The | ||||
| 446 | field names are cases insensitive. | ||||
| 447 | |||||
| 448 | Instances of this class are usually created as member variables of the | ||||
| 449 | C<HTTP::Request> and C<HTTP::Response> classes, internal to the | ||||
| 450 | library. | ||||
| 451 | |||||
| 452 | The following methods are available: | ||||
| 453 | |||||
| 454 | =over 4 | ||||
| 455 | |||||
| 456 | =item $h = HTTP::Headers->new | ||||
| 457 | |||||
| 458 | Constructs a new C<HTTP::Headers> object. You might pass some initial | ||||
| 459 | attribute-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 | |||||
| 466 | The constructor arguments are passed to the C<header> method which is | ||||
| 467 | described below. | ||||
| 468 | |||||
| 469 | =item $h->clone | ||||
| 470 | |||||
| 471 | Returns 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 | |||||
| 479 | Get or set the value of one or more header fields. The header field | ||||
| 480 | name ($field) is not case sensitive. To make the life easier for perl | ||||
| 481 | users who wants to avoid quoting before the => operator, you can use | ||||
| 482 | '_' as a replacement for '-' in header names. | ||||
| 483 | |||||
| 484 | The header() method accepts multiple ($field => $value) pairs, which | ||||
| 485 | means that you can update several fields with a single invocation. | ||||
| 486 | |||||
| 487 | The $value argument may be a plain string or a reference to an array | ||||
| 488 | of strings for a multi-valued field. If the $value is provided as | ||||
| 489 | C<undef> then the field is removed. If the $value is not given, then | ||||
| 490 | that header field will remain unchanged. | ||||
| 491 | |||||
| 492 | The old value (or values) of the last of the header fields is returned. | ||||
| 493 | If no such field exists C<undef> will be returned. | ||||
| 494 | |||||
| 495 | A multi-valued field will be returned as separate values in list | ||||
| 496 | context and will be concatenated with ", " as separator in scalar | ||||
| 497 | context. The HTTP spec (RFC 2616) promise that joining multiple | ||||
| 498 | values in this way will not change the semantic of a header field, but | ||||
| 499 | in practice there are cases like old-style Netscape cookies (see | ||||
| 500 | L<HTTP::Cookies>) where "," is used as part of the syntax of a single | ||||
| 501 | field value. | ||||
| 502 | |||||
| 503 | Examples: | ||||
| 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 | |||||
| 516 | Add a new field value for the specified header field. Previous values | ||||
| 517 | for the same field are retained. | ||||
| 518 | |||||
| 519 | As for the header() method, the field name ($field) is not case | ||||
| 520 | sensitive and '_' can be used as a replacement for '-'. | ||||
| 521 | |||||
| 522 | The $value argument may be a scalar or a reference to a list of | ||||
| 523 | scalars. | ||||
| 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 | |||||
| 530 | Set the specified header to the given value, but only if no previous | ||||
| 531 | value for that field is set. | ||||
| 532 | |||||
| 533 | The header field name ($field) is not case sensitive and '_' | ||||
| 534 | can be used as a replacement for '-'. | ||||
| 535 | |||||
| 536 | The $value argument may be a scalar or a reference to a list of | ||||
| 537 | scalars. | ||||
| 538 | |||||
| 539 | =item $h->remove_header( $field, ... ) | ||||
| 540 | |||||
| 541 | This function removes the header fields with the specified names. | ||||
| 542 | |||||
| 543 | The header field names ($field) are not case sensitive and '_' | ||||
| 544 | can be used as a replacement for '-'. | ||||
| 545 | |||||
| 546 | The return value is the values of the fields removed. In scalar | ||||
| 547 | context the number of fields removed is returned. | ||||
| 548 | |||||
| 549 | Note that if you pass in multiple field names then it is generally not | ||||
| 550 | possible to tell which of the returned values belonged to which field. | ||||
| 551 | |||||
| 552 | =item $h->remove_content_headers | ||||
| 553 | |||||
| 554 | This will remove all the header fields used to describe the content of | ||||
| 555 | a message. All header field names prefixed with C<Content-> falls | ||||
| 556 | into this category, as well as C<Allow>, C<Expires> and | ||||
| 557 | C<Last-Modified>. RFC 2616 denote these fields as I<Entity Header | ||||
| 558 | Fields>. | ||||
| 559 | |||||
| 560 | The return value is a new C<HTTP::Headers> object that contains the | ||||
| 561 | removed headers only. | ||||
| 562 | |||||
| 563 | =item $h->clear | ||||
| 564 | |||||
| 565 | This will remove all header fields. | ||||
| 566 | |||||
| 567 | =item $h->header_field_names | ||||
| 568 | |||||
| 569 | Returns the list of distinct names for the fields present in the | ||||
| 570 | header. The field names have case as suggested by HTTP spec, and the | ||||
| 571 | names are returned in the recommended "Good Practice" order. | ||||
| 572 | |||||
| 573 | In scalar context return the number of distinct field names. | ||||
| 574 | |||||
| 575 | =item $h->scan( \&process_header_field ) | ||||
| 576 | |||||
| 577 | Apply a subroutine to each header field in turn. The callback routine | ||||
| 578 | is called with two parameters; the name of the field and a single | ||||
| 579 | value (a string). If a header field is multi-valued, then the | ||||
| 580 | routine is called once for each value. The field name passed to the | ||||
| 581 | callback routine has case as suggested by HTTP spec, and the headers | ||||
| 582 | will be visited in the recommended "Good Practice" order. | ||||
| 583 | |||||
| 584 | Any return values of the callback routine are ignored. The loop can | ||||
| 585 | be broken by raising an exception (C<die>), but the caller of scan() | ||||
| 586 | would have to trap the exception itself. | ||||
| 587 | |||||
| 588 | =item $h->as_string | ||||
| 589 | |||||
| 590 | =item $h->as_string( $eol ) | ||||
| 591 | |||||
| 592 | Return the header fields as a formatted MIME header. Since it | ||||
| 593 | internally uses the C<scan> method to build the string, the result | ||||
| 594 | will use case as suggested by HTTP spec, and it will follow | ||||
| 595 | recommended "Good Practice" of ordering the header fields. Long header | ||||
| 596 | values are not folded. | ||||
| 597 | |||||
| 598 | The optional $eol parameter specifies the line ending sequence to | ||||
| 599 | use. The default is "\n". Embedded "\n" characters in header field | ||||
| 600 | values will be substituted with this line ending sequence. | ||||
| 601 | |||||
| 602 | =back | ||||
| 603 | |||||
| 604 | =head1 CONVENIENCE METHODS | ||||
| 605 | |||||
| 606 | The most frequently used headers can also be accessed through the | ||||
| 607 | following convenience Methods. Most of these methods can both be used to read | ||||
| 608 | and to set the value of a header. The header value is set if you pass | ||||
| 609 | an argument to the method. The old header value is always returned. | ||||
| 610 | If the given header did not exist then C<undef> is returned. | ||||
| 611 | |||||
| 612 | Methods that deal with dates/times always convert their value to system | ||||
| 613 | time (seconds since Jan 1, 1970) and they also expect this kind of | ||||
| 614 | value when the header value is set. | ||||
| 615 | |||||
| 616 | =over 4 | ||||
| 617 | |||||
| 618 | =item $h->date | ||||
| 619 | |||||
| 620 | This header represents the date and time at which the message was | ||||
| 621 | originated. I<E.g.>: | ||||
| 622 | |||||
| 623 | $h->date(time); # set current date | ||||
| 624 | |||||
| 625 | =item $h->expires | ||||
| 626 | |||||
| 627 | This header gives the date and time after which the entity should be | ||||
| 628 | considered stale. | ||||
| 629 | |||||
| 630 | =item $h->if_modified_since | ||||
| 631 | |||||
| 632 | =item $h->if_unmodified_since | ||||
| 633 | |||||
| 634 | These header fields are used to make a request conditional. If the requested | ||||
| 635 | resource has (or has not) been modified since the time specified in this field, | ||||
| 636 | then the server will return a C<304 Not Modified> response instead of | ||||
| 637 | the document itself. | ||||
| 638 | |||||
| 639 | =item $h->last_modified | ||||
| 640 | |||||
| 641 | This header indicates the date and time at which the resource was last | ||||
| 642 | modified. 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 | |||||
| 653 | The Content-Type header field indicates the media type of the message | ||||
| 654 | content. I<E.g.>: | ||||
| 655 | |||||
| 656 | $h->content_type('text/html'); | ||||
| 657 | |||||
| 658 | The value returned will be converted to lower case, and potential | ||||
| 659 | parameters will be chopped off and returned as a separate value if in | ||||
| 660 | an array context. If there is no such header field, then the empty | ||||
| 661 | string 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 | |||||
| 671 | Returns the upper-cased charset specified in the Content-Type header. In list | ||||
| 672 | context return the lower-cased bare content type followed by the upper-cased | ||||
| 673 | charset. Both values will be C<undef> if not specified in the header. | ||||
| 674 | |||||
| 675 | =item $h->content_is_text | ||||
| 676 | |||||
| 677 | Returns TRUE if the Content-Type header field indicate that the | ||||
| 678 | content is textual. | ||||
| 679 | |||||
| 680 | =item $h->content_is_html | ||||
| 681 | |||||
| 682 | Returns TRUE if the Content-Type header field indicate that the | ||||
| 683 | content is some kind of HTML (including XHTML). This method can't be | ||||
| 684 | used to set Content-Type. | ||||
| 685 | |||||
| 686 | =item $h->content_is_xhtml | ||||
| 687 | |||||
| 688 | Returns TRUE if the Content-Type header field indicate that the | ||||
| 689 | content is XHTML. This method can't be used to set Content-Type. | ||||
| 690 | |||||
| 691 | =item $h->content_is_xml | ||||
| 692 | |||||
| 693 | Returns TRUE if the Content-Type header field indicate that the | ||||
| 694 | content is XML. This method can't be used to set Content-Type. | ||||
| 695 | |||||
| 696 | =item $h->content_encoding | ||||
| 697 | |||||
| 698 | The Content-Encoding header field is used as a modifier to the | ||||
| 699 | media type. When present, its value indicates what additional | ||||
| 700 | encoding mechanism has been applied to the resource. | ||||
| 701 | |||||
| 702 | =item $h->content_length | ||||
| 703 | |||||
| 704 | A decimal number indicating the size in bytes of the message content. | ||||
| 705 | |||||
| 706 | =item $h->content_language | ||||
| 707 | |||||
| 708 | The natural language(s) of the intended audience for the message | ||||
| 709 | content. The value is one or more language tags as defined by RFC | ||||
| 710 | 1766. Eg. "no" for some kind of Norwegian and "en-US" for English the | ||||
| 711 | way it is written in the US. | ||||
| 712 | |||||
| 713 | =item $h->title | ||||
| 714 | |||||
| 715 | The title of the document. In libwww-perl this header will be | ||||
| 716 | initialized automatically from the E<lt>TITLE>...E<lt>/TITLE> element | ||||
| 717 | of HTML documents. I<This header is no longer part of the HTTP | ||||
| 718 | standard.> | ||||
| 719 | |||||
| 720 | =item $h->user_agent | ||||
| 721 | |||||
| 722 | This header field is used in request messages and contains information | ||||
| 723 | about 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 | |||||
| 729 | The server header field contains information about the software being | ||||
| 730 | used by the originating server program handling the request. | ||||
| 731 | |||||
| 732 | =item $h->from | ||||
| 733 | |||||
| 734 | This header should contain an Internet e-mail address for the human | ||||
| 735 | user who controls the requesting user agent. The address should be | ||||
| 736 | machine-usable, as defined by RFC822. E.g.: | ||||
| 737 | |||||
| 738 | $h->from('King Kong <king@kong.com>'); | ||||
| 739 | |||||
| 740 | I<This header is no longer part of the HTTP standard.> | ||||
| 741 | |||||
| 742 | =item $h->referer | ||||
| 743 | |||||
| 744 | Used to specify the address (URI) of the document from which the | ||||
| 745 | requested resource address was obtained. | ||||
| 746 | |||||
| 747 | The "Free On-line Dictionary of Computing" as this to say about the | ||||
| 748 | word 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 | |||||
| 759 | By popular demand C<referrer> exists as an alias for this method so you | ||||
| 760 | can avoid this misspelling in your programs and still send the right | ||||
| 761 | thing on the wire. | ||||
| 762 | |||||
| 763 | When setting the referrer, this method removes the fragment from the | ||||
| 764 | given URI if it is present, as mandated by RFC2616. Note that | ||||
| 765 | the removal does I<not> happen automatically if using the header(), | ||||
| 766 | push_header() or init_header() methods to set the referrer. | ||||
| 767 | |||||
| 768 | =item $h->www_authenticate | ||||
| 769 | |||||
| 770 | This header must be included as part of a C<401 Unauthorized> response. | ||||
| 771 | The field value consist of a challenge that indicates the | ||||
| 772 | authentication scheme and parameters applicable to the requested URI. | ||||
| 773 | |||||
| 774 | =item $h->proxy_authenticate | ||||
| 775 | |||||
| 776 | This header must be included in a C<407 Proxy Authentication Required> | ||||
| 777 | response. | ||||
| 778 | |||||
| 779 | =item $h->authorization | ||||
| 780 | |||||
| 781 | =item $h->proxy_authorization | ||||
| 782 | |||||
| 783 | A user agent that wishes to authenticate itself with a server or a | ||||
| 784 | proxy, may do so by including these headers. | ||||
| 785 | |||||
| 786 | =item $h->authorization_basic | ||||
| 787 | |||||
| 788 | This method is used to get or set an authorization header that use the | ||||
| 789 | "Basic Authentication Scheme". In array context it will return two | ||||
| 790 | values; the user name and the password. In scalar context it will | ||||
| 791 | return I<"uname:password"> as a single string value. | ||||
| 792 | |||||
| 793 | When used to set the header value, it expects two arguments. I<E.g.>: | ||||
| 794 | |||||
| 795 | $h->authorization_basic($uname, $password); | ||||
| 796 | |||||
| 797 | The method will croak if the $uname contains a colon ':'. | ||||
| 798 | |||||
| 799 | =item $h->proxy_authorization_basic | ||||
| 800 | |||||
| 801 | Same as authorization_basic() but will set the "Proxy-Authorization" | ||||
| 802 | header instead. | ||||
| 803 | |||||
| 804 | =back | ||||
| 805 | |||||
| 806 | =head1 NON-CANONICALIZED FIELD NAMES | ||||
| 807 | |||||
| 808 | The header field name spelling is normally canonicalized including the | ||||
| 809 | '_' to '-' translation. There are some application where this is not | ||||
| 810 | appropriate. Prefixing field names with ':' allow you to force a | ||||
| 811 | specific spelling. For example if you really want a header field name | ||||
| 812 | to show up as C<foo_bar> instead of "Foo-Bar", you might set it like | ||||
| 813 | this: | ||||
| 814 | |||||
| 815 | $h->header(":foo_bar" => 1); | ||||
| 816 | |||||
| 817 | These field names are returned with the ':' intact for | ||||
| 818 | $h->header_field_names and the $h->scan callback, but the colons do | ||||
| 819 | not show in $h->as_string. | ||||
| 820 | |||||
| 821 | =head1 COPYRIGHT | ||||
| 822 | |||||
| 823 | Copyright 1995-2005 Gisle Aas. | ||||
| 824 | |||||
| 825 | This library is free software; you can redistribute it and/or | ||||
| 826 | modify 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 | |||||
# 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 | |||||
# 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 | |||||
# 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 |