Profile of HTTP/Headers.pm

← Index
NYTProf Performance Profile «line view»
For script/ponapi
Run on Wed Feb 10 15:51:26 2016
Reported on Thu Feb 11 09:43:09 2016

Filename | /usr/local/share/perl/5.18.2/HTTP/Headers.pm
Statements | Executed 165 statements in 4.02ms

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