view release on metacpan or  search on metacpan

lib/Dev/Util/Sem.pm  view on Meta::CPAN

package Dev::Util::Sem;

use Dev::Util::Syntax;
use Dev::Util::File qw(mk_temp_dir dir_writable dir_suffix_slash);
use Exporter        qw(import);

use FileHandle;
use Carp();
use Fcntl 'LOCK_EX';

our $VERSION = version->declare("v2.19.42");

our @EXPORT_OK = qw(
    new
    unlock
);

our %EXPORT_TAGS = ( all => \@EXPORT_OK );

########################################
#            Methods                   #
########################################

sub new {
    my $class    = shift(@_);
    my $filespec = shift(@_) || Carp::croak("What filespec?");
    my $timeout  = shift     || 60;

    my $lock_dir_parent = _get_locks_dir($filespec);

    local $SIG{ ALRM } = sub { die "Timeout aquiring the lock on $filespec\n" };
    alarm $timeout if ( $timeout > 0 );

    $filespec =~ s{^.*/}{};
    $filespec = $lock_dir_parent . $filespec;

    my $fh = FileHandle->new;
    $fh->open( '>' . $filespec )
        or Carp::croak("Can't open semaphore file $filespec: $!\n");
    chmod 0666, $filespec;    # assuming you want it a+rw

    flock $fh, LOCK_EX;

    alarm 0;
    return bless { file => $filespec, 'fh' => $fh }, ref($class) || $class;
}

sub unlock {
    close( delete $_[0]{ 'fh' } or return 0 );
    unlink( $_[0]{ file } );
    return 1;
}

sub _get_locks_dir {
    my $spec       = shift || undef;
    my @locks_dirs = qw(/var/lock /var/locks /run/lock /tmp);

    my $dirfile_re = qr<^ ( (?: .* / (?: \.\.?\z )? )? ) ([^/]*) >xs;
    my ( $spec_dir, $spec_file );

    # add spec's dir to list of possible lock dirs
    if ( defined $spec && $spec =~ m{/} ) {
        ( $spec_dir, $spec_file ) = ( $spec =~ $dirfile_re );
        unshift @locks_dirs, $spec_dir;
    }

    # find first writable lock dir
    foreach my $locks_dir (@locks_dirs) {
        if ( dir_writable($locks_dir) ) {
            return dir_suffix_slash($locks_dir);
        }
    }
    Carp::croak("Could not find a writable dir to make lock.$!\n");
}

1;

=pod

=encoding utf-8

=head1 NAME

Dev::Util::Sem -  Module to do Semaphore locking

=head1 VERSION

Version v2.19.42

=head1 SYNOPSIS

To ensure that only one instance of a program runs at a time, 
create a semaphore lock file. A second instance will wait until
the first lock is unlocked before it can proceed or it times out.

    use Dev::Util::Sem;

    my $sem = Sem->new('mylock.sem');
    ...
    $sem->unlock;