view release on metacpan or  search on metacpan

lib/IPC/Lock/WithTTL.pm  view on Meta::CPAN

    my $now = time();
    my $new_expiration;
    my $acquired = 0;
    if ($pid == 0) {
        # Previous task finished successfully
        if ($now >= $expiration) {
            # expired
            $new_expiration = $self->update_heartbeat;
            $acquired = 1;
        } else {
            # not expired
            $acquired = 0;
        }
    } elsif ($pid != $$) {
        # Other task is in process?
        if ($now >= $expiration) {
            # expired (Last task may have terminated abnormally)
            $new_expiration = $self->update_heartbeat;

            if ($self->kill_old_proc && $pid > 0) {
                kill 'KILL', $pid;
            }
            $acquired = 1;
        } else {
            # not expired (Still running)
            $acquired = 0;
        }
    } else {
        # Previous task done by this process
        if ($now >= $expiration) {
            # expired (Last task may have terminated abnormally)
            $new_expiration = $self->update_heartbeat;
            $acquired = 1;
        } else {
            # not expired (Last task may have terminated abnormally)
            $new_expiration = $self->update_heartbeat;
            $acquired = 1;
        }
    }

    flock $fh, LOCK_UN;
    if ($acquired) {
        return wantarray ? (1, { pid => $$,   expiration => $new_expiration })
                         : 1;
    } else {
        return wantarray ? (0, { pid => $pid, expiration => $expiration })
                         : 0;
    }
}

sub release {
    args(my $self);

    $self->update_heartbeat(pid => 0);
    undef $self->{_fh};

    return 1;
}

sub update_heartbeat {
    args(my $self,
         my $pid => { isa => 'Int', default => $$ },
       );

    my $fh = $self->_fh;

    my $expiration = time() + $self->ttl;

    seek $fh, 0, SEEK_SET;
    truncate $fh, 0;
    print {$fh} join(' ', $pid, $expiration)."\n";

    return $expiration;
}

1;

__END__

=encoding utf-8

=begin html

<a href="https://travis-ci.org/hirose31/IPC-Lock-WithTTL"><img src="https://travis-ci.org/hirose31/IPC-Lock-WithTTL.png?branch=master" alt="Build Status" /></a>
<a href="https://coveralls.io/r/hirose31/IPC-Lock-WithTTL?branch=master"><img src="https://coveralls.io/repos/hirose31/IPC-Lock-WithTTL/badge.png?branch=master" alt="Coverage Status" /></a>

=end html

=head1 NAME

IPC::Lock::WithTTL - run only one process up to given timeout

=head1 SYNOPSIS

    use IPC::Lock::WithTTL;
    
    my $lock = IPC::Lock::WithTTL->new(
        file          => '/tmp/lockme',
        ttl           => 5,
        kill_old_proc => 0,
       );
    
    my($r, $hb) = $lock->acquire;
    
    if ($r) {
        infof("Got lock! yay!!");
    } else {
        critf("Cannot get lock. Try after at %d", $hb->{expiration});
        exit 1;
    }
    
    $lock->release;

=head1 DESCRIPTION

IPC::Lock::WithTTL provides inter process locking feature.
This locking has timeout feature, so we can use following cases:

    * Once send an alert email, don't send same kind of alert email within 10 minutes.
    * We want to prevent the situation that script for failover some system is invoked more than one processes at same time and invoked many times in short time.