tags/0.4.3.1-pre2/CPAN/HTTP/Headers/Auth.pm

   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;