Filename | /usr/local/share/perl/5.18.2/HTTP/Headers.pm |
Statements | Executed 165 statements in 4.02ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 13µs | 33µs | BEGIN@3 | HTTP::Headers::
1 | 1 | 1 | 13µs | 22µs | BEGIN@4 | HTTP::Headers::
1 | 1 | 1 | 5µs | 5µs | BEGIN@6 | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | __ANON__[:308] | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | __ANON__[:310] | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | _basic_auth | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | _date_header | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | _header | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | _process_newline | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | _sorted_field_names | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | as_string | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | authorization | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | authorization_basic | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | clear | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | client_date | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_encoding | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_is_html | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_is_text | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_is_xhtml | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_is_xml | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_language | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_length | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_type | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | content_type_charset | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | date | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | expires | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | flatten | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | from | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | header | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | header_field_names | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | if_modified_since | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | if_unmodified_since | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | init_header | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | last_modified | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | new | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | proxy_authenticate | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | proxy_authorization | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | proxy_authorization_basic | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | push_header | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | referer | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | remove_content_headers | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | remove_header | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | scan | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | server | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | title | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | user_agent | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | warning | HTTP::Headers::
0 | 0 | 0 | 0s | 0s | www_authenticate | HTTP::Headers::
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 # 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 # 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 # 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__ |