[27183] | 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;
|
---|