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); 6use IPC::Semaphore; 7use strict; 8use warnings; 9use constant INTERNAL_DEBUG => 0; 10 11########################################### 12sub new { 13########################################### 14 my($class, %options) = @_; 15 16 my $self = { 17 key => undef, 18 mode => undef, 19 uid => undef, 20 gid => undef, 21 destroy => undef, 22 semop_wait => .1, 23 semop_retries => 1, 24 %options, 25 }; 26 27 $self->{ikey} = unpack("i", pack("A4", $self->{key})); 28 29 # Accept usernames in the uid field as well 30 if(defined $self->{uid} and 31 $self->{uid} =~ /\D/) { 32 $self->{uid} = (getpwnam $self->{uid})[2]; 33 } 34 35 bless $self, $class; 36 $self->init(); 37 38 my @values = (); 39 for my $param (qw(mode uid gid)) { 40 push @values, $param, $self->{$param} if defined $self->{$param}; 41 } 42 $self->semset(@values) if @values; 43 44 return $self; 45} 46 47########################################### 48sub init { 49########################################### 50 my($self) = @_; 51 52 print "Semaphore init '$self->{key}'/'$self->{ikey}'\n" if INTERNAL_DEBUG; 53 54 $self->{id} = semget( $self->{ikey}, 55 1, 56 &IPC_EXCL|&IPC_CREAT|($self->{mode}||0777), 57 ); 58 59 if(! defined $self->{id} and 60 $! =~ /exists/) { 61 print "Semaphore '$self->{key}' already exists\n" if INTERNAL_DEBUG; 62 $self->{id} = semget( $self->{ikey}, 1, 0 ) 63 or die "semget($self->{ikey}) failed: $!"; 64 } elsif($!) { 65 die "Cannot create semaphore $self->{key}/$self->{ikey} ($!)"; 66 } 67} 68 69########################################### 70sub status_as_string { 71########################################### 72 my($self, @values) = @_; 73 74 my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); 75 76 my $values = join('/', $sem->getall()); 77 my $ncnt = $sem->getncnt(0); 78 my $pidlast = $sem->getpid(0); 79 my $zcnt = $sem->getzcnt(0); 80 my $id = $sem->id(); 81 82 return <<EOT; 83Semaphore Status 84Key ...................................... $self->{key} 85iKey ..................................... $self->{ikey} 86Id ....................................... $id 87Values ................................... $values 88Processes waiting for counter increase ... $ncnt 89Processes waiting for counter to hit 0 ... $zcnt 90Last process to perform an operation ..... $pidlast 91EOT 92} 93 94########################################### 95sub semsetval { 96########################################### 97 my($self, %keyvalues) = @_; 98 99 my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); 100 $sem->setval(%keyvalues); 101} 102 103########################################### 104sub semset { 105########################################### 106 my($self, @values) = @_; 107 108 print "Setting values for semaphore $self->{key}/$self->{ikey}\n" if 109 INTERNAL_DEBUG; 110 111 my $sem = IPC::Semaphore->new($self->{ikey}, 1, 0); 112 $sem->set(@values); 113} 114 115########################################### 116sub semlock { 117########################################### 118 my($self) = @_; 119 120 my $operation = pack("s!*", 121 # wait until it's 0 122 0, 0, 0, 123 # increment by 1 124 0, 1, SEM_UNDO 125 ); 126 127 print "Locking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; 128 $self->semop($self->{id}, $operation); 129} 130 131########################################### 132sub semunlock { 133########################################### 134 my($self) = @_; 135 136 my $operation = pack("s!*", 137 # decrement by 1 138 0, -1, (IPC_NOWAIT) 139 ); 140 141 print "Unlocking semaphore '$self->{key}'\n" if INTERNAL_DEBUG; 142 143 # ignore errors, as they might result from trying to unlock an 144 # already unlocked semaphor. 145 semop($self->{id}, $operation); 146} 147 148########################################### 149sub remove { 150########################################### 151 my($self) = @_; 152 153 print "Removing semaphore '$self->{key}'\n" if INTERNAL_DEBUG; 154 155 semctl ($self->{id}, 0, &IPC_RMID, 0) or 156 die "Removing semaphore $self->{key} failed: $!"; 157} 158 159########################################### 160sub DESTROY { 161########################################### 162 my($self) = @_; 163 164 if($self->{destroy}) { 165 $self->remove(); 166 } 167} 168 169########################################### 170sub semop { 171########################################### 172 my($self, @args) = @_; 173 174 my $retries = $self->{semop_retries}; 175 176 my $rc; 177 178 { 179 $rc = semop($args[0], $args[1]); 180 181 if(!$rc and 182 $! =~ /temporarily unavailable/ and 183 $retries-- > 0) { 184 $rc = 'undef' unless defined $rc; 185 print "semop failed (rc=$rc), retrying\n", 186 $self->status_as_string if INTERNAL_DEBUG; 187 select undef, undef, undef, $self->{semop_wait}; 188 redo; 189 } 190 } 191 192 $rc or die "semop(@args) failed: $! "; 193 $rc; 194} 195 1961; 197 198__END__ 199 200=head1 NAME 201 202Log::Log4perl::Util::Semaphore - Easy to use semaphores 203 204=head1 SYNOPSIS 205 206 use Log::Log4perl::Util::Semaphore; 207 my $sem = Log::Log4perl::Util::Semaphore->new( key => "abc" ); 208 209 $sem->semlock(); 210 # ... critical section 211 $sem->semunlock(); 212 213 $sem->semset( uid => (getpwnam("hugo"))[2], 214 gid => 102, 215 mode => 0644 216 ); 217 218=head1 DESCRIPTION 219 220Log::Log4perl::Util::Semaphore provides the synchronisation mechanism 221for the Synchronized.pm appender in Log4perl, but can be used independently 222of Log4perl. 223 224As a convenience, the C<uid> field accepts user names as well, which it 225translates into the corresponding uid by running C<getpwnam>. 226 227=head1 LEGALESE 228 229Copyright 2007 by Mike Schilli, all rights reserved. 230This program is free software, you can redistribute it and/or 231modify it under the same terms as Perl itself. 232 233=head1 AUTHOR 234 2352007, Mike Schilli <cpan@perlmeister.com> 236