package Log::Log4perl::Util::Semaphore;
use IPC::SysV qw(IPC_RMID IPC_CREAT IPC_EXCL SEM_UNDO IPC_NOWAIT
IPC_SET IPC_STAT);
use IPC::Semaphore;
use strict;
use warnings;
use constant INTERNAL_DEBUG => 0;
sub new {
my($class, %options) = @_;
my $self = {
key => undef,
mode => undef,
uid => undef,
gid => undef,
destroy => undef,
semop_wait => .1,
semop_retries => 1,
%options,
};
$self->{ikey} = unpack("i", pack("A4", $self->{key}));
if(defined $self->{uid} and
$self->{uid} =~ /\D/) {
$self->{uid} = (getpwnam $self->{uid})[2];
}
bless $self, $class;
$self->init();
my @values = ();
for my $param (qw(mode uid gid)) {
push @values, $param, $self->{$param} if defined $self->{$param};
}
$self->semset(@values) if @values;
return $self;
}
sub init {
my($self) = @_;
print "Semaphore init '$self->{key}'/'$self->{ikey}'\n" if INTERNAL_DEBUG;
$self->{id} = semget( $self->{ikey},
1,
&IPC_EXCL|&IPC_CREAT|($self->{mode}||0777),
);
if(! defined $self->{id} and
$! =~ /exists/) {
print "Semaphore '$self->{key}' already exists\n" if INTERNAL_DEBUG;
$self->{id} = semget( $self->{ikey}, 1, 0 )
or die "semget($self->{ikey}) failed: $!";
} elsif($!) {
die "Cannot create semaphore $self->{key}/$self->{ikey} ($!)";
}
}
sub status_as_string {
my($self, @values) = @_;
my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0);
my $values = join('/', $sem->getall());
my $ncnt = $sem->getncnt(0);
my $pidlast = $sem->getpid(0);
my $zcnt = $sem->getzcnt(0);
my $id = $sem->id();
return <<EOT;
Semaphore Status
Key ...................................... $self->{key}
iKey ..................................... $self->{ikey}
Id ....................................... $id
Values ................................... $values
Processes waiting for counter increase ... $ncnt
Processes waiting for counter to hit 0 ... $zcnt
Last process to perform an operation ..... $pidlast
EOT
}
sub semsetval {
my($self, %keyvalues) = @_;
my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0);
$sem->setval(%keyvalues);
}
sub semset {
my($self, @values) = @_;
print "Setting values for semaphore $self->{key}/$self->{ikey}\n" if
INTERNAL_DEBUG;
my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0);
$sem->set(@values);
}
sub semlock {
my($self) = @_;
my $operation = pack("s!*",
0, 0, 0,
0, 1, SEM_UNDO
);
print "Locking semaphore '$self->{key}'\n" if INTERNAL_DEBUG;
$self->semop($self->{id}, $operation);
}
sub semunlock {
my($self) = @_;
my $operation = pack("s!*",
0, -1, (IPC_NOWAIT)
);
print "Unlocking semaphore '$self->{key}'\n" if INTERNAL_DEBUG;
semop($self->{id}, $operation);
}
sub remove {
my($self) = @_;
print "Removing semaphore '$self->{key}'\n" if INTERNAL_DEBUG;
semctl ($self->{id}, 0, &IPC_RMID, 0) or
die "Removing semaphore $self->{key} failed: $!";
}
sub DESTROY {
my($self) = @_;
if($self->{destroy}) {
$self->remove();
}
}
sub semop {
my($self, @args) = @_;
my $retries = $self->{semop_retries};
my $rc;
{
$rc = semop($args[0], $args[1]);
if(!$rc and
$! =~ /temporarily unavailable/ and
$retries-- > 0) {
$rc = 'undef' unless defined $rc;
print "semop failed (rc=$rc), retrying\n",
$self->status_as_string if INTERNAL_DEBUG;
select undef, undef, undef, $self->{semop_wait};
redo;
}
}
$rc or die "semop(@args) failed: $! ";
$rc;
}
1;
__END__
=head1 NAME
Log::Log4perl::Util::Semaphore - Easy to use semaphores
=head1 SYNOPSIS
use Log::Log4perl::Util::Semaphore;
my $sem = Log::Log4perl::Util::Semaphore->new( key => "abc" );
$sem->semlock();
# ... critical section
$sem->semunlock();
$sem->semset( uid => (getpwnam("hugo"))[2],
gid => 102,
mode => 0644
);
=head1 DESCRIPTION
Log::Log4perl::Util::Semaphore provides the synchronisation mechanism
for the Synchronized.pm appender in Log4perl, but can be used independently
of Log4perl.
As a convenience, the C<uid> field accepts user names as well, which it
translates into the corresponding uid by running C<getpwnam>.
=head1 LEGALESE
Copyright 2007 by Mike Schilli, all rights reserved.
This program is free software, you can redistribute it and/or
modify it under the same terms as Perl itself.
=head1 AUTHOR
2007, Mike Schilli <cpan@perlmeister.com>