File Coverage

blib/lib/Lock/Socket.pm
Criterion Covered Total %
statement 176 208 84.6
branch 50 70 71.4
condition 10 26 38.4
subroutine 35 36 97.2
pod 5 10 50.0
total 276 350 78.8


line stmt bran cond sub pod time code
1             package Lock::Socket::Mo;
2              
3             #<<< Do not perltidy this
4             BEGIN {
5             # use Mo qw'builder default import is required';
6             # The following line of code was produced from the previous line by
7             # Mo::Inline version 0.39
8 2 50 50 2   1307 no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.::.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};*{$M.'is::e'}=sub{my($P,$e,$o)=@_;$o->{is}=sub{my($m,$n,%a)=@_;$a{is}or return$m;sub{$#_&&$a{is}eq'ro'&&caller ne'Mo::coerce'?die$n.' is ro':$m->(@_)}}};*{$M.'required::e'}=sub{my($P,$e,$o)=@_;$o->{required}=sub{my($m,$n,%a)=@_;if($a{required}){my$C=*{$P."new"}{CODE}||*{$M.Object::new}{CODE};no warnings 'redefine';*{$P."new"}=sub{my$s=$C->(@_);my%a=@_[1..$#_];if(!exists$a{$n}){require Carp;Carp::croak($n." required")}$s}}$m}};@f=qw[builder default import is required];use strict;use warnings;
  2 50 50 2   3  
  2 100 33 2   2521  
  2 50 33 2   12  
  2 100 50 2   3  
  2 50   2   367  
  2 50   2   10  
  2 0   2   8  
  2 0   2   67  
  2 100   2   10  
  2 100   2   3  
  2 50   2   78  
  2 50   2   4  
  2 100   113   17  
  2 100       17  
  29 100       39  
  29 50       97  
  29 50       94  
  29 50       139  
  29 50       58  
  34 50       147  
  29 100       78  
  2 100       25  
  2         8  
  4         31  
  4         7  
  4         13  
  4         7  
  4         324  
  16         83  
  4         16  
  4         37  
  0         0  
  0         0  
  0         0  
  12         21  
  12         40  
  113         662  
  12         43  
  12         78  
  12         20  
  12         54  
  4         16  
  8         48  
  4         13  
  4         220  
  2         8  
  2         16  
  4         7  
  4         238  
  12         39  
  12         85  
  2         9  
  0         0  
  2         8  
  2         29  
  2         6  
  0         0  
  0         0  
  2         8  
  2         21  
  4         8  
  4         254  
  12         34  
  12         50  
  6         13  
  6         56  
  0         0  
  0         0  
  12         176  
  6         15  
  4         18  
  6         13  
  2         17  
  4         28  
  42         150  
  2         5  
  2         6  
  2         7  
  4         53  
  4         15  
  2         13  
  2         25  
  4         9  
  4         313  
  12         35  
  12         25  
  12         104  
  141         1047  
  2         9  
  2         24  
  4         9  
  4         36  
  12         41  
  12         28  
  4         5  
  4         20  
  4         35  
  29         1977  
  29         102  
  29         99  
  1         11  
  1         247  
  28         144  
  12         42  
  2         6  
  2         854  
  0         0  
  0         0  
  2         783  
  0         0  
  0         0  
  2         1045  
  0         0  
  0         0  
  2         773  
  0         0  
  0         0  
  2         885  
  0         0  
  0         0  
  2         772  
  0         0  
  0         0  
  2         816  
  0         0  
  0         0  
  2         833  
  0         0  
  0         0  
9 2         73 $INC{'Lock/Socket/Mo.pm'} = __FILE__;
10             }
11             1;
12             #>>>
13              
14             package Lock::Socket::Error;
15 2     2   9 use Lock::Socket::Mo;
  2         3  
  2         7  
16 2     2   3700 use overload '""' => sub { $_[0]->msg }, fallback => 1;
  2     10   2150  
  2         19  
  10         1675  
17              
18             has msg => (
19             is => 'ro',
20             required => 1,
21             );
22              
23             1;
24              
25             package Lock::Socket;
26 2     2   179 use strict;
  2         3  
  2         62  
27 2     2   8 use warnings;
  2         4  
  2         57  
28 2     2   9 use Carp ();
  2         2  
  2         50  
29 2     2   10 use Lock::Socket::Mo;
  2         3  
  2         11  
30 2     2   2177 use Socket;
  2         9711  
  2         2455  
31              
32             our @VERSION = '0.0.6';
33             our @CARP_NOT;
34              
35             @Lock::Socket::Error::Bind::ISA = ('Lock::Socket::Error');
36             @Lock::Socket::Error::Socket::ISA = ('Lock::Socket::Error');
37             @Lock::Socket::Error::Usage::ISA = ('Lock::Socket::Error');
38             @Lock::Socket::Error::Import::ISA = ('Lock::Socket::Error');
39              
40             ### Function Interface ###
41              
42             sub _uid_ip {
43 0 0 0 0   0 return join( '.', 127, unpack( 'C2', pack( "n", $< ) ), 1 )
44             unless $^O =~ m/bsd$/ or $^O eq 'darwin';
45 0         0 return '127.0.0.1';
46             }
47              
48             sub lock_socket {
49 9   66 9 1 805 my $port = shift
50             || __PACKAGE__->err( 'Usage', 'usage: lock_socket($PORT)' );
51 8         12 my $addr = shift;
52              
53 8 100       51 my $sock = Lock::Socket->new(
54             port => $port,
55             defined $addr ? ( addr => $addr ) : (),
56             );
57 8         22 $sock->lock;
58 5         14 return $sock;
59             }
60              
61             sub lock_user_socket {
62 1   33 1 1 353 my $port = shift
63             || __PACKAGE__->err( 'Usage', 'usage: lock_user_socket($PORT)' );
64 0         0 my $addr = shift;
65              
66 0   0     0 my $sock = Lock::Socket->new(
67             port => $port + $<,
68             addr => $addr || _uid_ip,
69             );
70 0         0 $sock->lock;
71 0         0 return $sock;
72             }
73              
74             sub try_lock_socket {
75 4 100   4 1 988 $_[0] || __PACKAGE__->err( 'Usage', 'usage: try_lock_socket($PORT)' );
76 3         6 return eval { lock_socket(@_) };
  3         23  
77             }
78              
79             sub try_lock_user_socket {
80 1 50   1 1 347 $_[0] || __PACKAGE__->err( 'Usage', 'usage: try_lock_user_socket($PORT)' );
81 0         0 return eval { lock_user_socket(@_) };
  0         0  
82             }
83              
84             sub import {
85 3     3   300 my $class = shift;
86 3         7 my $caller = caller;
87 2     2   26 no strict 'refs';
  2         4  
  2         1363  
88              
89 3         35 foreach my $token (@_) {
90 5 100       22 if ( $token eq 'lock_socket' ) {
    100          
    100          
    100          
91 1         2 *{ $caller . '::lock_socket' } = \&lock_socket;
  1         7  
92             }
93             elsif ( $token eq 'try_lock_socket' ) {
94 1         2 *{ $caller . '::try_lock_socket' } = \&try_lock_socket;
  1         5  
95             }
96             elsif ( $token eq 'lock_user_socket' ) {
97 1         1 *{ $caller . '::lock_user_socket' } = \&lock_user_socket;
  1         5  
98             }
99             elsif ( $token eq 'try_lock_user_socket' ) {
100 1         3 *{ $caller . '::try_lock_user_socket' } = \&try_lock_user_socket;
  1         27  
101             }
102             else {
103 1         4 __PACKAGE__->err( 'Import',
104             'not exported by Lock::Socket: ' . $token );
105             }
106             }
107             }
108              
109             ### Object Attributes ###
110              
111             has port => (
112             is => 'ro',
113             required => 1,
114             );
115              
116             has addr => (
117             is => 'ro',
118             default => '127.0.0.1',
119              
120             );
121              
122             has _inet_addr => (
123             is => 'ro',
124             default => sub {
125             my $self = shift;
126             return inet_aton( $self->addr );
127             },
128             );
129              
130             has _fh => (
131             is => 'rw',
132             lazy => 0,
133             builder => '_fh_builder',
134             );
135              
136             sub _fh_builder {
137 19     19   26 my $self = shift;
138 19 50       3586 socket( my $fh, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
139             || $self->err( 'Socket', "socket: $!" );
140 19         108 return $fh;
141             }
142              
143             sub fh {
144 18     18 0 46 $_[0]->_fh;
145             }
146              
147             has _is_locked => (
148             is => 'rw',
149             lazy => 0,
150             default => sub { 0 },
151             );
152              
153             sub is_locked {
154 6     6 0 969 $_[0]->_is_locked;
155             }
156              
157             ### Object Methods ###
158              
159             sub err {
160 11     11 0 21 my $self = shift;
161 11         26 my $class = 'Lock::Socket::Error::' . $_[0];
162 11         67 local @CARP_NOT = __PACKAGE__;
163 11         1612 die $class->new( msg => Carp::shortmess( $_[1] ) );
164             }
165              
166             sub lock {
167 20     20 1 36 my $self = shift;
168 20 100       37 return 1 if $self->_is_locked;
169              
170 18 100       38 bind( $self->fh, pack_sockaddr_in( $self->port, $self->_inet_addr ) )
171             || $self->err( 'Bind',
172             sprintf( 'bind: %s (%s:%d)', $!, $self->addr, $self->port ) );
173              
174 12         37 $self->_is_locked(1);
175             }
176              
177             sub try_lock {
178 3     3 0 9 my $self = shift;
179 3   100     3 return eval { $self->lock } || 0;
180             }
181              
182             sub unlock {
183 3     3 0 7 my $self = shift;
184 3 100       14 return 1 unless $self->_is_locked;
185              
186 2         6 close( $self->_fh );
187 2         8 $self->_fh( $self->_fh_builder );
188 2         7 $self->_is_locked(0);
189              
190 2         9 return 1;
191             }
192              
193             1;
194              
195             __END__