1#////////////////////////////////////////// 2package Log::Log4perl::Util::Semaphore; 3#////////////////////////////////////////// 4use IPC::SysV qw(IPC_RMID IPC_CREAT IPC_EXCL SEM_UNDO IPC_NOWAIT 5 IPC_SET IPC_STAT SETVAL); 6use IPC::Semaphore; 7use POSIX qw(EEXIST); 8use strict; 9use warnings; 10use constant INTERNAL_DEBUG => 0; 11 12########################################### 13sub new { 14########################################### 15 my($class, %options) = @_; 16 17 my $self = { 18 key => undef, 19 mode => undef, 20 uid => undef, 21 gid => undef, 22 destroy => undef, 23 semop_wait => .1, 24 semop_retries => 1, 25 creator => $$, 26 %options, 27 }; 28 29 $self->{ikey} = unpack("i", pack("A4", $self->{key})); 30 31 # Accept usernames in the uid field as well 32 if(defined $self->{uid} and 33 $self->{uid} =~ /\D/) { 34 $self->{uid} = (getpwnam $self->{uid})[2]; 35 } 36 37 bless $self, $class; 38 $self->init(); 39 40 my @values = (); 41 for my $param (qw(mode uid gid)) { 42 push @values, $param, $self->{$param} if defined $self->{$param}; 43 } 44 $self->semset(@values) if @values; 45 46 return $self; 47} 48 49########################################### 50sub init { 51########################################### 52 my($self) = @_; 53 54 print "Semaphore init '$self->{key}'/'$self->{ikey}'\n" if INTERNAL_DEBUG; 55 56 $self->{id} = semget( $self->{ikey}, 57 1, 58 &IPC_EXCL|&IPC_CREAT|($self->{mode}||0777), 59 ); 60 61 if(! defined $self->{id} and 62 $! == EEXIST) { 63 print "Semaphore '$self->{key}' already exists\n" if INTERNAL_DEBUG; 64 $self->{id} = semget( $self->{ikey}, 1, 0 ) 65 or die "semget($self->{ikey}) failed: $!"; 66 } elsif($!) { 67 die "Cannot create semaphore $self->{key}/$self->{ikey} ($!)"; 68 } 69} 70 71########################################### 72sub status_as_string { 73########################################### 74 my($self, @values) = @_; 75 76 my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); 77 78 my $values = join('/', $sem->getall()); 79 my $ncnt = $sem->getncnt(0); 80 my $pidlast = $sem->getpid(0); 81 my $zcnt = $sem->getzcnt(0); 82 my $id = $sem->id(); 83 84 return <<EOT; 85Semaphore Status 86Key ...................................... $self->{key} 87iKey ..................................... $self->{ikey} 88Id ....................................... $id 89Values ................................... $values 90Processes waiting for counter increase ... $ncnt 91Processes waiting for counter to hit 0 ... $zcnt 92Last process to perform an operation ..... $pidlast 93EOT 94} 95 96########################################### 97sub semsetval { 98########################################### 99 my($self, %keyvalues) = @_; 100 101 my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); 102 $sem->setval(%keyvalues); 103} 104 105########################################### 106sub semset { 107########################################### 108 my($self, @values) = @_; 109 110 print "Setting values for semaphore $self->{key}/$self->{ikey}\n" if 111 INTERNAL_DEBUG; 112 113 my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); 114 $sem->set(@values); 115} 116 117########################################### 118sub semlock { 119########################################### 120 my($self) = @_; 121 122 my $operation = pack("s!*", 123 # wait until it's 0 124 0, 0, 0, 125 # increment by 1 126 0, 1, SEM_UNDO 127 ); 128 129 print "Locking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; 130 $self->semop($self->{id}, $operation); 131} 132 133########################################### 134sub semunlock { 135########################################### 136 my($self) = @_; 137 138# my $operation = pack("s!*", 139# # decrement by 1 140# 0, -1, SEM_UNDO 141# ); 142# 143 print "Unlocking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; 144 145# # ignore errors, as they might result from trying to unlock an 146# # already unlocked semaphor. 147# semop($self->{id}, $operation); 148 149 semctl $self->{id}, 0, SETVAL, 0; 150} 151 152########################################### 153sub remove { 154########################################### 155 my($self) = @_; 156 157 print "Removing semaphore '$self->{key}'\n" if INTERNAL_DEBUG; 158 159 semctl ($self->{id}, 0, &IPC_RMID, 0) or 160 die "Removing semaphore $self->{key} failed: $!"; 161} 162 163########################################### 164sub DESTROY { 165########################################### 166 my($self) = @_; 167 168 if($self->{destroy} && $$==$self->{creator}) { 169 $self->remove(); 170 } 171} 172 173########################################### 174sub semop { 175########################################### 176 my($self, @args) = @_; 177 178 my $retries = $self->{semop_retries}; 179 180 my $rc; 181 182 { 183 $rc = semop($args[0], $args[1]); 184 185 if(!$rc and 186 $! =~ /temporarily unavailable/ and 187 $retries-- > 0) { 188 $rc = 'undef' unless defined $rc; 189 print "semop failed (rc=$rc), retrying\n", 190 $self->status_as_string if INTERNAL_DEBUG; 191 select undef, undef, undef, $self->{semop_wait}; 192 redo; 193 } 194 } 195 196 $rc or die "semop(@args) failed: $! "; 197 $rc; 198} 199 2001; 201 202__END__ 203 204=head1 NAME 205 206Log::Log4perl::Util::Semaphore - Easy to use semaphores 207 208=head1 SYNOPSIS 209 210 use Log::Log4perl::Util::Semaphore; 211 my $sem = Log::Log4perl::Util::Semaphore->new( key => "abc" ); 212 213 $sem->semlock(); 214 # ... critical section 215 $sem->semunlock(); 216 217 $sem->semset( uid => (getpwnam("hugo"))[2], 218 gid => 102, 219 mode => 0644 220 ); 221 222=head1 DESCRIPTION 223 224Log::Log4perl::Util::Semaphore provides the synchronisation mechanism 225for the Synchronized.pm appender in Log4perl, but can be used independently 226of Log4perl. 227 228As a convenience, the C<uid> field accepts user names as well, which it 229translates into the corresponding uid by running C<getpwnam>. 230 231=head1 LICENSE 232 233Copyright 2002-2012 by Mike Schilli E<lt>m@perlmeister.comE<gt> 234and Kevin Goess E<lt>cpan@goess.orgE<gt>. 235 236This library is free software; you can redistribute it and/or modify 237it under the same terms as Perl itself. 238 239=head1 AUTHOR 240 241Please contribute patches to the project on Github: 242 243 http://github.com/mschilli/log4perl 244 245Send bug reports or requests for enhancements to the authors via our 246 247MAILING LIST (questions, bug reports, suggestions/patches): 248log4perl-devel@lists.sourceforge.net 249 250Authors (please contact them via the list above, not directly): 251Mike Schilli <m@perlmeister.com>, 252Kevin Goess <cpan@goess.org> 253 254Contributors (in alphabetical order): 255Ateeq Altaf, Cory Bennett, Jens Berthold, Jeremy Bopp, Hutton 256Davidson, Chris R. Donnelly, Matisse Enzer, Hugh Esco, Anthony 257Foiani, James FitzGibbon, Carl Franks, Dennis Gregorovic, Andy 258Grundman, Paul Harrington, David Hull, Robert Jacobson, Jason Kohles, 259Jeff Macdonald, Markus Peter, Brett Rann, Peter Rabbitson, Erik 260Selberg, Aaron Straup Cope, Lars Thegler, David Viner, Mac Yang. 261 262