home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _c04ebb6c4812d3767b659bebb9ba5c65 < prev    next >
Encoding:
Text File  |  2000-03-15  |  2.1 KB  |  95 lines
  1. package HTTP::Headers::Auth;
  2.  
  3. use strict;
  4. use vars qw($VERSION);
  5. $VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\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.     } else {
  35.         # something wrong, parameter pair without any scheme seen
  36.         # IGNORE
  37.     }
  38.     }
  39.     @ret;
  40. }
  41.  
  42. sub _authenticate
  43. {
  44.     my $self = shift;
  45.     my $header = shift;
  46.     my @old = $self->_header($header);
  47.     if (@_) {
  48.     $self->remove_header($header);
  49.     my @new = @_;
  50.     while (@new) {
  51.         my $a_scheme = shift(@new);
  52.         if ($a_scheme =~ /\s/) {
  53.         # assume complete valid value, pass it through
  54.         $self->push_header($header, $a_scheme);
  55.         } else {
  56.         my @param;
  57.         if (@new) {
  58.             my $p = $new[0];
  59.             if (ref($p) eq "ARRAY") {
  60.             @param = @$p;
  61.             shift(@new);
  62.             } elsif (ref($p) eq "HASH") {
  63.             @param = %$p;
  64.             shift(@new);
  65.             }
  66.         }
  67.         my $val = ucfirst(lc($a_scheme));
  68.         if (@param) {
  69.             my $sep = " ";
  70.             while (@param) {
  71.             my $k = shift @param;
  72.             my $v = shift @param;
  73.             if ($v =~ /[^0-9a-zA-Z]/ || lc($k) eq "realm") {
  74.                 # must quote the value
  75.                 $v =~ s,([\\\"]),\\$1,g;
  76.                 $v = qq("$v");
  77.             }
  78.             $val .= "$sep$k=$v";
  79.             $sep = ", ";
  80.             }
  81.         }
  82.         $self->push_header($header, $val);
  83.         }
  84.     }
  85.     }
  86.     return unless defined wantarray;
  87.     wantarray ? _parse_authenticate(@old) : join(", ", @old);
  88. }
  89.  
  90.  
  91. sub www_authenticate    { shift->_authenticate("WWW-Authenticate", @_)   }
  92. sub proxy_authenticate  { shift->_authenticate("Proxy-Authenticate", @_) }
  93.  
  94. 1;
  95.