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   1940 use strict;
  4         8  
  4         116  
6 4     4   24 use warnings;
  4         8  
  4         112  
7              
8 4     4   20 use parent qw( Protocol::DBus::Authn::Mechanism );
  4         8  
  4         24  
9              
10 4     4   168 use Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces ();
  4         8  
  4         52  
11              
12 4     4   20 use File::Spec ();
  4         8  
  4         80  
13              
14             my $sha_module;
15              
16 4     4   20 use constant must_send_initial => 0;
  4         8  
  4         260  
17              
18             use constant {
19 4         2740 DEBUG => 0,
20 4     4   28 };
  4         8  
21              
22             sub new {
23 1     1 0 6 my ($class) = @_;
24              
25 1         9 local $@;
26              
27 1 50       3 if ( eval { require Digest::SHA1; 1 } ) {
  1 50       231  
  0         0  
28 0         0 $sha_module = 'Digest::SHA1';
29             }
30 1         1136 elsif ( eval { require Digest::SHA; 1 } ) {
  1         4124  
31 1         12 $sha_module = 'Digest::SHA';
32             }
33             else {
34 0         0 die "No SHA module available!";
35             }
36              
37 1         20 return $class->SUPER::new( @_[ 1 .. $#_ ] );
38             }
39              
40             sub INITIAL_RESPONSE {
41 1     1 0 4 my ($self) = @_;
42              
43 1         9 return unpack( 'H*', ($self->_getpw())[0] );
44             }
45              
46             sub AFTER_AUTH {
47 1     1 0 32 my ($self) = @_;
48              
49             return (
50             [ 1 => sub {
51 1     1   8 _consume_data($self, @_);
52 1         37 } ],
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   3 my ($self, $authn, $line) = @_;
67              
68 1 50       6 if (0 != index($line, 'DATA ')) {
69 0         0 die "Invalid line: [$line]";
70             }
71              
72 1         4 substr( $line, 0, 5, q<> );
73              
74 1         12 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         5 my $cookie = $self->_get_cookie($ck_ctx, $ck_id);
85              
86 1         7 my $cl_challenge = _create_challenge();
87              
88 1         16 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         3 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         19 $authn->{'_sha1_response'} = unpack 'H*', "$cl_challenge $str_digest";
106              
107 1         5 return;
108             }
109              
110             sub _authn_respond_data {
111             return (
112             'DATA',
113 1   33 1   7 $_[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         8 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;