DBIx-Locker
view release on metacpan or search on metacpan
0.100117 2014-05-19 17:38:21-04:00 America/New_York
- Fix tests on DBD::SQLite 1.42 (frew)
0.100116 2013-12-17 13:08:36-0500 America/New_York
- tweak test expectations to allow for multiline unique key error
(seems to be found in older SQLite?)
0.100115 2013-11-27 22:40:10 America/New_York
Add lockstring method to ::Lock (frew)
Add is_locked flag to ::Lock to make unlock idempotent (frew)
0.100114 2013-07-30 18:03:23 America/New_York
Include errstr from underlying db (frew)
update bugtracker
0.100113 2013-07-05 21:13:26 America/New_York
fix typo, update bugtracker
0.100112 2012-11-06 12:01:01 America/New_York
lib/DBIx/Locker.pm view on Meta::CPAN
#pod ...and a B<warning>.
#pod
#pod DBIx::Locker was written to replace some lousy database resource locking code.
#pod The code would establish a MySQL lock with C<GET_LOCK> to lock arbitrary
#pod resources. Unfortunately, the code would also silently reconnect in case of
#pod database connection failure, silently losing the connection-based lock.
#pod DBIx::Locker locks by creating a persistent row in a "locks" table.
#pod
#pod Because DBIx::Locker locks are stored in a table, they won't go away. They
#pod have to be purged regularly. (A program for doing this, F<dbix_locker_purge>,
#pod is included.) The locked resource is just a string. All records in the lock
#pod (or semaphore) table are unique on the lock string.
#pod
#pod This is the I<entire> mechanism. This is quick and dirty and quite effective,
#pod but it's not highly efficient. If you need high speed locks with multiple
#pod levels of resolution, or anything other than a quick and brutal solution,
#pod I<keep looking>.
#pod
#pod =head1 STORAGE
#pod
#pod To use this module you'll need to create the lock table, which should have five
lib/DBIx/Locker.pm view on Meta::CPAN
#pod =over
#pod
#pod =item * C<id> Autoincrementing ID is recommended
#pod
#pod =item * C<lockstring> varchar(128) with a unique constraint
#pod
#pod =item * C<created> datetime
#pod
#pod =item * C<expires> datetime
#pod
#pod =item * C<locked_by> text
#pod
#pod =back
#pod
#pod See the C<sql> directory included in this dist for DDL for your database.
#pod
#pod =method new
#pod
#pod my $locker = DBIx::Locker->new(\%arg);
#pod
#pod This returns a new locker.
lib/DBIx/Locker.pm view on Meta::CPAN
Carp::confess("no lockstring provided")
unless defined $lockstring and length $lockstring;
my $expires = $arg->{expires} ||= 3600;
Carp::confess("expires must be a positive integer")
unless $expires > 0 and $expires == int $expires;
$expires = time + $expires;
my $locked_by = {
host => Sys::Hostname::hostname(),
guid => Data::GUID->new->as_string,
pid => $$,
};
my $table = $self->table;
my $dbh = $self->dbh;
local $dbh->{RaiseError} = 0;
local $dbh->{PrintError} = 0;
my $rows = $dbh->do(
"INSERT INTO $table (lockstring, created, expires, locked_by)
VALUES (?, ?, ?, ?)",
undef,
$lockstring,
$self->_time_to_string,
$self->_time_to_string([ localtime($expires) ]),
$JSON->encode($locked_by),
);
die(
"could not lock resource <$lockstring>" . (
$dbh->err && $dbh->errstr
? (': ' . $dbh->errstr)
: ''
)
) unless $rows and $rows == 1;
my $lock = DBIx::Locker::Lock->new({
locker => $self,
lock_id => $self->last_insert_id,
expires => $expires,
locked_by => $locked_by,
lockstring => $lockstring,
});
return $lock;
}
sub _time_to_string {
my ($self, $time) = @_;
$time = [ localtime ] unless $time;
lib/DBIx/Locker.pm view on Meta::CPAN
...and a B<warning>.
DBIx::Locker was written to replace some lousy database resource locking code.
The code would establish a MySQL lock with C<GET_LOCK> to lock arbitrary
resources. Unfortunately, the code would also silently reconnect in case of
database connection failure, silently losing the connection-based lock.
DBIx::Locker locks by creating a persistent row in a "locks" table.
Because DBIx::Locker locks are stored in a table, they won't go away. They
have to be purged regularly. (A program for doing this, F<dbix_locker_purge>,
is included.) The locked resource is just a string. All records in the lock
(or semaphore) table are unique on the lock string.
This is the I<entire> mechanism. This is quick and dirty and quite effective,
but it's not highly efficient. If you need high speed locks with multiple
levels of resolution, or anything other than a quick and brutal solution,
I<keep looking>.
=head1 PERL VERSION
This library should run on perls released even a long time ago. It should work
lib/DBIx/Locker.pm view on Meta::CPAN
=over
=item * C<id> Autoincrementing ID is recommended
=item * C<lockstring> varchar(128) with a unique constraint
=item * C<created> datetime
=item * C<expires> datetime
=item * C<locked_by> text
=back
See the C<sql> directory included in this dist for DDL for your database.
=head1 AUTHOR
Ricardo SIGNES <cpan@semiotic.systems>
=head1 CONTRIBUTORS
lib/DBIx/Locker/Lock.pm view on Meta::CPAN
#pod L<DBIx::Locker> to create locks. Since you are not a locker, you should not
#pod call this method. Seriously.
#pod
#pod my $locker = DBIx::Locker::Lock->new(\%arg);
#pod
#pod This returns a new lock.
#pod
#pod locker - the locker creating the lock
#pod lock_id - the id of the lock in the lock table
#pod expires - the time (in epoch seconds) at which the lock will expire
#pod locked_by - a hashref of identifying information
#pod lockstring - the string that was locked
#pod
#pod =cut
sub new {
my ($class, $arg) = @_;
my $guts = {
is_locked => 1,
locker => $arg->{locker},
lock_id => $arg->{lock_id},
expires => $arg->{expires},
locked_by => $arg->{locked_by},
lockstring => $arg->{lockstring},
};
return bless $guts => $class;
}
#pod =method locker
#pod
#pod =method lock_id
#pod
#pod =method locked_by
#pod
#pod =method lockstring
#pod
#pod These are accessors for data supplied to L</new>.
#pod
#pod =cut
BEGIN {
for my $attr (qw(locker lock_id locked_by lockstring)) {
Sub::Install::install_sub({
code => sub {
Carp::confess("$attr is read-only") if @_ > 1;
$_[0]->{$attr}
},
as => $attr,
});
}
}
lib/DBIx/Locker/Lock.pm view on Meta::CPAN
return $new_expiry;
}
#pod =method guid
#pod
#pod This method returns the lock's globally unique id.
#pod
#pod =cut
sub guid { $_[0]->locked_by->{guid} }
#pod =method is_locked
#pod
#pod Method to see if the lock is active or not
#pod
#pod =cut
sub is_locked {
$_[0]->{is_locked} = $_[1] if exists $_[1];
$_[0]->{is_locked}
}
#pod =method unlock
#pod
#pod This method unlocks the lock, deleting the semaphor record. This method is
#pod automatically called when locks are garbage collected.
#pod
#pod =cut
sub unlock {
my ($self) = @_;
return unless $self->is_locked;
my $dbh = $self->locker->dbh;
my $table = $self->locker->table;
my $rows = $dbh->do("DELETE FROM $table WHERE id=?", undef, $self->lock_id);
Carp::confess('error releasing lock') unless $rows == 1;
$self->is_locked(0);
}
sub DESTROY {
my ($self) = @_;
local $@;
return unless $self->locked_by->{pid} == $$;
$self->unlock;
}
1;
__END__
=pod
=encoding UTF-8
lib/DBIx/Locker/Lock.pm view on Meta::CPAN
L<DBIx::Locker> to create locks. Since you are not a locker, you should not
call this method. Seriously.
my $locker = DBIx::Locker::Lock->new(\%arg);
This returns a new lock.
locker - the locker creating the lock
lock_id - the id of the lock in the lock table
expires - the time (in epoch seconds) at which the lock will expire
locked_by - a hashref of identifying information
lockstring - the string that was locked
=head2 locker
=head2 lock_id
=head2 locked_by
=head2 lockstring
These are accessors for data supplied to L</new>.
=head2 expires
This method returns the expiration time (as a unix timestamp) as provided to
L</new> -- unless expiration has been changed. Expiration can be changed by
using this method as a mutator:
lib/DBIx/Locker/Lock.pm view on Meta::CPAN
# expire one hour from now, no matter what initial expiration was
$lock->expires(time + 3600);
When updating the expiration time, if the given expiration time is not a valid
unix time, or if the expiration cannot be updated, an exception will be raised.
=head2 guid
This method returns the lock's globally unique id.
=head2 is_locked
Method to see if the lock is active or not
=head2 unlock
This method unlocks the lock, deleting the semaphor record. This method is
automatically called when locks are garbage collected.
=head1 AUTHOR
sql/mssql.sql view on Meta::CPAN
CREATE TABLE [locks] (
[id] bigint NOT NULL IDENTITY (1, 1),
[lockstring] varchar(128) NOT NULL,
[created] datetime NOT NULL,
[expires] datetime NOT NULL,
[locked_by] text NOT NULL,
CONSTRAINT [PK_locks] PRIMARY KEY CLUSTERED ([id]),
CONSTRAINT [UC_locks] UNIQUE ([lockstring])
);
sql/mysql.sql view on Meta::CPAN
CREATE TABLE semaphores (
id bigint unsigned NOT NULL PRIMARY KEY AUTO_INCREMENT,
lockstring varchar(128) UNIQUE,
created datetime NOT NULL,
expires datetime NOT NULL,
locked_by text NOT NULL
);
sql/sqlite.sql view on Meta::CPAN
CREATE TABLE locks (
id INTEGER PRIMARY KEY,
lockstring varchar(128) UNIQUE,
created varchar(14) NOT NULL,
expires varchar(14) NOT NULL,
locked_by varchar(1024)
);
my @conn = ('dbi:SQLite:dbname=test.db', undef, undef, {});
{
my $dbh = DBI->connect(@conn);
$dbh->do('CREATE TABLE locks (
id INTEGER PRIMARY KEY,
lockstring varchar(128) UNIQUE,
created varchar(14) NOT NULL,
expires varchar(14) NOT NULL,
locked_by varchar(1024)
)');
}
my $locker = DBIx::Locker->new({
dbi_args => \@conn,
table => 'locks',
});
isa_ok($locker, 'DBIx::Locker');
my $expiry = $lock->expires;
like($expiry, qr/\A\d+\z/, "expiry is an integer");
cmp_ok($expiry, '>', time, "expiry is in the future");
$guid = $lock->guid;
eval { $locker->lock('Zombie Soup'); };
ok(
$@,
# (used to be isa_ok) 'X::Unavailable',
"can't lock already-locked resources"
);
ok($lock->is_locked, 'lock is active');
$lock->unlock;
ok(!$lock->is_locked, 'lock is not active');
ok(eval { $lock->unlock; 1}, 'unlock twice works');
}
{
my $lock = $locker->lock('Zombie Soup');
isa_ok($lock, 'DBIx::Locker::Lock', 'newly obtained lock');
isnt($lock->guid, $guid, "new lock guid is not the old lock guid");
my $lock_2 = $locker->lock('Zombie Cola');
( run in 0.685 second using v1.01-cache-2.11-cpan-49f99fa48dc )