"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/LWP/Authen/Digest.pm" (7 Mar 2020, 2463 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::Digest;
    2 
    3 use strict;
    4 use base 'LWP::Authen::Basic';
    5 
    6 our $VERSION = '6.43';
    7 
    8 require Digest::MD5;
    9 
   10 sub _reauth_requested {
   11     my ($class, $auth_param, $ua, $request, $auth_header) = @_;
   12     my $ret = defined($$auth_param{stale}) && lc($$auth_param{stale}) eq 'true';
   13     if ($ret) {
   14         my $hdr = $request->header($auth_header);
   15         $hdr =~ tr/,/;/;    # "," is used to separate auth-params!!
   16         ($hdr) = HTTP::Headers::Util::split_header_words($hdr);
   17         my $nonce = {@$hdr}->{nonce};
   18         delete $$ua{authen_md5_nonce_count}{$nonce};
   19     }
   20     return $ret;
   21 }
   22 
   23 sub auth_header {
   24     my($class, $user, $pass, $request, $ua, $h) = @_;
   25 
   26     my $auth_param = $h->{auth_param};
   27 
   28     my $nc = sprintf "%08X", ++$ua->{authen_md5_nonce_count}{$auth_param->{nonce}};
   29     my $cnonce = sprintf "%8x", time;
   30 
   31     my $uri = $request->uri->path_query;
   32     $uri = "/" unless length $uri;
   33 
   34     my $md5 = Digest::MD5->new;
   35 
   36     my(@digest);
   37     $md5->add(join(":", $user, $auth_param->{realm}, $pass));
   38     push(@digest, $md5->hexdigest);
   39     $md5->reset;
   40 
   41     push(@digest, $auth_param->{nonce});
   42 
   43     if ($auth_param->{qop}) {
   44     push(@digest, $nc, $cnonce, ($auth_param->{qop} =~ m|^auth[,;]auth-int$|) ? 'auth' : $auth_param->{qop});
   45     }
   46 
   47     $md5->add(join(":", $request->method, $uri));
   48     push(@digest, $md5->hexdigest);
   49     $md5->reset;
   50 
   51     $md5->add(join(":", @digest));
   52     my($digest) = $md5->hexdigest;
   53     $md5->reset;
   54 
   55     my %resp = map { $_ => $auth_param->{$_} } qw(realm nonce opaque);
   56     @resp{qw(username uri response algorithm)} = ($user, $uri, $digest, "MD5");
   57 
   58     if (($auth_param->{qop} || "") =~ m|^auth([,;]auth-int)?$|) {
   59     @resp{qw(qop cnonce nc)} = ("auth", $cnonce, $nc);
   60     }
   61 
   62     my(@order) = qw(username realm qop algorithm uri nonce nc cnonce response);
   63     if($request->method =~ /^(?:POST|PUT)$/) {
   64     $md5->add($request->content);
   65     my $content = $md5->hexdigest;
   66     $md5->reset;
   67     $md5->add(join(":", @digest[0..1], $content));
   68     $md5->reset;
   69     $resp{"message-digest"} = $md5->hexdigest;
   70     push(@order, "message-digest");
   71     }
   72     push(@order, "opaque");
   73     my @pairs;
   74     for (@order) {
   75     next unless defined $resp{$_};
   76 
   77     # RFC2617 says that qop-value and nc-value should be unquoted.
   78     if ( $_ eq 'qop' || $_ eq 'nc' ) {
   79         push(@pairs, "$_=" . $resp{$_});
   80     }
   81     else {
   82         push(@pairs, "$_=" . qq("$resp{$_}"));
   83     }
   84     }
   85 
   86     my $auth_value  = "Digest " . join(", ", @pairs);
   87     return $auth_value;
   88 }
   89 
   90 1;