home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / ext / IPC / SysV / Semaphore.pm < prev    next >
Text File  |  2000-03-03  |  6KB  |  298 lines
  1. # IPC::Semaphore
  2. #
  3. # Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
  4. # This program is free software; you can redistribute it and/or
  5. # modify it under the same terms as Perl itself.
  6.  
  7. package IPC::Semaphore;
  8.  
  9. use IPC::SysV qw(GETNCNT GETZCNT GETVAL SETVAL GETPID GETALL SETALL
  10.          IPC_STAT IPC_SET IPC_RMID);
  11. use strict;
  12. use vars qw($VERSION);
  13. use Carp;
  14.  
  15. $VERSION = "1.00";
  16.  
  17. {
  18.     package IPC::Semaphore::stat;
  19.  
  20.     use Class::Struct qw(struct);
  21.  
  22.     struct 'IPC::Semaphore::stat' => [
  23.     uid    => '$',
  24.     gid    => '$',
  25.     cuid    => '$',
  26.     cgid    => '$',
  27.     mode    => '$',
  28.     ctime    => '$',
  29.     otime    => '$',
  30.     nsems    => '$',
  31.     ];
  32. }
  33.  
  34. sub new {
  35.     @_ == 4 || croak 'new ' . __PACKAGE__ . '( KEY, NSEMS, FLAGS )';
  36.     my $class = shift;
  37.  
  38.     my $id = semget($_[0],$_[1],$_[2]);
  39.  
  40.     defined($id)
  41.     ? bless \$id, $class
  42.     : undef;
  43. }
  44.  
  45. sub id {
  46.     my $self = shift;
  47.     $$self;
  48. }
  49.  
  50. sub remove {
  51.     my $self = shift;
  52.     (semctl($$self,0,IPC_RMID,0), undef $$self)[0];
  53. }
  54.  
  55. sub getncnt {
  56.     @_ == 2 || croak '$sem->getncnt( SEM )';
  57.     my $self = shift;
  58.     my $sem = shift;
  59.     my $v = semctl($$self,$sem,GETNCNT,0);
  60.     $v ? 0 + $v : undef;
  61. }
  62.  
  63. sub getzcnt {
  64.     @_ == 2 || croak '$sem->getzcnt( SEM )';
  65.     my $self = shift;
  66.     my $sem = shift;
  67.     my $v = semctl($$self,$sem,GETZCNT,0);
  68.     $v ? 0 + $v : undef;
  69. }
  70.  
  71. sub getval {
  72.     @_ == 2 || croak '$sem->getval( SEM )';
  73.     my $self = shift;
  74.     my $sem = shift;
  75.     my $v = semctl($$self,$sem,GETVAL,0);
  76.     $v ? 0 + $v : undef;
  77. }
  78.  
  79. sub getpid {
  80.     @_ == 2 || croak '$sem->getpid( SEM )';
  81.     my $self = shift;
  82.     my $sem = shift;
  83.     my $v = semctl($$self,$sem,GETPID,0);
  84.     $v ? 0 + $v : undef;
  85. }
  86.  
  87. sub op {
  88.     @_ >= 4 || croak '$sem->op( OPLIST )';
  89.     my $self = shift;
  90.     croak 'Bad arg count' if @_ % 3;
  91.     my $data = pack("s*",@_);
  92.     semop($$self,$data);
  93. }
  94.  
  95. sub stat {
  96.     my $self = shift;
  97.     my $data = "";
  98.     semctl($$self,0,IPC_STAT,$data)
  99.     or return undef;
  100.     IPC::Semaphore::stat->new->unpack($data);
  101. }
  102.  
  103. sub set {
  104.     my $self = shift;
  105.     my $ds;
  106.  
  107.     if(@_ == 1) {
  108.     $ds = shift;
  109.     }
  110.     else {
  111.     croak 'Bad arg count' if @_ % 2;
  112.     my %arg = @_;
  113.     my $ds = $self->stat
  114.         or return undef;
  115.     my($key,$val);
  116.     $ds->$key($val)
  117.         while(($key,$val) = each %arg);
  118.     }
  119.  
  120.     my $v = semctl($$self,0,IPC_SET,$ds->pack);
  121.     $v ? 0 + $v : undef;
  122. }
  123.  
  124. sub getall {
  125.     my $self = shift;
  126.     my $data = "";
  127.     semctl($$self,0,GETALL,$data)
  128.     or return ();
  129.     (unpack("s*",$data));
  130. }
  131.  
  132. sub setall {
  133.     my $self = shift;
  134.     my $data = pack("s*",@_);
  135.     semctl($$self,0,SETALL,$data);
  136. }
  137.  
  138. sub setval {
  139.     @_ == 3 || croak '$sem->setval( SEM, VAL )';
  140.     my $self = shift;
  141.     my $sem = shift;
  142.     my $val = shift;
  143.     semctl($$self,$sem,SETVAL,$val);
  144. }
  145.  
  146. 1;
  147.  
  148. __END__
  149.  
  150. =head1 NAME
  151.  
  152. IPC::Semaphore - SysV Semaphore IPC object class
  153.  
  154. =head1 SYNOPSIS
  155.  
  156.     use IPC::SysV qw(IPC_PRIVATE S_IRWXU IPC_CREAT);
  157.     use IPC::Semaphore;
  158.  
  159.     $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | IPC_CREAT);
  160.  
  161.     $sem->setall( (0) x 10);
  162.  
  163.     @sem = $sem->getall;
  164.  
  165.     $ncnt = $sem->getncnt;
  166.  
  167.     $zcnt = $sem->getzcnt;
  168.  
  169.     $ds = $sem->stat;
  170.  
  171.     $sem->remove;
  172.  
  173. =head1 DESCRIPTION
  174.  
  175. =head1 METHODS
  176.  
  177. =over 4
  178.  
  179. =item new ( KEY , NSEMS , FLAGS )
  180.  
  181. Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number
  182. of semaphores in the set. A new set is created if
  183.  
  184. =over 4
  185.  
  186. =item *
  187.  
  188. C<KEY> is equal to C<IPC_PRIVATE>
  189.  
  190. =item *
  191.  
  192. C<KEY> does not already  have  a  semaphore  identifier
  193. associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
  194.  
  195. =back
  196.  
  197. On creation of a new semaphore set C<FLAGS> is used to set the
  198. permissions.
  199.  
  200. =item getall
  201.  
  202. Returns the values of the semaphore set as an array.
  203.  
  204. =item getncnt ( SEM )
  205.  
  206. Returns the number of processed waiting for the semaphore C<SEM> to
  207. become greater than it's current value
  208.  
  209. =item getpid ( SEM )
  210.  
  211. Returns the process id of the last process that performed an operation
  212. on the semaphore C<SEM>.
  213.  
  214. =item getval ( SEM )
  215.  
  216. Returns the current value of the semaphore C<SEM>.
  217.  
  218. =item getzcnt ( SEM )
  219.  
  220. Returns the number of processed waiting for the semaphore C<SEM> to
  221. become zero.
  222.  
  223. =item id
  224.  
  225. Returns the system identifier for the semaphore set.
  226.  
  227. =item op ( OPLIST )
  228.  
  229. C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is
  230. a concatenation of smaller lists, each which has three values. The
  231. first is the semaphore number, the second is the operation and the last
  232. is a flags value. See L<semop> for more details. For example
  233.  
  234.     $sem->op(
  235.     0, -1, IPC_NOWAIT,
  236.     1,  1, IPC_NOWAIT
  237.     );
  238.  
  239. =item remove
  240.  
  241. Remove and destroy the semaphore set from the system.
  242.  
  243. =item set ( STAT )
  244.  
  245. =item set ( NAME => VALUE [, NAME => VALUE ...] )
  246.  
  247. C<set> will set the following values of the C<stat> structure associated
  248. with the semaphore set.
  249.  
  250.     uid
  251.     gid
  252.     mode (oly the permission bits)
  253.  
  254. C<set> accepts either a stat object, as returned by the C<stat> method,
  255. or a list of I<name>-I<value> pairs.
  256.  
  257. =item setall ( VALUES )
  258.  
  259. Sets all values in the semaphore set to those given on the C<VALUES> list.
  260. C<VALUES> must contain the correct number of values.
  261.  
  262. =item setval ( N , VALUE )
  263.  
  264. Set the C<N>th value in the semaphore set to C<VALUE>
  265.  
  266. =item stat
  267.  
  268. Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of
  269. C<Class::Struct>. It provides the following fields. For a description
  270. of these fields see you system documentation.
  271.  
  272.     uid
  273.     gid
  274.     cuid
  275.     cgid
  276.     mode
  277.     ctime
  278.     otime
  279.     nsems
  280.  
  281. =back
  282.  
  283. =head1 SEE ALSO
  284.  
  285. L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop> 
  286.  
  287. =head1 AUTHOR
  288.  
  289. Graham Barr <gbarr@pobox.com>
  290.  
  291. =head1 COPYRIGHT
  292.  
  293. Copyright (c) 1997 Graham Barr. All rights reserved.
  294. This program is free software; you can redistribute it and/or modify it
  295. under the same terms as Perl itself.
  296.  
  297. =cut
  298.