"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/LWP/Authen/Basic.pm" (7 Mar 2020, 2356 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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