lib/IPC/Semaphore/Concurrency.pm

   1 package IPC::Semaphore::Concurrency;
   2
   3 use 5.008008;
   4 use strict;
   5 use warnings;
   6
   7 use Carp;
   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);
  10 use IPC::Semaphore;
  11
  12 require Exporter;
  13 our @ISA = qw(Exporter);
  14 our %EXPORT_TAGS = ( 'all' => [ qw() ] );
  15 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
  16 our @EXPORT = qw();
  17
  18 our $VERSION = '0.01';
  19
  20 sub new {
  21         my $class = shift;
  22
  23         my %args;
  24         if (@_ == 1) {
  25                 print "foo\n\n\n";
  26                 # Only one required argument
  27                 $args{'pathname'} = shift;
  28         } else {
  29                 %args = @_;
  30         }
  31
  32         if (!exists($args{'pathname'})) {
  33                 carp "Must supply a pathname!";
  34                 return undef;
  35         }
  36         # Set defaults
  37         $args{'auto_touch'} ||= 1;
  38         $args{'proj_id'} ||= 0;
  39         $args{'sem_max'} ||= 1;
  40         $args{'slots'} ||= 1;
  41
  42         my $self = bless {}, $class;
  43         $self->{'_args'} = { %args };
  44
  45         $self->_touch() if (!-f $self->{'_args'}->{'pathname'} || $self->{'_args'}->{'auto_touch'}) or return undef;
  46         my $key = $self->_ftok() or return undef;
  47
  48         $self->{'semaphore'} = $self->_create($key);
  49
  50         return $self;
  51 }
  52
  53 # Internal functions
  54 sub _touch {
  55         my $self = shift;
  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;
  59         return 1;
  60 }
  61
  62 sub _ftok {
  63         my $self = shift;
  64         return ftok($self->{'_args'}->{'pathname'}, $self->{'_args'}->{'proj_id'}) or carp "Can't create semaphore key: $!" and return undef;
  65 }
  66
  67 sub _create {
  68         my $self = shift;
  69         my $key = shift;
  70         # Presubably the semaphore exists already, so try using it right away
  71         my $sem = IPC::Semaphore->new($key, 0, 0);
  72         if (!defined($sem)) {
  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);
  75                 if (!defined($sem)) {
  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";
  78                 } else {
  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);
  82                         }
  83                 }
  84         }
  85         # Return whatever last semget call got us
  86         return $sem;
  87 }
  88
  89 # External API
  90
  91 sub getall {
  92         my $self = shift;
  93         return $self->{'semaphore'}->getall();
  94 }
  95
  96 sub getval {
  97         my $self = shift;
  98         my $nsem = shift or 0;
  99         return $self->{'semaphore'}->getval($nsem);
 100 }
 101
 102 sub getncnt {
 103         my $self = shift;
 104         my $nsem = shift or 0;
 105         return $self->{'semaphore'}->getncnt($nsem);
 106 }
 107
 108 sub getslot {
 109         my $self = shift;
 110
 111         my %args;
 112         if (@_ >= 1 && $_[0] =~ /^\d+$/) {
 113                 # Positional arguments
 114                 ($args{'number'}, $args{'wait'}, $args{'maxqueue'}, $args{'undo'}) = @_;
 115         } else {
 116                 %args = @_;
 117         }
 118         # Defaults
 119         $args{'number'}   ||= 0;
 120         $args{'wait'}     ||= 0;
 121         $args{'maxqueue'} ||= 0;
 122         $args{'undo'}     ||= 1;
 123
 124         my $sem = $self->{'semaphore'};
 125         my $flags = IPC_NOWAIT;
 126         $flags |= SEM_UNDO if ($args{'undo'});
 127
 128         my $ret;
 129         if (($ret = $sem->op($args{'number'}, -1, $flags))) {
 130                 return $ret;
 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);
 136         }
 137         return $ret;
 138 }
 139
 140 sub release {
 141         my $self = shift;
 142         my $number = shift || 0;
 143         return $self->{'semaphore'}->op($number, 1, 0);
 144 }
 145
 146 sub remove {
 147         my $self = shift;
 148         return $self->{'semaphore'}->remove();
 149 }
 150
 151 1;
 152 __END__
 153 # Below is stub documentation for your module. You'd better edit it!
 154
 155 =head1 NAME
 156
 157 IPC::Semaphore::Concurrency - Perl extension for blah blah blah
 158
 159 =head1 SYNOPSIS
 160
 161   use IPC::Semaphore::Concurrency;
 162   blah blah blah
 163
 164 =head1 DESCRIPTION
 165
 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
 168 unedited.
 169
 170 Blah blah blah.
 171
 172 =head2 EXPORT
 173
 174 None by default.
 175
 176
 177
 178 =head1 SEE ALSO
 179
 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
 183 standards.
 184
 185 If you have a mailing list set up for your module, mention it here.
 186
 187 If you have a web site set up for your module, mention it here.
 188
 189 =head1 AUTHOR
 190
 191 A. U. Thor, E<lt>root@slackware.lanE<gt>
 192
 193 =head1 COPYRIGHT AND LICENSE
 194
 195 Copyright (C) 2009 by A. U. Thor
 196
 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.
 200
 201
 202 =cut