view release on metacpan or  search on metacpan

lib/IPC/ConcurrencyLimit/Lock/Redis.pm  view on Meta::CPAN

sub _release_lock {
  my $self = shift;
  my $id = $self->id;
  return if not $id;

  $self->script_cache->run_script(
    'release_lock', [1, $self->key_name, $id]
  );

  $self->{id} = undef;
}

sub _updated_uuid {
  my ($self) = @_;
  my $old_uuid = $self->uuid;
  my $new_uuid = $UUIDGenerator->create;
  substr($new_uuid, 8, 8) = substr($old_uuid, 8, 8);
  vec($new_uuid, 15, 4) = vec($old_uuid, 15, 4);
  return $new_uuid;
}

sub heartbeat {
  my $self = shift;
  my $conn = $self->redis_conn;
  return() if not $conn;

  my $proc_info = $self->proc_info;
  my $new_uuid = $self->_updated_uuid;
  my $olddata = $self->uuid . "-" . $proc_info;
  my $newdata = $new_uuid . "-" . $proc_info;

  my $ok;
  eval {
    $ok = $self->script_cache->run_script(
      'update_uuid',
      [ 1, $self->key_name, $self->id, $olddata, $newdata ]
    );
    1
  } or return(); # server gone away?

  if (not $ok) {
    return(); # lock was acquired by somebody else?
  }

  $self->{uuid} = $new_uuid;
  return 1; # probably all fine
}

sub DESTROY {
  local $@;
  my $self = shift;
  $self->_release_lock();
}


# This is so ugly because we compile slightly different code depending on whether
# we're running on a perl that can do big-endian-forced-quads or not.
# FIXME Will work on 64bit perls only. Implementation for 32bit integers welcome.
# FIXME is this worth it or should it just do a run-time perl version check like heartbeat()?
eval(<<'PRE' . ($] ge '5.010' ? <<'NEW_PERL' : <<'OLD_PERL') . <<'POST')
sub clear_old_locks {
  my ($class, $redis_conn, $key_name, $cutoff) = @_;

  my %hash = $redis_conn->hgetall($key_name);
  return if not keys(%hash);
  my $ncleared = 0;
  foreach my $lockid (keys %hash) {
PRE
    my ($quad) = unpack("Q>", $hash{$lockid});
    $quad -= $quad % 16; # 60 bit only
NEW_PERL
    my ($x, $y) = unpack("N2", $hash{$lockid});
    $y -= $y % 16; # 60 bit only
    my $quad = $x*2**32 + $y;
OLD_PERL
    if ($quad/1e7 < $cutoff) {
      $ncleared += $redis_conn->eval($LuaScript_ClearOldLock, 1, $key_name, $lockid, $hash{$lockid});
    }
  }
  return $ncleared;
}
1
POST
or do {
  my $err = $@ || 'Zombie error';
  die "Failed to compile clear_old_locks code: $err";
};

1;

__END__


=head1 NAME

IPC::ConcurrencyLimit::Lock::Redis - Locking via Redis

=head1 SYNOPSIS

  # see also: IPC::ConcurrencyLimit::Lock
  
  use IPC::ConcurrencyLimit;
  use Redis;
  
  my $redis = Redis->new(server => ...);
  my $limit = IPC::ConcurrencyLimit->new(
    type       => 'Redis',
    max_procs  => 1, # defaults to 1
    redis_conn => $redis,
    key_name   => "mylock",
    # optional value to store. Will be prefixed with UUID (see below)
    # proc_info  => "...",
  );
  
  my $id = $limit->get_lock;
  if (not $id) {
    warn "Couldn't get lock";
    exit();
  }