line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Plack::Middleware::Auth::Basic; |
2
|
4
|
|
|
4
|
|
20845
|
use strict; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
127
|
|
3
|
4
|
|
|
4
|
|
20
|
use parent qw(Plack::Middleware); |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
25
|
|
4
|
4
|
|
|
4
|
|
219
|
use Plack::Util::Accessor qw( realm authenticator ); |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
22
|
|
5
|
4
|
|
|
4
|
|
20
|
use Scalar::Util; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
173
|
|
6
|
4
|
|
|
4
|
|
1613
|
use MIME::Base64; |
|
4
|
|
|
|
|
2544
|
|
|
4
|
|
|
|
|
1310
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
sub prepare_app { |
9
|
4
|
|
|
4
|
1
|
9
|
my $self = shift; |
10
|
|
|
|
|
|
|
|
11
|
4
|
50
|
|
|
|
16
|
my $auth = $self->authenticator or die 'authenticator is not set'; |
12
|
4
|
50
|
33
|
|
|
32
|
if (Scalar::Util::blessed($auth) && $auth->can('authenticate')) { |
|
|
50
|
|
|
|
|
|
13
|
0
|
|
|
0
|
|
0
|
$self->authenticator(sub { $auth->authenticate(@_[0,1]) }); # because Authen::Simple barfs on 3 params |
|
0
|
|
|
|
|
0
|
|
14
|
|
|
|
|
|
|
} elsif (ref $auth ne 'CODE') { |
15
|
0
|
|
|
|
|
0
|
die 'authenticator should be a code reference or an object that responds to authenticate()'; |
16
|
|
|
|
|
|
|
} |
17
|
|
|
|
|
|
|
} |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub call { |
20
|
10
|
|
|
10
|
1
|
22
|
my($self, $env) = @_; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my $auth = $env->{HTTP_AUTHORIZATION} |
23
|
10
|
100
|
|
|
|
29
|
or return $self->unauthorized; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# note the 'i' on the regex, as, according to RFC2617 this is a |
26
|
|
|
|
|
|
|
# "case-insensitive token to identify the authentication scheme" |
27
|
8
|
50
|
|
|
|
50
|
if ($auth =~ /^Basic (.*)$/i) { |
28
|
8
|
|
50
|
|
|
69
|
my($user, $pass) = split /:/, (MIME::Base64::decode($1) || ":"), 2; |
29
|
8
|
50
|
|
|
|
112
|
$pass = '' unless defined $pass; |
30
|
8
|
100
|
|
|
|
38
|
if ($self->authenticator->($user, $pass, $env)) { |
31
|
6
|
|
|
|
|
62
|
$env->{REMOTE_USER} = $user; |
32
|
6
|
|
|
|
|
29
|
return $self->app->($env); |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
} |
35
|
|
|
|
|
|
|
|
36
|
2
|
|
|
|
|
43
|
return $self->unauthorized; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub unauthorized { |
40
|
4
|
|
|
4
|
0
|
7
|
my $self = shift; |
41
|
4
|
|
|
|
|
6
|
my $body = 'Authorization required'; |
42
|
|
|
|
|
|
|
return [ |
43
|
4
|
|
50
|
|
|
33
|
401, |
44
|
|
|
|
|
|
|
[ 'Content-Type' => 'text/plain', |
45
|
|
|
|
|
|
|
'Content-Length' => length $body, |
46
|
|
|
|
|
|
|
'WWW-Authenticate' => 'Basic realm="' . ($self->realm || "restricted area") . '"' ], |
47
|
|
|
|
|
|
|
[ $body ], |
48
|
|
|
|
|
|
|
]; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
1; |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
__END__ |