File Coverage

blib/lib/HTTP/Headers/Auth.pm
Criterion Covered Total %
statement 56 56 100.0
branch 21 22 95.4
condition 3 3 100.0
subroutine 8 8 100.0
pod 2 2 100.0
total 90 91 98.9


line stmt bran cond sub pod time code
1             package HTTP::Headers::Auth;
2              
3 1     1   492 use strict;
  1         3  
  1         31  
4 1     1   5 use warnings;
  1         2  
  1         46  
5              
6             our $VERSION = '6.43';
7              
8 1     1   6 use HTTP::Headers;
  1         2  
  1         40  
9              
10             package
11             HTTP::Headers;
12              
13             BEGIN {
14             # we provide a new (and better) implementations below
15 1     1   8 undef(&www_authenticate);
16 1         539 undef(&proxy_authenticate);
17             }
18              
19             require HTTP::Headers::Util;
20              
21             sub _parse_authenticate
22             {
23 4     4   5 my @ret;
24 4         13 for (HTTP::Headers::Util::split_header_words(@_)) {
25 9 100       18 if (!defined($_->[1])) {
26             # this is a new auth scheme
27 6         14 push(@ret, shift(@$_) => {});
28 6         9 shift @$_;
29             }
30 9 50       18 if (@ret) {
31             # this a new parameter pair for the last auth scheme
32 9         15 while (@$_) {
33 6         13 my $k = shift @$_;
34 6         8 my $v = shift @$_;
35 6         18 $ret[-1]{$k} = $v;
36             }
37             }
38             else {
39             # something wrong, parameter pair without any scheme seen
40             # IGNORE
41             }
42             }
43 4         22 @ret;
44             }
45              
46             sub _authenticate
47             {
48 8     8   11 my $self = shift;
49 8         15 my $header = shift;
50 8         24 my @old = $self->_header($header);
51 8 100       18 if (@_) {
52 6         18 $self->remove_header($header);
53 6         14 my @new = @_;
54 6         15 while (@new) {
55 8         12 my $a_scheme = shift(@new);
56 8 100       25 if ($a_scheme =~ /\s/) {
57             # assume complete valid value, pass it through
58 1         4 $self->push_header($header, $a_scheme);
59             }
60             else {
61 7         10 my @param;
62 7 100       18 if (@new) {
63 5         8 my $p = $new[0];
64 5 100       18 if (ref($p) eq "ARRAY") {
    100          
65 1         4 @param = @$p;
66 1         2 shift(@new);
67             }
68             elsif (ref($p) eq "HASH") {
69 3         10 @param = %$p;
70 3         7 shift(@new);
71             }
72             }
73 7         16 my $val = ucfirst(lc($a_scheme));
74 7 100       14 if (@param) {
75 4         7 my $sep = " ";
76 4         10 while (@param) {
77 6         9 my $k = shift @param;
78 6         11 my $v = shift @param;
79 6 100 100     26 if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
80             # must quote the value
81 3         7 $v =~ s,([\\\"]),\\$1,g;
82 3         8 $v = qq("$v");
83             }
84 6         12 $val .= "$sep$k=$v";
85 6         15 $sep = ", ";
86             }
87             }
88 7         19 $self->push_header($header, $val);
89             }
90             }
91             }
92 8 100       25 return unless defined wantarray;
93 5 100       19 wantarray ? _parse_authenticate(@old) : join(", ", @old);
94             }
95              
96              
97 5     5 1 16 sub www_authenticate { shift->_authenticate("WWW-Authenticate", @_) }
98 3     3 1 22 sub proxy_authenticate { shift->_authenticate("Proxy-Authenticate", @_) }
99              
100             1;
101              
102             __END__