File Coverage

blib/lib/Protocol/DBus/Authn/Mechanism/DBUS_COOKIE_SHA1/Pieces.pm
Criterion Covered Total %
statement 31 34 91.1
branch 7 10 70.0
condition 2 3 66.6
subroutine 8 8 100.0
pod 0 3 0.0
total 48 58 82.7


line stmt bran cond sub pod time code
1             package Protocol::DBus::Authn::Mechanism::DBUS_COOKIE_SHA1::Pieces;
2              
3 6     6   892152 use strict;
  6         38  
  6         144  
4 6     6   30 use warnings;
  6         13  
  6         129  
5              
6 6     6   30 use File::Spec ();
  6         7  
  6         103  
7              
8 6     6   26 use constant KEYRINGS_DIR => '.dbus-keyrings';
  6         12  
  6         2338  
9              
10             my $sha1_module;
11              
12             sub _sha1_module {
13 4   66 4   28 return $sha1_module ||= do {
14 3 50       7 if ( eval { require Digest::SHA1; 1 } ) {
  3 50       427  
  0         0  
15 0         0 'Digest::SHA1';
16             }
17 3         589 elsif ( eval { require Digest::SHA; 1 } ) {
  3         3210  
18 3         116 'Digest::SHA';
19             }
20             else {
21 0         0 die "No SHA module available!";
22             }
23             };
24             }
25              
26             sub create_challenge {
27 1     1 0 984 my $cl_challenge = join(',', map { rand } 1 .. 4 );
  4         58  
28              
29             # Ensure that we use only hex characters for the challenge,
30             # or else the challenge might have a colon, space, or something else
31             # problematic.
32 1         6 return sha1_hex($cl_challenge);
33             }
34              
35             sub sha1_hex {
36 4     4 0 21 return _sha1_module()->can('sha1_hex')->(@_);
37             }
38              
39             sub get_cookie {
40 6     6 0 11043 my ($homedir, $ck_ctx, $ck_id) = @_;
41              
42 6         97 my $path = File::Spec->catfile(
43             $homedir,
44             KEYRINGS_DIR(),
45             $ck_ctx,
46             );
47              
48 6 100       305 open my $rfh, '<', $path or die "open(< $path): $!";
49              
50 5         129 while ( my $line = <$rfh> ) {
51 7         21 chomp $line;
52              
53 7 100       59 next if 0 != index( $line, "$ck_id " );
54              
55 4         88 return substr( $line, 1 + index($line, q< >, 2 + length($ck_id)) );
56             }
57              
58 1 50       21 warn "readline: $!" if $!;
59              
60 1         37 die "Failed to find cookie “$ck_id” in “$path”!";
61             }
62              
63             1;