local-lib5/lib/perl5/LWP/Authen/Basic.pm

   1 package LWP::Authen::Basic;
   2 use strict;
   3
   4 require MIME::Base64;
   5
   6 sub auth_header {
   7     my($class, $user, $pass) = @_;
   8     return "Basic " . MIME::Base64::encode("$user:$pass", "");
   9 }
  10
  11 sub authenticate
  12 {
  13     my($class, $ua, $proxy, $auth_param, $response,
  14        $request, $arg, $size) = @_;
  15
  16     my $realm = $auth_param->{realm} || "";
  17     my $url = $proxy ? $request->{proxy} : $request->uri_canonical;
  18     return $response unless $url;
  19     my $host_port = $url->host_port;
  20     my $auth_header = $proxy ? "Proxy-Authorization" : "Authorization";
  21
  22     my @m = $proxy ? (m_proxy => $url) : (m_host_port => $host_port);
  23     push(@m, realm => $realm);
  24
  25     my $h = $ua->get_my_handler("request_prepare", @m, sub {
  26         $_[0]{callback} = sub {
  27             my($req, $ua, $h) = @_;
  28             my($user, $pass) = $ua->credentials($host_port, $h->{realm});
  29             if (defined $user) {
  30                 my $auth_value = $class->auth_header($user, $pass, $req, $ua, $h);
  31                 $req->header($auth_header => $auth_value);
  32             }
  33         };
  34     });
  35     $h->{auth_param} = $auth_param;
  36
  37     if (!$proxy && !$request->header($auth_header) && $ua->credentials($host_port, $realm)) {
  38         # we can make sure this handler applies and retry
  39         add_path($h, $url->path);
  40         return $ua->request($request->clone, $arg, $size, $response);
  41     }
  42
  43     my($user, $pass) = $ua->get_basic_credentials($realm, $url, $proxy);
  44     unless (defined $user and defined $pass) {
  45         $ua->set_my_handler("request_prepare", undef, @m);  # delete handler
  46         return $response;
  47     }
  48
  49     # check that the password has changed
  50     my ($olduser, $oldpass) = $ua->credentials($host_port, $realm);
  51     return $response if (defined $olduser and defined $oldpass and
  52                          $user eq $olduser and $pass eq $oldpass);
  53
  54     $ua->credentials($host_port, $realm, $user, $pass);
  55     add_path($h, $url->path) unless $proxy;
  56     return $ua->request($request->clone, $arg, $size, $response);
  57 }
  58
  59 sub add_path {
  60     my($h, $path) = @_;
  61     $path =~ s,[^/]+\z,,;
  62     push(@{$h->{m_path_prefix}}, $path);
  63 }
  64
  65 1;