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