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 5     5   679554 use strict;
  5         30  
  5         127  
4 5     5   53 use warnings;
  5         14  
  5         219  
5              
6 5     5   26 use File::Spec ();
  5         10  
  5         80  
7              
8 5     5   24 use constant KEYRINGS_DIR => '.dbus-keyrings';
  5         10  
  5         1851  
9              
10             my $sha1_module;
11              
12             sub _sha1_module {
13 3   66 3   21 return $sha1_module ||= do {
14 2 50       5 if ( eval { require Digest::SHA1; 1 } ) {
  2 50       295  
  0         0  
15 0         0 'Digest::SHA1';
16             }
17 2         451 elsif ( eval { require Digest::SHA; 1 } ) {
  2         2575  
18 2         62 '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 794 my $cl_challenge = join(',', map { rand } 1 .. 4 );
  4         49  
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         5 return sha1_hex($cl_challenge);
33             }
34              
35             sub sha1_hex {
36 3     3 0 14 return _sha1_module()->can('sha1_hex')->(@_);
37             }
38              
39             sub get_cookie {
40 5     5 0 9305 my ($homedir, $ck_ctx, $ck_id) = @_;
41              
42 5         67 my $path = File::Spec->catfile(
43             $homedir,
44             KEYRINGS_DIR(),
45             $ck_ctx,
46             );
47              
48 5 100       201 open my $rfh, '<', $path or die "open(< $path): $!";
49              
50 4         76 while ( my $line = <$rfh> ) {
51 6         18 chomp $line;
52              
53 6 100       36 next if 0 != index( $line, "$ck_id " );
54              
55 3         63 return substr( $line, 1 + index($line, q< >, 2 + length($ck_id)) );
56             }
57              
58 1 50       16 warn "readline: $!" if $!;
59              
60 1         26 die "Failed to find cookie “$ck_id” in “$path”!";
61             }
62              
63             1;