1 package IPC
::Semaphore
::Concurrency
;
8 use POSIX
qw(O_WRONLY O_CREAT O_NONBLOCK O_NOCTTY);
9 use IPC
::SysV
qw(ftok IPC_NOWAIT IPC_CREAT IPC_EXCL S_IRUSR S_IWUSR S_IRGRP S_IWGRP S_IROTH S_IWOTH SEM_UNDO);
13 our @ISA = qw(Exporter);
14 our %EXPORT_TAGS = ( 'all' => [ qw() ] );
15 our @EXPORT_OK = ( @
{ $EXPORT_TAGS{'all'} } );
18 our $VERSION = '0.01';
26 # Only one required argument
27 $args{'pathname'} = shift;
32 if (!exists($args{'pathname'})) {
33 carp
"Must supply a pathname!";
37 $args{'auto_touch'} ||= 1;
38 $args{'proj_id'} ||= 0;
39 $args{'sem_max'} ||= 1;
42 my $self = bless {}, $class;
43 $self->{'_args'} = { %args };
45 $self->_touch() if (!-f
$self->{'_args'}->{'pathname'} || $self->{'_args'}->{'auto_touch'}) or return undef;
46 my $key = $self->_ftok() or return undef;
48 $self->{'semaphore'} = $self->_create($key) or return undef;
56 sysopen(my $fh, $self->{'_args'}->{'pathname'}, O_WRONLY
|O_CREAT
|O_NONBLOCK
|O_NOCTTY
) or carp
"Can't create ".$self->{'_args'}->{'pathname'}.": $!" and return 0;
57 utime(undef, undef, $self->{'_args'}->{'pathname'}) if ($self->{'_args'}->{'auto_touch'});
58 close $fh or carp
"Can't close ".$self->{'_args'}->{'pathname'}.": $!" and return 0;
64 return ftok
($self->{'_args'}->{'pathname'}, $self->{'_args'}->{'proj_id'}) or carp
"Can't create semaphore key: $!" and return undef;
70 # Presubably the semaphore exists already, so try using it right away
71 my $sem = IPC
::Semaphore
->new($key, 0, 0);
73 # Creatie a new semaphore...
74 $sem = IPC
::Semaphore
->new($key, $self->{'_args'}->{'sem_max'}, IPC_CREAT
|IPC_EXCL
|S_IRUSR
|S_IWUSR
|S_IRGRP
|S_IWGRP
|S_IROTH
|S_IWOTH
);
76 # Make sure another process did not create it in our back
77 $sem = IPC
::Semaphore
->new($key, 0, 0) or carp
"Semaphore creation failed!\n";
79 # If we created the semaphore now we assign its initial value
80 for (my $i=0; $i<$self->{'_args'}->{'sem_max'}; $i++) { # TODO: Support array - see above
81 $sem->op($i, $self->{'_args'}->{'slots'}, 0);
85 # Return whatever last semget call got us
93 return $self->{'semaphore'}->getall();
98 my $nsem = shift or 0;
99 return $self->{'semaphore'}->getval($nsem);
104 my $nsem = shift or 0;
105 return $self->{'semaphore'}->getncnt($nsem);
112 if (@_ >= 1 && $_[0] =~ /^\d+$/) {
113 # Positional arguments
114 ($args{'number'}, $args{'wait'}, $args{'maxqueue'}, $args{'undo'}) = @_;
119 $args{'number'} ||= 0;
121 $args{'maxqueue'} ||= 0;
124 my $sem = $self->{'semaphore'};
125 my $flags = IPC_NOWAIT
;
126 $flags |= SEM_UNDO
if ($args{'undo'});
129 if (($ret = $sem->op($args{'number'}, -1, $flags))) {
131 } elsif ($args{'wait'}) {
132 return $ret if ($args{'maxqueue'} && $self->getncnt($args{'number'}) >= $args{'maxqueue'});
133 # Remove NOWAIT and block
134 $flags ^= IPC_NOWAIT
;
135 return $sem->op($args{'number'}, -1, $flags);
142 my $number = shift || 0;
143 return $self->{'semaphore'}->op($number, 1, 0);
148 return $self->{'semaphore'}->remove();
153 # Below is stub documentation for your module. You'd better edit it!
157 IPC::Semaphore::Concurrency - Perl extension for blah blah blah
161 use IPC::Semaphore::Concurrency;
166 Stub documentation for IPC::Semaphore::Concurrency, created by h2xs. It looks like the
167 author of the extension was negligent enough to leave the stub
180 Mention other useful documentation such as the documentation of
181 related modules or operating system documentation (such as man pages
182 in UNIX), or any relevant external documentation such as RFCs or
185 If you have a mailing list set up for your module, mention it here.
187 If you have a web site set up for your module, mention it here.
191 A. U. Thor, E<lt>root@slackware.lanE<gt>
193 =head1 COPYRIGHT AND LICENSE
195 Copyright (C) 2009 by A. U. Thor
197 This library is free software; you can redistribute it and/or modify
198 it under the same terms as Perl itself, either Perl version 5.8.8 or,
199 at your option, any later version of Perl 5 you may have available.