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