line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package IPC::SRLock; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
891
|
use 5.010001; |
|
1
|
|
|
|
|
2
|
|
4
|
1
|
|
|
1
|
|
4
|
use namespace::autoclean; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
10
|
|
5
|
1
|
|
|
1
|
|
65
|
use version; our $VERSION = qv( sprintf '0.30.%d', q$Rev: 1 $ =~ /\d+/gmx ); |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
7
|
|
6
|
|
|
|
|
|
|
|
7
|
1
|
|
|
1
|
|
574
|
use File::DataClass::Types qw( HashRef LoadableClass NonEmptySimpleStr Object ); |
|
1
|
|
|
|
|
26849
|
|
|
1
|
|
|
|
|
13
|
|
8
|
1
|
|
|
1
|
|
1007
|
use IPC::SRLock::Utils qw( merge_attributes ); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
6
|
|
9
|
1
|
|
|
1
|
|
176
|
use Moo; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
8
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
my $_build__implementation = sub { |
12
|
5
|
|
|
5
|
|
564
|
return $_[ 0 ]->_implementation_class->new( $_[ 0 ]->_implementation_attr ); |
13
|
|
|
|
|
|
|
}; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
my $_build__implementation_class = sub { |
16
|
5
|
|
|
5
|
|
438
|
my $self = shift; my $type = $self->type; my $class; |
|
5
|
|
|
|
|
22
|
|
|
5
|
|
|
|
|
7
|
|
17
|
|
|
|
|
|
|
|
18
|
5
|
100
|
|
|
|
18
|
if ('+' eq substr $type, 0, 1) { $class = substr $type, 1 } |
|
1
|
|
|
|
|
3
|
|
19
|
4
|
|
|
|
|
13
|
else { $class = __PACKAGE__.'::'.(ucfirst $type) } |
20
|
|
|
|
|
|
|
|
21
|
5
|
|
|
|
|
72
|
return $class; |
22
|
|
|
|
|
|
|
}; |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
# Public attributes |
25
|
|
|
|
|
|
|
has 'type' => is => 'ro', isa => NonEmptySimpleStr, default => 'fcntl'; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# Private attributes |
28
|
|
|
|
|
|
|
has '_implementation' => is => 'lazy', isa => Object, |
29
|
|
|
|
|
|
|
handles => [ qw( get_table list reset set ) ], |
30
|
|
|
|
|
|
|
builder => $_build__implementation; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
has '_implementation_attr' => is => 'ro', isa => HashRef, required => 1; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
has '_implementation_class' => is => 'lazy', isa => LoadableClass, |
35
|
|
|
|
|
|
|
builder => $_build__implementation_class; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# Construction |
38
|
|
|
|
|
|
|
around 'BUILDARGS' => sub { |
39
|
|
|
|
|
|
|
my ($orig, $self, @args) = @_; my $attr = $orig->( $self, @args ); |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
my $builder = $attr->{builder}; |
42
|
|
|
|
|
|
|
my $conf = $builder && $builder->can( 'config' ) ? $builder->config : 0; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
$conf and $conf->can( 'lock_attributes' ) |
45
|
|
|
|
|
|
|
and merge_attributes $attr, $conf->lock_attributes, |
46
|
|
|
|
|
|
|
[ keys %{ $conf->lock_attributes } ]; |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
$attr->{name} //= lc join '_', split m{ :: }mx, __PACKAGE__, -1; |
49
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
my $type = delete $attr->{type}; $attr = { _implementation_attr => $attr }; |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
$type and $type !~ m{ \A ([a-zA-Z0-9\:\+]+) \z }mx |
53
|
|
|
|
|
|
|
and die "Type ${type} tainted"; |
54
|
|
|
|
|
|
|
$type and $attr->{type} = $1; |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
return $attr; |
57
|
|
|
|
|
|
|
}; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub BUILD { |
60
|
5
|
|
|
5
|
1
|
422
|
my $self = shift; $self->_implementation; return; |
|
5
|
|
|
|
|
65
|
|
|
5
|
|
|
|
|
13904
|
|
61
|
|
|
|
|
|
|
} |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
1; |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
__END__ |