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