UPDATE: I just tried this on another box and it worked fine. The problem is on perl v5.8.9, HP-UX 11iv2, on itanium.

I'm trying to create a simple module for lock files, and I'm experiecing very strange behavior in trying to timeout the blocking flock() calls using $SIG{ALRM} and alarm(). Here is the module:

#!/usr/bin/perl

package FileLock;

use 5.00800;
use strict;
use warnings;
use Fcntl qw(:flock);

our $VERSION = 1.00;
use constant NO_LOCK => 0;
use constant SH_LOCK => 1;
use constant EX_LOCK => 2;
our $lock_stat = NO_LOCK;
our $fh;

sub new {
  # save off the class
  my $class = shift;
  
  # check for and save file
  if(scalar @_ < 1) {
    die("No file argument specified for FileLock->new().\n");
  }
  my $file = shift;
  
  # open the file
  open($fh, '+<', $file) or die("Could not open '$file' in preparation
+ for lock.\n");
  
  # create the object
  my $self = {'fh' => $fh,
    'stat' => NO_LOCK};
  bless($self, $class);
  
  return $self;
}

sub shared_lock {
  my $self = shift;
  
  # return if already an shared lock
  if($self->{'stat'} == SH_LOCK) {
    return 1;
  }
  
  # get the timeout if specified
  my $timeout = 0;
  if(scalar @_ > 0) {
    $timeout = shift;
  }
  
  # release existing lock before trying to take new
  if($self->{'stat'} != NO_LOCK) {
    $self->unlock or die("Could not unlock in preparation for shared l
+ock.\n");
  }
  
  # try and get a lock with the specified timeout
  eval {
    local $SIG{ALRM} = sub {die("timeout\n")};
    alarm($timeout);
    flock(($self->{'fh'}), LOCK_SH) or die("flock failed during shared
+ lock.\n");
    alarm(0);
  };
  if ($@) {
    # if it was not a timeout then propogate it
    unless ($@ eq "timeout\n") {
      die;
    }
    # propogate the timeout
    die("Could not get shared lock within $timeout seconds.\n");
  };
  
  # got the lock, update status and done
  $self->{'stat'} = SH_LOCK;
  return 1;
}

sub exclusive_lock {
  my $self = shift;
  
  # return if already an exclusive lock
  if($self->{'stat'} == EX_LOCK) {
    return 1;
  }
  
  # get the timeout if specified
  my $timeout = 0;
  if(scalar @_ > 0) {
    $timeout = shift;
  }
  
  # release existing lock before trying to take new
  if($self->{'stat'} != NO_LOCK) {
    $self->unlock or die("Could not unlock in preparation for shared l
+ock.\n");
  }
  
  # try and get a lock with the specified timeout
  eval {
    local $SIG{ALRM} = sub {die("timeout\n")};
    alarm($timeout);
    print "  Doing flock\n";
    flock(($self->{'fh'}), LOCK_EX) or die("flock failed during exclus
+ive lock.\n");
    print "  Reset timeout\n";
    alarm (0);
  };
  if ($@) {
    # if it was not a timeout then propogate it
    unless ($@ eq "timeout\n") {
      die($@);
    }
    
    # propogate the timeout
    die("Could not get exclusive lock within $timeout seconds.\n");
  };
  
  # got the lock, update status and done
  $self->{'stat'} = EX_LOCK;
  return 1;
}

sub unlock {
  my $self = shift;
  
  # return if already unlocked
  if($self->{'stat'} == NO_LOCK) {
    return 1;
  }
  
  # try the unlock
  flock(($self->{'fh'}), LOCK_UN) or die("Could not release lock.");
  
  return 1;
}

1;
__END__

[download]

Here is test 1:

#!/usr/bin/perl -w

# setup path to local modules
BEGIN
{
    use File::Basename;
    use Cwd;
    File::Basename::fileparse_set_fstype($^O);
    my $include = (File::Basename::fileparse($0))[1];
    $include = $include eq '' ? '.' : $include;
    $include = Cwd::abs_path($include);
    unshift @INC, $include;
}

use strict;
use FileLock;

my $file = "filelock.sem";
my $lock = FileLock->new($file);
print "Created FileLock obj for '$file'.\n";

# try a shared lock
$lock->shared_lock(10);
print "Got shared lock on '$file'.\n";

# try exclusive lock
$lock->exclusive_lock(10);
print "Got exclusive lock on '$file'.\n";

# try unlock
$lock->unlock();
print "Unlocked '$file'.\n";

[download]

And test 2:

#!/usr/bin/perl -w


# setup path to local modules
BEGIN
{
    use File::Basename;
    use Cwd;
    File::Basename::fileparse_set_fstype($^O);
    my $include = (File::Basename::fileparse($0))[1];
    $include = $include eq '' ? '.' : $include;
    $include = Cwd::abs_path($include);
    unshift @INC, $include;
}

use strict;
use FileLock;

my $file = "filelock.sem";
my $lock = FileLock->new($file);
print "Created FileLock obj for '$file'.\n";

# try a shared lock
$lock->shared_lock(10);
print "Got shared lock on '$file'.\n";

# hold the lock
eval {
  while (1) {
    # do nothing
  }
};

[download]

When I run test file 1, I get what I expect:

Created FileLock obj for 'filelock.sem'.
Got shared lock on 'filelock.sem'.
  Doing flock
  Reset timeout
Got exclusive lock on 'filelock.sem'.
Unlocked 'filelock.sem'.

[download]

However, when I run test 2 in another shell and then run testfile 1 things stall. Test 2 works as anticipated and get a shared lock, and test 1 gets a shared lock, but then pauses indefinitely on the flock(). The alarm signal seems to be delayed or blocked by the flock. If I kill test 2 before 10 seconds then test 1 gets the exclusive lock and completes as expected. If I kill test 2 after ten seconds then test 1 completes with the timeout message. It seems that the alarm signal is being blocked/delayed by flock(), any ideas why and how to fix it? I've listed examples of killing test 2 before and after 10 seconds of test 1 starting below:

Before 10 seconds:
Created FileLock obj for 'filelock.sem'.
Got shared lock on 'filelock.sem'.
  Doing flock
  Reset timeout
Got exclusive lock on 'filelock.sem'.
Unlocked 'filelock.sem'.

After ten seconds:
Created FileLock obj for 'filelock.sem'.
Got shared lock on 'filelock.sem'.
  Doing flock
Could not get exclusive lock within 10 seconds.

[download]

In reply to strange flock and alarm behavior by blipinsk

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.