[27174] | 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;
|
---|