File Coverage

blib/lib/Protocol/DBus/Authn/Mechanism/DBUS_COOKIE_SHA1.pm
Criterion Covered Total %
statement 49 57 85.9
branch 3 6 50.0
condition 1 5 20.0
subroutine 14 15 93.3
pod 0 3 0.0
total 67 86 77.9


line stmt bran cond sub pod time code
1             package Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1;
2              
3             # https://dbus.freedesktop.org/doc/dbus-specification.html#auth-mechanisms-sha
4              
5 4     4   1856 use strict;
  4         12  
  4         112  
6 4     4   20 use warnings;
  4         4  
  4         108  
7              
8 4     4   20 use parent qw( Protocol::DBus::Authn::Mechanism );
  4         8  
  4         20  
9              
10 4     4   164 use Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces ();
  4         8  
  4         52  
11              
12 4     4   16 use File::Spec ();
  4         8  
  4         88  
13              
14             my $sha_module;
15              
16 4     4   16 use constant must_send_initial => 0;
  4         8  
  4         256  
17              
18             use constant {
19 4         2844 DEBUG => 0,
20 4     4   24 };
  4         8  
21              
22             sub new {
23 1     1 0 6 my ($class) = @_;
24              
25 1         2 local $@;
26              
27 1 50       12 if ( eval { require Digest::SHA1; 1 } ) {
  1 50       271  
  0         0  
28 0         0 $sha_module = 'Digest::SHA1';
29             }
30 1         1274 elsif ( eval { require Digest::SHA; 1 } ) {
  1         4337  
31 1         10 $sha_module = 'Digest::SHA';
32             }
33             else {
34 0         0 die "No SHA module available!";
35             }
36              
37 1         35 return $class->SUPER::new( @_[ 1 .. $#_ ] );
38             }
39              
40             sub INITIAL_RESPONSE {
41 1     1 0 5 my ($self) = @_;
42              
43 1         18 return unpack( 'H*', ($self->_getpw())[0] );
44             }
45              
46             sub AFTER_AUTH {
47 1     1 0 40 my ($self) = @_;
48              
49             return (
50             [ 1 => sub {
51 1     1   6 _consume_data($self, @_);
52 1         32 } ],
53             [ 0 => \&_authn_respond_data ],
54             );
55             }
56              
57             sub _getpw {
58 0     0   0 my ($self) = @_;
59              
60 0   0     0 $self->{'_pw'} ||= [ getpwuid $> ];
61              
62 0         0 return @{ $self->{'_pw'} };
  0         0  
63             }
64              
65             sub _consume_data {
66 1     1   5 my ($self, $authn, $line) = @_;
67              
68 1 50       5 if (0 != index($line, 'DATA ')) {
69 0         0 die "Invalid line: [$line]";
70             }
71              
72 1         3 substr( $line, 0, 5, q<> );
73              
74 1         14 my ($ck_ctx, $ck_id, $sr_challenge) = split m< >, pack( 'H*', $line );
75              
76 1         3 if (DEBUG()) {
77             print STDERR (
78             "AUTHN/SHA1 context: $ck_ctx$/",
79             "AUTHN/SHA1 cookie ID: $ck_id$/",
80             "AUTHN/SHA1 server challenge: $sr_challenge$/",
81             );
82             }
83              
84 1         8 my $cookie = $self->_get_cookie($ck_ctx, $ck_id);
85              
86 1         17 my $cl_challenge = _create_challenge();
87              
88 1         20 my $str = join(
89             ':',
90             $sr_challenge,
91             $cl_challenge,
92             $cookie,
93             );
94              
95 1         5 my $str_digest = _sha1_hex($str);
96              
97 1         4 if (DEBUG()) {
98             print STDERR (
99             "AUTHN/SHA1 cookie: $cookie$/",
100             "AUTHN/SHA1 client challenge: $ck_id$/",
101             "AUTHN/SHA1 string: $str$/",
102             );
103             }
104              
105 1         26 $authn->{'_sha1_response'} = unpack 'H*', "$cl_challenge $str_digest";
106              
107 1         7 return;
108             }
109              
110             sub _authn_respond_data {
111             return (
112             'DATA',
113 1   33 1   8 $_[0]->{'_sha1_response'} || do {
114             die "No SHA1 DATA response set!";
115             },
116             );
117             }
118              
119             *_sha1_hex = \&Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces::sha1_hex;
120              
121             *_create_challenge = \&Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces::create_challenge;
122              
123             sub _get_cookie {
124 1     1   3 my ($self, $ck_ctx, $ck_id) = @_;
125              
126 1         7 return Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces::get_cookie(
127             ($self->_getpw())[7],
128             $ck_ctx,
129             $ck_id,
130             );
131             }
132              
133             1;