home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _8a0a6f5079bb26769603d12f74001996 < prev    next >
Text File  |  2000-03-15  |  1KB  |  37 lines
  1. package LWP::Authen::Basic;
  2. use strict;
  3.  
  4. require MIME::Base64;
  5.  
  6. sub authenticate
  7. {
  8.     my($class, $ua, $proxy, $auth_param, $response,
  9.        $request, $arg, $size) = @_;
  10.  
  11.     my($user, $pass) = $ua->get_basic_credentials($auth_param->{realm},
  12.                                                   $request->url, $proxy);
  13.     return $response unless defined $user and defined $pass;
  14.  
  15.     my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
  16.     my $auth_value = "Basic " . MIME::Base64::encode("$user:$pass", "");
  17.  
  18.     # Need to check this isn't a repeated fail!
  19.     my $r = $response;
  20.     while ($r) {
  21.     my $auth = $r->request->header($auth_header);
  22.     if ($auth && $auth eq $auth_value) {
  23.         # here we know this failed before
  24.         $response->header("Client-Warning" =>
  25.                   "Credentials for '$user' failed before");
  26.         return $response;
  27.     }
  28.     $r = $r->previous;
  29.     }
  30.  
  31.     my $referral = $request->clone;
  32.     $referral->header($auth_header => $auth_value);
  33.     return $ua->request($referral, $arg, $size, $response);
  34. }
  35.  
  36. 1;
  37.