File Coverage

blib/lib/Lock/Socket.pm

Criterion	Covered	Total	%
statement	172	197	87.3
branch	46	64	71.8
condition	11	20	55.0
subroutine	33	33	100.0
pod	1	6	16.6
total	263	320	82.1

package Lock::Socket::Mo;

#<<< Do not perltidy this
BEGIN {
# use Mo qw'builder default import is required';
#   The following line of code was produced from the previous line by
#   Mo::Inline version 0.39
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;
$INC{'Lock/Socket/Mo.pm'} = __FILE__;
}
1;
#>>>

package Lock::Socket::Error;
use Lock::Socket::Mo;
use overload '""' => sub { $_[0]->msg }, fallback => 1;

has msg => (
    is       => 'ro',
    required => 1,
);

1;

package Lock::Socket;
use strict;
use warnings;
use Carp ();
use Lock::Socket::Mo;
use Socket;

our @VERSION = '0.0.4';
our @CARP_NOT;

@Lock::Socket::Error::Bind::ISA   = ('Lock::Socket::Error');
@Lock::Socket::Error::Socket::ISA = ('Lock::Socket::Error');
@Lock::Socket::Error::Usage::ISA  = ('Lock::Socket::Error');
@Lock::Socket::Error::Import::ISA = ('Lock::Socket::Error');

### Function Interface ###

sub import {
    my $class  = shift;
    my $caller = caller;
    no strict 'refs';

    foreach my $token (@_) {
        if ( $token eq 'lock_socket' ) {
            *{ $caller . '::lock_socket' } = sub {
                my $port = shift
                  || __PACKAGE__->err( 'Usage', 'usage: lock_socket($PORT)' );
                my $addr = shift;
                my $sock = Lock::Socket->new(
                    port => $port,
                    defined $addr ? ( addr => $addr ) : (),
                );
                $sock->lock;
                return $sock;
            };
        }
        elsif ( $token eq 'try_lock_socket' ) {
            *{ $caller . '::try_lock_socket' } = sub {
                my $port = shift
                  || __PACKAGE__->err( 'Usage',
                    'usage: try_lock_socket($PORT)' );
                my $addr = shift;
                my $sock = Lock::Socket->new(
                    port => $port,
                    defined $addr ? ( addr => $addr ) : (),
                );
                $sock->try_lock;
                return $sock if $sock->_is_locked;
                return undef;
              }
        }
        else {
            __PACKAGE__->err( 'Import',
                'not exported by Lock::Socket: ' . $token );
        }
    }
}

### Object Attributes ###

has port => (
    is       => 'ro',
    required => 1,
);

has addr => (
    is      => 'ro',
    default => sub {
        return join( '.', 127, unpack( 'C2', pack( "n", $< ) ), 1 )
          unless $^O =~ m/bsd$/;
        return '127.0.0.1';
    },
);

has _inet_addr => (
    is      => 'ro',
    default => sub {
        my $self = shift;
        return inet_aton( $self->addr );
    },
);

has _fh => (
    is      => 'rw',
    lazy    => 0,
    builder => '_fh_builder',
);

sub _fh_builder {
    my $self = shift;
    socket( my $fh, PF_INET, SOCK_STREAM, getprotobyname('tcp') )
      || $self->err( 'Socket', "socket: $!" );
    return $fh;
}

sub fh {
    $_[0]->_fh;
}

has _is_locked => (
    is      => 'rw',
    lazy    => 0,
    default => sub { 0 },
);

sub is_locked {
    $_[0]->_is_locked;
}

### Object Methods ###

sub err {
    my $self  = shift;
    my $class = 'Lock::Socket::Error::' . $_[0];
    local @CARP_NOT = __PACKAGE__;
    die $class->new( msg => Carp::shortmess( $_[1] ) );
}

sub lock {
    my $self = shift;
    return 1 if $self->_is_locked;

    bind( $self->fh, pack_sockaddr_in( $self->port, $self->_inet_addr ) )
      || $self->err( 'Bind',
        sprintf( 'bind: %s (%s:%d)', $!, $self->addr, $self->port ) );

    $self->_is_locked(1);
}

sub try_lock {
    my $self = shift;
    return eval { $self->lock } || 0;
}

sub unlock {
    my $self = shift;
    return 1 unless $self->_is_locked;

    close( $self->_fh );
    $self->_fh( $self->_fh_builder );
    $self->_is_locked(0);

    return 1;
}

1;

__END__