File Coverage

lib/IPC/SRLock/Utils.pm
Criterion Covered Total %
statement 39 40 100.0
branch 13 14 100.0
condition 5 5 100.0
subroutine 12 12 100.0
pod 5 5 100.0
total 74 76 100.0


line stmt bran cond sub pod time code
1             package IPC::SRLock::Utils;
2              
3 1     1   217703 use strict;
  1         2  
  1         22  
4 1     1   4 use warnings;
  1         1  
  1         24  
5 1     1   3 use parent 'Exporter::Tiny';
  1         1  
  1         7  
6              
7 1     1   418 use IPC::SRLock::Constants qw( EXCEPTION_CLASS );
  1         1  
  1         7  
8 1     1   168 use Scalar::Util qw( blessed );
  1         1  
  1         297  
9              
10             our @EXPORT_OK = qw( Unspecified hash_from loop_until merge_attributes throw );
11              
12             sub Unspecified () {
13 1     1 1 6 return sub { 'Unspecified' };
  1     1   3012  
14             }
15              
16             sub hash_from (;@) {
17 15 100   15 1 27 my (@args) = @_; $args[ 0 ] or return {};
  15         40  
18              
19 14 100       57 return ref $args[ 0 ] ? $args[ 0 ] : { @args };
20             }
21              
22             sub loop_until ($) {
23 7     7 1 9 my $f = shift;
24              
25             return sub {
26 7     7   10 my $self = shift; my $args = $self->_get_args( @_ ); my $start = time;
  7         31  
  6         11  
27              
28 6         7 while (1) {
29 6         6 my $now = time;
30 6 100       15 my $r = $f->( $self, $args, $now ); $r and return $r;
  6         39  
31              
32             # uncoverable branch false
33 2 50       18 $args->{async} and return 0;
34             # uncoverable statement
35 0         0 $self->_sleep_or_timeout( $start, $now, $self->lockfile );
36             }
37 7         35 };
38             }
39              
40             sub merge_attributes ($$;$) {
41 3     3 1 105 my ($dest, $src, $keys) = @_; my $class = blessed $src;
  3         11  
42              
43 3   100     4 for (grep { not exists $dest->{ $_ } or not defined $dest->{ $_ } }
  5         14  
44 3   100     15 @{ $keys // [] }) {
45 4 100       31 my $v = $class ? ($src->can( $_ ) ? $src->$_() : undef) : $src->{ $_ };
    100          
46              
47 4 100       10 defined $v and $dest->{ $_ } = $v;
48             }
49              
50 3         5 return $dest;
51             }
52              
53             sub throw (;@) {
54 5     5 1 36 EXCEPTION_CLASS->throw( @_ );
55             }
56              
57             1;
58              
59             __END__