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.3_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__
=head1 NAME

Lock::Socket - application lock/mutex module based on sockets

=head1 VERSION

0.0.3_4 (2014-09-14)

=head1 SYNOPSIS

    ### Function API ###
    use Lock::Socket qw/lock_socket try_lock_socket/;

    # Raises exception if cannot lock
    my $lock = lock_socket(5197);

    # Or just return undef
    my $lock2 = try_lock_socket(5197)
      or die "handle your own error";

    ### Object API ###
    use Lock::Socket;

    # Create a socket
    my $sock = Lock::Socket->new( port => 5197 );

    # Lock or raise an exception
    $sock->lock;

    # Can check its status in case you forgot
    my $status = $sock->is_locked;    # 1 (or 0)
    my $addr   = $sock->addr;         # 127.X.Y.1
    my $port   = $sock->port;         # 5197

    # Re-locking changes nothing
    $sock->lock;

    # New lock on same port fails
    my $sock2 = Lock::Socket->new( port => 5197 );
    eval { $sock2->lock };            # exception

    # But trying to get a lock is ok
    my $status      = $sock2->try_lock;     # 0
    my $same_status = $sock2->is_locked;    # 0

    # If you need the underlying filehandle
    my $fh = $sock->fh;

    # You can manually unlock
    $sock->unlock;

    # ... or unlocking is automatic on scope exit
    undef $sock;

=head1 DESCRIPTION

B<Lock::Socket> provides cooperative inter-process locking for
applications that need to ensure that only one process is running at a
time.  This module works by binding an INET socket to a port on a
loopback address which the operating system conveniently restricts to a
single process.

Note that on most systems the port number needs to be greater than 1024
unless you are running with elevated privileges.

=head2 Function Interface

The C<lock_socket()> and C<try_lock_socket()> functions both take a
mandatory port number and an optional IP address as arguments, and
return a B<Lock::Socket> object on success. C<lock_socket()> will raise
an exception if the lock cannot be taken whereas C<try_lock_socket()>
will return C<undef>.

=head2 Object Interface

Objects are instantiated manually as follows.

    my $sock = Lock::Socket->new(
        port => $PORT, # required
        addr => $ADDR, # defaults to 127.X.Y.1
    );

As soon as the B<Lock::Socket> object goes out of scope the port is
closed and the lock can be obtained by someone else.

=head2 System-wide locks

If you need a single system-wide lock across all users then you should
specify both the port and the adddress explicitly, because
B<Lock::Socket> has a built-in per-user feature as described next.

=head2 Per-user locks

By default the loopback address is calculated as follows:

    Octet   Value
    ------  ------------------------------
    1       127
    2       First byte of user ID
    3       Second byte of user ID
    4       1

This scheme provides something of an automatic per-user lock for a
given port, provided there is no user ID greater than 65536. The
calculated address can be read back via the C<addr()> method.

Unfortunately on BSD systems the loopback interface appears to be
configured with a /32 netmask so there the above calculation is I<not>
performed and the address defaults to 127.0.0.1 resulting in a
system-wide lock.

So in order to be sure you have per-user port uniqueness you can
dynamically calculate the port number based on the user ID:

    my $port = 5197 + $>;

If you do this make sure to pick some random base number instead of
5197, otherwise all applications that use B<Lock::Socket> will be
fighting against each other :-)

=head2 Holding a lock over 'exec'

If you want to keep holding onto a lock socket after a call to C<exec>
(perhaps after forking) you should read about the C<$^F> variable in
L<perlvar>, as you have to set it B<before> creating a lock socket to
ensure the socket will not be closed on exec.

=head2 Example application

See the F<example/solo> file in the distribution for a B<Lock::Socket>
demonstration which provides a command-line lock:

    usage: solo PORT COMMAND...

    # terminal 1
    $ example/solo 1414 sleep 10  # Have lock on 127.3.232.1:1414

    # terminal 2
    $ example/solo 1414 sleep 10  # bind error

=head1 CAVEATS

Most operating systems implement the L<Ephemeral
Port|http://en.wikipedia.org/wiki/Ephemeral_port> concept.  If you
select a port from that range it could be possible that some unrelated
process uses, if temporarily, the port that your application defines
for locking.

Unfortunately the ephemeral port range varies from system to system.
Based on the wikipedia page mentioned above, chances are good that a
port between 5001 and 32767 will work, particularly if your system
loopback device is configured with a /8 netmask (i.e. supports the
127.X.Y.1 scheme). To be sure you should investigate the platorms your
application runs on, and possibly choose an appropriate value at
runtime.

=head1 SEE ALSO

There are many other locking modules available on CPAN, but most of
them use some kind of file or flock-based locking.

=head1 AUTHOR

Mark Lawrence E<lt>nomad@null.netE<gt>. This module was inspired by the
L<solo.pl|https://github.com/andres-erbsen/solo> script by Andres
Erbsen.

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014 Mark Lawrence <nomad@null.net>

This program is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by the
Free Software Foundation; either version 3 of the License, or (at your
option) any later version.

