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;
|
---|