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