view release on metacpan or  search on metacpan

lib/Sys/RunAlone/User.pm  view on Meta::CPAN

use strict;
use warnings;
package Sys::RunAlone::User;

our $VERSION= '0.01';
#ABSTRACT: make sure only one invocation of a script is active at a time per user

my $silent;
my $retry;
my $pid_file;
my $callback;

1;

sub import {
    shift;
    my($userName) = (getpwuid($>))[0]; 
    my %args= @_;
    $silent   = delete $args{silent};
    $retry    = delete $args{retry};
    $retry    = $ENV{RETRY_SYS_RUNALONE} if exists $ENV{RETRY_SYS_RUNALONE};

    my($dir)  = delete $args{pid_dir};
    my($file) = delete $args{pid_file};
    $callback = delete $args{callback};
    $dir    ||= "/tmp";
    $file   ||= "$userName-$0.lock";

    $pid_file = "$dir/$file";
    
    if ( my @unknown = sort keys %args ) {
        die "Don't know what to do with: @unknown";
    }
    return;
}

sub checkRunning {
    open my($LOCK), "<", $pid_file or return 0;
    chomp(my($pid) = <$LOCK>);
    close($LOCK);
    return kill(0, $pid);
}

INIT {
    no warnings;    
    if ( my $skip= $ENV{SKIP_SYS_RUNALONE_USER} ) {
        print STDERR "Skipping " . __PACKAGE__ . " check for '$0'\n"
          if !$silent and $skip > 1;
    }
    elsif ( checkRunning() ) {
        if ($retry) {
            my ( $times, $sleep )= split ',', $retry;
            $sleep ||= 1;
            while ( $times-- ) {
                sleep $sleep;
                goto ALLOK if !checkRunning();
            }
        }
        if(defined($callback)) {
            $callback->();
        } else {
            print STDERR "A copy of '$0' is already running\n" if !$silent;
        }
        exit 1;
    }

  ALLOK:
       open my($LOCK), ">", $pid_file;
       print $LOCK $$;
       close $LOCK;
}

END {
    open my($LOCK), "<", $pid_file;
    chomp (my($pid) = <$LOCK>);
    close $LOCK;
    unlink $pid_file if ($pid == $$);