true|$define|y) avail_ext="$avail_ext $xxx" ;;
esac
;;
+ IPC/SysV|ipc_sysv)
+ case "$d_sem" in
+ true|$define|y) avail_ext="$avail_ext $xxx" ;;
+ esac
+ ;;
*) avail_ext="$avail_ext $xxx"
;;
esac
ext/IO/lib/IO/Seekable.pm IO::Seekable extension Perl module
ext/IO/lib/IO/Select.pm IO::Select extension Perl module
ext/IO/lib/IO/Socket.pm IO::Socket extension Perl module
+ext/IPC/SysV/ChangeLog IPC::SysV extension Perl module
+ext/IPC/SysV/MANIFEST IPC::SysV extension Perl module
+ext/IPC/SysV/Makefile.PL IPC::SysV extension Perl module
+ext/IPC/SysV/README IPC::SysV extension Perl module
+ext/IPC/SysV/SysV.pm IPC::SysV extension Perl module
+ext/IPC/SysV/SysV.xs IPC::SysV extension Perl module
+ext/IPC/SysV/Msg.pm IPC::SysV extension Perl module
+ext/IPC/SysV/Semaphore.pm IPC::SysV extension Perl module
+ext/IPC/SysV/t/msg.t IPC::SysV extension Perl module
+ext/IPC/SysV/t/sem.t IPC::SysV extension Perl module
ext/NDBM_File/Makefile.PL NDBM extension makefile writer
ext/NDBM_File/NDBM_File.pm NDBM extension Perl module
ext/NDBM_File/NDBM_File.xs NDBM extension external subroutines
--- /dev/null
+Fri Jul 3 15:06:40 1998 Jarkko Hietaniemi <jhi@iki.fi>
+
+ - Integrated IPC::SysV 1.03 to Perl 5.004_69.
+
+Change 142 on 1998/05/31 by <gbarr@pobox.com> (Graham Barr)
+
+ - Changed SHMLBA from a constSUB to an XS sub as on some systems it is not
+ a constant
+ - Added a missing MODULE line to SysV.xs so ftok is defined in IPC::SysV
+
+Change 138 on 1998/05/23 by <gbarr@pobox.com> (Graham Barr)
+
+ Applied patch from Jarkko Hietaniemi to add constats for UNICOS
+
+ Reduced size of XS object by changing constant sub definition
+ into a loop
+
+ Updated POD to include ftok()
+
+Change 135 on 1998/05/18 by <gbarr@pobox.com> (Graham Barr)
+
+ applied changes from Jarkko Hietaniemi <jhi@iki.fi> to add
+ new constants and ftok
+
+ fixed to compile with >5.004_50
+
+ surrounded newCONSTSUB with #ifndef as perl now defines this itself
+
--- /dev/null
+MANIFEST
+Makefile.PL
+Msg.pm
+README
+Semaphore.pm
+SysV.pm
+SysV.xs
+t/msg.t
+t/sem.t
+ChangeLog
--- /dev/null
+# This -*- perl -*- script makes the Makefile
+# $Id: Makefile.PL,v 1.3 1997/03/04 09:21:12 gbarr Exp $
+
+require 5.002;
+use ExtUtils::MakeMaker;
+
+#--- MY package
+
+sub MY::libscan
+{
+ my($self,$path) = @_;
+
+ return ''
+ if($path =~ m:/(RCS|CVS|SCCS)/: ||
+ $path =~ m:[~%]$: ||
+ $path =~ m:\.(orig|rej)$:
+ );
+
+ $path;
+}
+
+WriteMakefile(
+ VERSION_FROM => "SysV.pm",
+ NAME => "IPC::SysV",
+
+ 'linkext' => {LINKTYPE => 'dynamic' },
+ 'dist' => {COMPRESS => 'gzip -9f',
+ SUFFIX => 'gz',
+ DIST_DEFAULT => 'all tardist',
+ },
+
+ 'clean' => {FILES => join(" ",
+ map { "$_ */$_ */*/$_" }
+ qw(*% *.html *.b[ac]k *.old *.orig))
+ },
+ 'macro' => { INSTALLDIRS => 'perl' },
+);
--- /dev/null
+# IPC::Msg.pm
+#
+# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IPC::Msg;
+
+use IPC::SysV qw(IPC_STAT IPC_SET IPC_RMID);
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = "1.00";
+
+{
+ package IPC::Msg::stat;
+
+ use Class::Struct qw(struct);
+
+ struct 'IPC::Msg::stat' => [
+ uid => '$',
+ gid => '$',
+ cuid => '$',
+ cgid => '$',
+ mode => '$',
+ qnum => '$',
+ qbytes => '$',
+ lspid => '$',
+ lrpid => '$',
+ stime => '$',
+ rtime => '$',
+ ctime => '$',
+ ];
+}
+
+sub new {
+ @_ == 3 || croak 'new IPC::Msg ( KEY , FLAGS )';
+ my $class = shift;
+
+ my $id = msgget($_[0],$_[1]);
+
+ defined($id)
+ ? bless \$id, $class
+ : undef;
+}
+
+sub id {
+ my $self = shift;
+ $$self;
+}
+
+sub stat {
+ my $self = shift;
+ my $data = "";
+ msgctl($$self,IPC_STAT,$data) or
+ return undef;
+ IPC::Msg::stat->new->unpack($data);
+}
+
+sub set {
+ my $self = shift;
+ my $ds;
+
+ if(@_ == 1) {
+ $ds = shift;
+ }
+ else {
+ croak 'Bad arg count' if @_ % 2;
+ my %arg = @_;
+ my $ds = $self->stat
+ or return undef;
+ my($key,$val);
+ $ds->$key($val)
+ while(($key,$val) = each %arg);
+ }
+
+ msgctl($$self,IPC_SET,$ds->pack);
+}
+
+sub remove {
+ my $self = shift;
+ (msgctl($$self,IPC_RMID,0), undef $$self)[0];
+}
+
+sub rcv {
+ @_ == 5 || croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )';
+ my $self = shift;
+ my $buf = "";
+ msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or
+ return;
+ my $type;
+ ($type,$_[0]) = unpack("L a*",$buf);
+ $type;
+}
+
+sub snd {
+ @_ == 4 || croak '$msg->snd( TYPE, BUF, FLAGS )';
+ my $self = shift;
+ msgsnd($$self,pack("L a*",$_[0],$_[1]), $_[2] || 0);
+}
+
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::Msg - SysV Msg IPC object class
+
+=head1 SYNOPSIS
+
+ use IPC::SysV qw(IPC_PRIVATE S_IRWXU S_IRWXG S_IRWXO);
+ use IPC::Msg;
+
+ $msg = new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
+
+ $msg->snd(pack("L a*",$msgtype,$msg));
+
+ $msg->rcv($buf,256);
+
+ $ds = $msg->stat;
+
+ $msg->remove;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item new ( KEY , FLAGS )
+
+Creates a new message queue associated with C<KEY>. A new queue is
+created if
+
+=over 4
+
+=item *
+
+C<KEY> is equal to C<IPC_PRIVATE>
+
+=item *
+
+C<KEY> does not already have a message queue
+associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
+
+=back
+
+On creation of a new message queue C<FLAGS> is used to set the
+permissions.
+
+=item id
+
+Returns the system message queue identifier.
+
+=item rcv ( BUF, LEN [, TYPE [, FLAGS ]] )
+
+Read a message from the queue. Returns the type of the message read. See
+L<msgrcv>
+
+=item remove
+
+Remove and destroy the message queue from the system.
+
+=item set ( STAT )
+
+=item set ( NAME => VALUE [, NAME => VALUE ...] )
+
+C<set> will set the following values of the C<stat> structure associated
+with the message queue.
+
+ uid
+ gid
+ mode (oly the permission bits)
+ qbytes
+
+C<set> accepts either a stat object, as returned by the C<stat> method,
+or a list of I<name>-I<value> pairs.
+
+=item snd ( TYPE, MSG [, FLAGS ] )
+
+Place a message on the queue with the data from C<MSG> and with type C<TYPE>.
+See L<msgsnd>.
+
+=item stat
+
+Returns an object of type C<IPC::Msg::stat> which is a sub-class of
+C<Class::Struct>. It provides the following fields. For a description
+of these fields see you system documentation.
+
+ uid
+ gid
+ cuid
+ cgid
+ mode
+ qnum
+ qbytes
+ lspid
+ lrpid
+ stime
+ rtime
+ ctime
+
+=back
+
+=head1 SEE ALSO
+
+L<IPC::SysV> L<Class::Struct>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+This package is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+The SysV-IPC contains three packages
+
+ IPC::Semaphore
+ - Provides an object interface to using SysV IPC semaphores
+
+ IPC::Msg
+ - Provides an object interface to using SysV IPC messages
+
+ IPC::SysV
+ - Provides the constants required to use the system SysV IPC calls.
+
+Currently there is not object support for SysV shared memory, but
+SysV::SharedMem is a project for the future.
+
+Share and enjoy!
+
--- /dev/null
+# IPC::Semaphore
+#
+# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IPC::Semaphore;
+
+use IPC::SysV qw(GETNCNT GETZCNT GETVAL SETVAL GETPID GETALL SETALL
+ IPC_STAT IPC_SET IPC_RMID);
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = "1.00";
+
+{
+ package IPC::Semaphore::stat;
+
+ use Class::Struct qw(struct);
+
+ struct 'IPC::Semaphore::stat' => [
+ uid => '$',
+ gid => '$',
+ cuid => '$',
+ cgid => '$',
+ mode => '$',
+ ctime => '$',
+ otime => '$',
+ nsems => '$',
+ ];
+}
+
+sub new {
+ @_ == 4 || croak 'new ' . __PACKAGE__ . '( KEY, NSEMS, FLAGS )';
+ my $class = shift;
+
+ my $id = semget($_[0],$_[1],$_[2]);
+
+ defined($id)
+ ? bless \$id, $class
+ : undef;
+}
+
+sub id {
+ my $self = shift;
+ $$self;
+}
+
+sub remove {
+ my $self = shift;
+ (semctl($$self,0,IPC_RMID,0), undef $$self)[0];
+}
+
+sub getncnt {
+ @_ == 2 || croak '$sem->getncnt( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETNCNT,0);
+ $v ? 0 + $v : undef;
+}
+
+sub getzcnt {
+ @_ == 2 || croak '$sem->getzcnt( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETZCNT,0);
+ $v ? 0 + $v : undef;
+}
+
+sub getval {
+ @_ == 2 || croak '$sem->getval( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETVAL,0);
+ $v ? 0 + $v : undef;
+}
+
+sub getpid {
+ @_ == 2 || croak '$sem->getpid( SEM )';
+ my $self = shift;
+ my $sem = shift;
+ my $v = semctl($$self,$sem,GETPID,0);
+ $v ? 0 + $v : undef;
+}
+
+sub op {
+ @_ >= 4 || croak '$sem->op( OPLIST )';
+ my $self = shift;
+ croak 'Bad arg count' if @_ % 3;
+ my $data = pack("s*",@_);
+ semop($$self,$data);
+}
+
+sub stat {
+ my $self = shift;
+ my $data = "";
+ semctl($$self,0,IPC_STAT,$data)
+ or return undef;
+ IPC::Semaphore::stat->new->unpack($data);
+}
+
+sub set {
+ my $self = shift;
+ my $ds;
+
+ if(@_ == 1) {
+ $ds = shift;
+ }
+ else {
+ croak 'Bad arg count' if @_ % 2;
+ my %arg = @_;
+ my $ds = $self->stat
+ or return undef;
+ my($key,$val);
+ $ds->$key($val)
+ while(($key,$val) = each %arg);
+ }
+
+ my $v = semctl($$self,0,IPC_SET,$ds->pack);
+ $v ? 0 + $v : undef;
+}
+
+sub getall {
+ my $self = shift;
+ my $data = "";
+ semctl($$self,0,GETALL,$data)
+ or return ();
+ (unpack("s*",$data));
+}
+
+sub setall {
+ my $self = shift;
+ my $data = pack("s*",@_);
+ semctl($$self,0,SETALL,$data);
+}
+
+sub setval {
+ @_ == 3 || croak '$sem->setval( SEM, VAL )';
+ my $self = shift;
+ my $sem = shift;
+ my $val = shift;
+ semctl($$self,$sem,SETVAL,$val);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::Semaphore - SysV Semaphore IPC object class
+
+=head1 SYNOPSIS
+
+ use IPC::SysV qw(IPC_PRIVATE S_IRWXU IPC_CREAT);
+ use IPC::Semaphore;
+
+ $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | IPC_CREAT);
+
+ $sem->setall( (0) x 10);
+
+ @sem = $sem->getall;
+
+ $ncnt = $sem->getncnt;
+
+ $zcnt = $sem->getzcnt;
+
+ $ds = $sem->stat;
+
+ $sem->remove;
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item new ( KEY , NSEMS , FLAGS )
+
+Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number
+of semaphores in the set. A new set is created if
+
+=over 4
+
+=item *
+
+C<KEY> is equal to C<IPC_PRIVATE>
+
+=item *
+
+C<KEY> does not already have a semaphore identifier
+associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
+
+=back
+
+On creation of a new semaphore set C<FLAGS> is used to set the
+permissions.
+
+=item getall
+
+Returns the values of the semaphore set as an array.
+
+=item getncnt ( SEM )
+
+Returns the number of processed waiting for the semaphore C<SEM> to
+become greater than it's current value
+
+=item getpid ( SEM )
+
+Returns the process id of the last process that performed an operation
+on the semaphore C<SEM>.
+
+=item getval ( SEM )
+
+Returns the current value of the semaphore C<SEM>.
+
+=item getzcnt ( SEM )
+
+Returns the number of processed waiting for the semaphore C<SEM> to
+become zero.
+
+=item id
+
+Returns the system identifier for the semaphore set.
+
+=item op ( OPLIST )
+
+C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is
+a concatenation of smaller lists, each which has three values. The
+first is the semaphore number, the second is the operation and the last
+is a flags value. See L<semop> for more details. For example
+
+ $sem->op(
+ 0, -1, IPC_NOWAIT,
+ 1, 1, IPC_NOWAIT
+ );
+
+=item remove
+
+Remove and destroy the semaphore set from the system.
+
+=item set ( STAT )
+
+=item set ( NAME => VALUE [, NAME => VALUE ...] )
+
+C<set> will set the following values of the C<stat> structure associated
+with the semaphore set.
+
+ uid
+ gid
+ mode (oly the permission bits)
+
+C<set> accepts either a stat object, as returned by the C<stat> method,
+or a list of I<name>-I<value> pairs.
+
+=item setall ( VALUES )
+
+Sets all values in the semaphore set to those given on the C<VALUES> list.
+C<VALUES> must contain the correct number of values.
+
+=item setval ( N , VALUE )
+
+Set the C<N>th value in the semaphore set to C<VALUE>
+
+=item stat
+
+Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of
+C<Class::Struct>. It provides the following fields. For a description
+of these fields see you system documentation.
+
+ uid
+ gid
+ cuid
+ cgid
+ mode
+ ctime
+ otime
+ nsems
+
+=back
+
+=head1 SEE ALSO
+
+L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop>
+
+=head1 AUTHOR
+
+Graham Barr <gbarr@pobox.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
--- /dev/null
+# IPC::SysV.pm
+#
+# Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IPC::SysV;
+
+use strict;
+use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
+use Carp;
+use Config;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = "1.03";
+
+@EXPORT_OK = qw(
+ GETALL GETNCNT GETPID GETVAL GETZCNT
+
+ IPC_ALLOC IPC_CREAT IPC_EXCL IPC_GETACL IPC_LOCKED IPC_M
+ IPC_NOERROR IPC_NOWAIT IPC_PRIVATE IPC_R IPC_RMID IPC_SET
+ IPC_SETACL IPC_SETLABEL IPC_STAT IPC_W IPC_WANTED
+
+ MSG_FWAIT MSG_LOCKED MSG_MWAIT MSG_NOERROR MSG_QWAIT
+ MSG_R MSG_RWAIT MSG_STAT MSG_W MSG_WWAIT
+
+ SEM_A SEM_ALLOC SEM_DEST SEM_ERR SEM_ORDER SEM_R SEM_UNDO
+
+ SETALL SETVAL
+
+ SHMLBA
+
+ SHM_A SHM_CLEAR SHM_COPY SHM_DCACHE SHM_DEST SHM_ECACHE
+ SHM_FMAP SHM_ICACHE SHM_INIT SHM_LOCK SHM_LOCKED SHM_MAP
+ SHM_NOSWAP SHM_R SHM_RDONLY SHM_REMOVED SHM_RND SHM_SHARE_MMU
+ SHM_SHATTR SHM_SIZE SHM_UNLOCK SHM_W
+
+ S_IRUSR S_IWUSR S_IRWXU
+ S_IRGRP S_IWGRP S_IRWXG
+ S_IROTH S_IWOTH S_IRWXO
+
+ ftok
+);
+
+BOOT_XS: {
+ # If I inherit DynaLoader then I inherit AutoLoader and I DON'T WANT TO
+ require DynaLoader;
+
+ # DynaLoader calls dl_load_flags as a static method.
+ *dl_load_flags = DynaLoader->can('dl_load_flags');
+
+ do {
+ __PACKAGE__->can('bootstrap') || \&DynaLoader::bootstrap
+ }->(__PACKAGE__, $VERSION);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::SysV - SysV IPC constants
+
+=head1 SYNOPSIS
+
+ use IPC::SysV qw(IPC_STAT IPC_PRIVATE);
+
+=head1 DESCRIPTION
+
+C<IPC::SysV> defines and conditionally exports all the constants
+defined in your system include files which are needed by the SysV
+IPC calls.
+
+=item ftok( PATH, ID )
+
+Return a key based on PATH and ID, which can be used as a key for
+C<msgget>, C<semget> and C<shmget>. See L<ftok>
+
+=head1 SEE ALSO
+
+L<IPC::Msg>, L<IPC::Semaphore>, L<ftok>
+
+=head1 AUTHORS
+
+Graham Barr <gbarr@pobox.com>
+Jarkko Hietaniemi <jhi@iki.fi>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1997 Graham Barr. All rights reserved.
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include <sys/types.h>
+#ifdef __linux__
+#include <asm/page.h>
+#endif
+#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
+#include <sys/ipc.h>
+#ifdef HAS_MSG
+#include <sys/msg.h>
+#endif
+#ifdef HAS_SEM
+#include <sys/sem.h>
+#endif
+#ifdef HAS_SHM
+#include <sys/shm.h>
+# ifndef HAS_SHMAT_PROTOTYPE
+ extern Shmat_t shmat _((int, char *, int));
+# endif
+#endif
+#endif
+
+#ifndef newCONSTSUB
+static void
+newCONSTSUB(stash,name,sv)
+ HV *stash;
+ char *name;
+ SV *sv;
+{
+#ifdef dTHR
+ dTHR;
+#endif
+ U32 oldhints = hints;
+ HV *old_cop_stash = curcop->cop_stash;
+ HV *old_curstash = curstash;
+ line_t oldline = curcop->cop_line;
+ curcop->cop_line = copline;
+
+ hints &= ~HINT_BLOCK_SCOPE;
+ if(stash)
+ curstash = curcop->cop_stash = stash;
+
+ newSUB(
+ start_subparse(FALSE, 0),
+ newSVOP(OP_CONST, 0, newSVpv(name,0)),
+ newSVOP(OP_CONST, 0, &sv_no), /* SvPV(&sv_no) == "" -- GMB */
+ newSTATEOP(0, Nullch, newSVOP(OP_CONST, 0, sv))
+ );
+
+ hints = oldhints;
+ curcop->cop_stash = old_cop_stash;
+ curstash = old_curstash;
+ curcop->cop_line = oldline;
+}
+#endif
+
+MODULE=IPC::SysV PACKAGE=IPC::Msg::stat
+
+PROTOTYPES: ENABLE
+
+void
+pack(obj)
+ SV * obj
+PPCODE:
+{
+ SV *sv;
+ struct msqid_ds ds;
+ AV *list = (AV*)SvRV(obj);
+ sv = *av_fetch(list,0,TRUE); ds.msg_perm.uid = SvIV(sv);
+ sv = *av_fetch(list,1,TRUE); ds.msg_perm.gid = SvIV(sv);
+ sv = *av_fetch(list,4,TRUE); ds.msg_perm.mode = SvIV(sv);
+ sv = *av_fetch(list,6,TRUE); ds.msg_qbytes = SvIV(sv);
+ ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds)));
+ XSRETURN(1);
+}
+
+void
+unpack(obj,buf)
+ SV * obj
+ SV * buf
+PPCODE:
+{
+ STRLEN len;
+ SV **sv_ptr;
+ struct msqid_ds *ds = (struct msqid_ds *)SvPV(buf,len);
+ AV *list = (AV*)SvRV(obj);
+ if (len != sizeof(*ds)) {
+ croak("Bad arg length for %s, length is %d, should be %d",
+ "IPC::Msg::stat",
+ len, sizeof(*ds));
+ }
+ sv_ptr = av_fetch(list,0,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.uid);
+ sv_ptr = av_fetch(list,1,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.gid);
+ sv_ptr = av_fetch(list,2,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.cuid);
+ sv_ptr = av_fetch(list,3,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.cgid);
+ sv_ptr = av_fetch(list,4,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_perm.mode);
+ sv_ptr = av_fetch(list,5,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_qnum);
+ sv_ptr = av_fetch(list,6,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_qbytes);
+ sv_ptr = av_fetch(list,7,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_lspid);
+ sv_ptr = av_fetch(list,8,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_lrpid);
+ sv_ptr = av_fetch(list,9,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_stime);
+ sv_ptr = av_fetch(list,10,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_rtime);
+ sv_ptr = av_fetch(list,11,TRUE);
+ sv_setiv(*sv_ptr, ds->msg_ctime);
+ XSRETURN(1);
+}
+
+MODULE=IPC::SysV PACKAGE=IPC::Semaphore::stat
+
+void
+unpack(obj,ds)
+ SV * obj
+ SV * ds
+PPCODE:
+{
+ STRLEN len;
+ AV *list = (AV*)SvRV(obj);
+ struct semid_ds *data = (struct semid_ds *)SvPV(ds,len);
+ if(!sv_isa(obj, "IPC::Semaphore::stat"))
+ croak("method %s not called a %s object",
+ "unpack","IPC::Semaphore::stat");
+ if (len != sizeof(*data)) {
+ croak("Bad arg length for %s, length is %d, should be %d",
+ "IPC::Semaphore::stat",
+ len, sizeof(*data));
+ }
+ sv_setiv(*av_fetch(list,0,TRUE), data[0].sem_perm.uid);
+ sv_setiv(*av_fetch(list,1,TRUE), data[0].sem_perm.gid);
+ sv_setiv(*av_fetch(list,2,TRUE), data[0].sem_perm.cuid);
+ sv_setiv(*av_fetch(list,3,TRUE), data[0].sem_perm.cgid);
+ sv_setiv(*av_fetch(list,4,TRUE), data[0].sem_perm.mode);
+ sv_setiv(*av_fetch(list,5,TRUE), data[0].sem_ctime);
+ sv_setiv(*av_fetch(list,6,TRUE), data[0].sem_otime);
+ sv_setiv(*av_fetch(list,7,TRUE), data[0].sem_nsems);
+ XSRETURN(1);
+}
+
+void
+pack(obj)
+ SV * obj
+PPCODE:
+{
+ SV **sv_ptr;
+ SV *sv;
+ struct semid_ds ds;
+ AV *list = (AV*)SvRV(obj);
+ if(!sv_isa(obj, "IPC::Semaphore::stat"))
+ croak("method %s not called a %s object",
+ "pack","IPC::Semaphore::stat");
+ if((sv_ptr = av_fetch(list,0,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.uid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,1,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.gid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,2,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.cuid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,3,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.cgid = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,4,TRUE)) && (sv = *sv_ptr))
+ ds.sem_perm.mode = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,5,TRUE)) && (sv = *sv_ptr))
+ ds.sem_ctime = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,6,TRUE)) && (sv = *sv_ptr))
+ ds.sem_otime = SvIV(*sv_ptr);
+ if((sv_ptr = av_fetch(list,7,TRUE)) && (sv = *sv_ptr))
+ ds.sem_nsems = SvIV(*sv_ptr);
+ ST(0) = sv_2mortal(newSVpv((char *)&ds,sizeof(ds)));
+ XSRETURN(1);
+}
+
+MODULE=IPC::SysV PACKAGE=IPC::SysV
+
+int
+ftok(path, id)
+ char * path
+ int id
+ CODE:
+#if defined(HAS_SEM) || defined(HAS_SHM)
+ key_t k = ftok(path, id);
+ ST(0) = k == (key_t) -1 ? &sv_undef : sv_2mortal(newSViv(k));
+#else
+ DIE(no_func, "ftok");
+#endif
+
+int
+SHMLBA()
+ CODE:
+#ifdef SHMLBA
+ ST(0) = sv_2mortal(newSViv(SHMLBA));
+#else
+ croak("SHMLBA is not defined on this architecture");
+#endif
+
+BOOT:
+{
+ HV *stash = gv_stashpvn("IPC::SysV", 9, TRUE);
+ /*
+ * constant subs for IPC::SysV
+ */
+ struct { char *n; I32 v; } IPC__SysV__const[] = {
+#ifdef GETVAL
+ {"GETVAL", GETVAL},
+#endif
+#ifdef GETPID
+ {"GETPID", GETPID},
+#endif
+#ifdef GETNCNT
+ {"GETNCNT", GETNCNT},
+#endif
+#ifdef GETZCNT
+ {"GETZCNT", GETZCNT},
+#endif
+#ifdef GETALL
+ {"GETALL", GETALL},
+#endif
+#ifdef IPC_ALLOC
+ {"IPC_ALLOC", IPC_ALLOC},
+#endif
+#ifdef IPC_CREAT
+ {"IPC_CREAT", IPC_CREAT},
+#endif
+#ifdef IPC_EXCL
+ {"IPC_EXCL", IPC_EXCL},
+#endif
+#ifdef IPC_GETACL
+ {"IPC_GETACL", IPC_EXCL},
+#endif
+#ifdef IPC_LOCKED
+ {"IPC_LOCKED", IPC_LOCKED},
+#endif
+#ifdef IPC_M
+ {"IPC_M", IPC_M},
+#endif
+#ifdef IPC_NOERROR
+ {"IPC_NOERROR", IPC_NOERROR},
+#endif
+#ifdef IPC_NOWAIT
+ {"IPC_NOWAIT", IPC_NOWAIT},
+#endif
+#ifdef IPC_PRIVATE
+ {"IPC_PRIVATE", IPC_PRIVATE},
+#endif
+#ifdef IPC_R
+ {"IPC_R", IPC_R},
+#endif
+#ifdef IPC_RMID
+ {"IPC_RMID", IPC_RMID},
+#endif
+#ifdef IPC_SET
+ {"IPC_SET", IPC_SET},
+#endif
+#ifdef IPC_SETACL
+ {"IPC_SETACL", IPC_SETACL},
+#endif
+#ifdef IPC_SETLABEL
+ {"IPC_SETLABEL", IPC_SETLABEL},
+#endif
+#ifdef IPC_STAT
+ {"IPC_STAT", IPC_STAT},
+#endif
+#ifdef IPC_W
+ {"IPC_W", IPC_W},
+#endif
+#ifdef IPC_WANTED
+ {"IPC_WANTED", IPC_WANTED},
+#endif
+#ifdef MSG_NOERROR
+ {"MSG_NOERROR", MSG_NOERROR},
+#endif
+#ifdef MSG_FWAIT
+ {"MSG_FWAIT", MSG_FWAIT},
+#endif
+#ifdef MSG_LOCKED
+ {"MSG_LOCKED", MSG_LOCKED},
+#endif
+#ifdef MSG_MWAIT
+ {"MSG_MWAIT", MSG_MWAIT},
+#endif
+#ifdef MSG_WAIT
+ {"MSG_WAIT", MSG_WAIT},
+#endif
+#ifdef MSG_R
+ {"MSG_R", MSG_R},
+#endif
+#ifdef MSG_RWAIT
+ {"MSG_RWAIT", MSG_RWAIT},
+#endif
+#ifdef MSG_STAT
+ {"MSG_STAT", MSG_STAT},
+#endif
+#ifdef MSG_W
+ {"MSG_W", MSG_W},
+#endif
+#ifdef MSG_WWAIT
+ {"MSG_WWAIT", MSG_WWAIT},
+#endif
+#ifdef SEM_A
+ {"SEM_A", SEM_A},
+#endif
+#ifdef SEM_ALLOC
+ {"SEM_ALLOC", SEM_ALLOC},
+#endif
+#ifdef SEM_DEST
+ {"SEM_DEST", SEM_DEST},
+#endif
+#ifdef SEM_ERR
+ {"SEM_ERR", SEM_ERR},
+#endif
+#ifdef SEM_R
+ {"SEM_R", SEM_R},
+#endif
+#ifdef SEM_ORDER
+ {"SEM_ORDER", SEM_ORDER},
+#endif
+#ifdef SEM_UNDO
+ {"SEM_UNDO", SEM_UNDO},
+#endif
+#ifdef SETVAL
+ {"SETVAL", SETVAL},
+#endif
+#ifdef SETALL
+ {"SETALL", SETALL},
+#endif
+#ifdef SHM_CLEAR
+ {"SHM_CLEAR", SHM_CLEAR},
+#endif
+#ifdef SHM_COPY
+ {"SHM_COPY", SHM_COPY},
+#endif
+#ifdef SHM_DCACHE
+ {"SHM_DCACHE", SHM_DCACHE},
+#endif
+#ifdef SHM_DEST
+ {"SHM_DEST", SHM_DEST},
+#endif
+#ifdef SHM_ECACHE
+ {"SHM_ECACHE", SHM_ECACHE},
+#endif
+#ifdef SHM_FMAP
+ {"SHM_FMAP", SHM_FMAP},
+#endif
+#ifdef SHM_ICACHE
+ {"SHM_ICACHE", SHM_ICACHE},
+#endif
+#ifdef SHM_INIT
+ {"SHM_INIT", SHM_INIT},
+#endif
+#ifdef SHM_LOCK
+ {"SHM_LOCK", SHM_LOCK},
+#endif
+#ifdef SHM_LOCKED
+ {"SHM_LOCKED", SHM_LOCKED},
+#endif
+#ifdef SHM_MAP
+ {"SHM_MAP", SHM_MAP},
+#endif
+#ifdef SHM_NOSWAP
+ {"SHM_NOSWAP", SHM_NOSWAP},
+#endif
+#ifdef SHM_RDONLY
+ {"SHM_RDONLY", SHM_RDONLY},
+#endif
+#ifdef SHM_REMOVED
+ {"SHM_REMOVED", SHM_REMOVED},
+#endif
+#ifdef SHM_RND
+ {"SHM_RND", SHM_RND},
+#endif
+#ifdef SHM_SHARE_MMU
+ {"SHM_SHARE_MMU", SHM_SHARE_MMU},
+#endif
+#ifdef SHM_SHATTR
+ {"SHM_SHATTR", SHM_SHATTR},
+#endif
+#ifdef SHM_SIZE
+ {"SHM_SIZE", SHM_SIZE},
+#endif
+#ifdef SHM_UNLOCK
+ {"SHM_UNLOCK", SHM_UNLOCK},
+#endif
+#ifdef SHM_W
+ {"SHM_W", SHM_W},
+#endif
+#ifdef S_IRUSR
+ {"S_IRUSR", S_IRUSR},
+#endif
+#ifdef S_IWUSR
+ {"S_IWUSR", S_IWUSR},
+#endif
+#ifdef S_IRWXU
+ {"S_IRWXU", S_IRWXU},
+#endif
+#ifdef S_IRGRP
+ {"S_IRGRP", S_IRGRP},
+#endif
+#ifdef S_IWGRP
+ {"S_IWGRP", S_IWGRP},
+#endif
+#ifdef S_IRWXG
+ {"S_IRWXG", S_IRWXG},
+#endif
+#ifdef S_IROTH
+ {"S_IROTH", S_IROTH},
+#endif
+#ifdef S_IWOTH
+ {"S_IWOTH", S_IWOTH},
+#endif
+#ifdef S_IRWXO
+ {"S_IRWXO", S_IRWXO},
+#endif
+ {Nullch,0}};
+ char *name;
+ int i;
+
+ for(i = 0 ; name = IPC__SysV__const[i].n ; i++) {
+ newCONSTSUB(stash,name, newSViv(IPC__SysV__const[i].v));
+ }
+}
+
--- /dev/null
+use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_NOWAIT IPC_STAT S_IRWXU S_IRWXG S_IRWXO);
+
+use IPC::Msg;
+#Creating a message queue
+
+print "1..9\n";
+
+$msq = new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO)
+ || die "msgget: ",$!+0," $!\n";
+
+print "ok 1\n";
+
+#Putting a message on the queue
+$msgtype = 1;
+$msg = "hello";
+$msq->snd($msgtype,$msg,0) || print "not ";
+print "ok 2\n";
+
+#Check if there are messages on the queue
+$ds = $msq->stat() or print "not ";
+print "ok 3\n";
+
+print "not " unless $ds && $ds->qnum() == 1;
+print "ok 4\n";
+
+#Retreiving a message from the queue
+$rmsgtype = 0; # Give me any type
+$rmsgtype = $msq->rcv($rmsg,256,$rmsgtype,IPC_NOWAIT) || print "not ";
+print "ok 5\n";
+
+print "not " unless $rmsgtype == $msgtype && $rmsg eq $msg;
+print "ok 6\n";
+
+$ds = $msq->stat() or print "not ";
+print "ok 7\n";
+
+print "not " unless $ds && $ds->qnum() == 0;
+print "ok 8\n";
+
+$msq->remove || print "not ";
+print "ok 9\n";
--- /dev/null
+
+use IPC::SysV qw(
+ SETALL
+ IPC_PRIVATE
+ IPC_CREAT
+ IPC_RMID
+ IPC_NOWAIT
+ IPC_STAT
+ S_IRWXU
+ S_IRWXG
+ S_IRWXO
+);
+use IPC::Semaphore;
+
+print "1..10\n";
+
+$sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT)
+ || die "semget: ",$!+0," $!\n";
+
+print "ok 1\n";
+
+my $st = $sem->stat || print "not ";
+print "ok 2\n";
+
+$sem->setall( (0) x 10) || print "not ";
+print "ok 3\n";
+
+my @sem = $sem->getall;
+print "not " unless join("",@sem) eq "0000000000";
+print "ok 4\n";
+
+$sem[2] = 1;
+$sem->setall( @sem ) || print "not ";
+print "ok 5\n";
+
+@sem = $sem->getall;
+print "not " unless join("",@sem) eq "0010000000";
+print "ok 6\n";
+
+my $ncnt = $sem->getncnt(0);
+print "not " if $sem->getncnt(0) || !defined($ncnt);
+print "ok 7\n";
+
+$sem->op(2,-1,IPC_NOWAIT) || print "not ";
+print "ok 8\n";
+
+print "not " if $sem->getncnt(0);
+print "ok 9\n";
+
+$sem->remove || print "not ";
+print "ok 10\n";
use Fcntl;
-first to get the correct function definitions. Argument processing and
+first to get the correct constant definitions. Argument processing and
value return works just like ioctl() below.
For example:
=item msgctl ID,CMD,ARG
-Calls the System V IPC function msgctl(2). If CMD is &IPC_STAT, then ARG
-must be a variable that will hold the returned msqid_ds structure.
-Returns like ioctl: the undefined value for error, "0 but true" for
-zero, or the actual return value otherwise.
+Calls the System V IPC function msgctl(2). You'll probably have to say
+
+ use IPC::SysV;
+
+first to get the correct constant definitions. If CMD is IPC_STAT,
+then ARG must be a variable which will hold the returned msqid_ds
+structure. Returns like ioctl: the undefined value for error, "0 but
+true" for zero, or the actual return value otherwise. See also
+IPC::SysV and IPC::Semaphore::Msg documentation.
=item msgget KEY,FLAGS
-Calls the System V IPC function msgget(2). Returns the message queue id,
-or the undefined value if there is an error.
+Calls the System V IPC function msgget(2). Returns the message queue
+id, or the undefined value if there is an error. See also IPC::SysV
+and IPC::SysV::Msg documentation.
=item msgsnd ID,MSG,FLAGS
Calls the System V IPC function msgsnd to send the message MSG to the
message queue ID. MSG must begin with the long integer message type,
which may be created with C<pack("l", $type)>. Returns TRUE if
-successful, or FALSE if there is an error.
+successful, or FALSE if there is an error. See also IPC::SysV
+and IPC::SysV::Msg documentation.
=item msgrcv ID,VAR,SIZE,TYPE,FLAGS
Calls the System V IPC function msgrcv to receive a message from
message queue ID into variable VAR with a maximum message size of
-SIZE. Note that if a message is received, the message type will be the
-first thing in VAR, and the maximum length of VAR is SIZE plus the size
-of the message type. Returns TRUE if successful, or FALSE if there is
-an error.
+SIZE. Note that if a message is received, the message type will be
+the first thing in VAR, and the maximum length of VAR is SIZE plus the
+size of the message type. Returns TRUE if successful, or FALSE if
+there is an error. See also IPC::SysV and IPC::SysV::Msg documentation.
=item my EXPR
=item semctl ID,SEMNUM,CMD,ARG
-Calls the System V IPC function semctl. If CMD is &IPC_STAT or
-&GETALL, then ARG must be a variable that will hold the returned
+Calls the System V IPC function semctl. You'll probably have to say
+
+ use IPC::SysV;
+
+first to get the correct constant definitions. If CMD is IPC_STAT or
+GETALL, then ARG must be a variable which will hold the returned
semid_ds structure or semaphore value array. Returns like ioctl: the
undefined value for error, "0 but true" for zero, or the actual return
-value otherwise.
+value otherwise. See also IPC::SysV and IPC::Semaphore documentation.
=item semget KEY,NSEMS,FLAGS
Calls the System V IPC function semget. Returns the semaphore id, or
-the undefined value if there is an error.
+the undefined value if there is an error. See also IPC::SysV and
+IPC::SysV::Semaphore documentation.
=item semop KEY,OPSTRING
$semop = pack("sss", $semnum, -1, 0);
die "Semaphore trouble: $!\n" unless semop($semid, $semop);
-To signal the semaphore, replace "-1" with "1".
+To signal the semaphore, replace "-1" with "1". See also IPC::SysV
+and IPC::SysV::Semaphore documentation.
=item send SOCKET,MSG,FLAGS,TO
=item shmctl ID,CMD,ARG
-Calls the System V IPC function shmctl. If CMD is &IPC_STAT, then ARG
-must be a variable that will hold the returned shmid_ds structure.
-Returns like ioctl: the undefined value for error, "0 but true" for
-zero, or the actual return value otherwise.
+Calls the System V IPC function shmctl. You'll probably have to say
+
+ use IPC::SysV;
+
+first to get the correct constant definitions. If CMD is IPC_STAT,
+then ARG must be a variable which will hold the returned shmid_ds
+structure. Returns like ioctl: the undefined value for error, "0 but
+true" for zero, or the actual return value otherwise.
+See also IPC::SysV documentation.
=item shmget KEY,SIZE,FLAGS
Calls the System V IPC function shmget. Returns the shared memory
segment id, or the undefined value if there is an error.
+See also IPC::SysV documentation.
=item shmread ID,VAR,POS,SIZE
hold the data read. When writing, if STRING is too long, only SIZE
bytes are used; if STRING is too short, nulls are written to fill out
SIZE bytes. Return TRUE if successful, or FALSE if there is an error.
+See also IPC::SysV documentation.
=item shutdown SOCKET,HOW
Here's a small example showing shared memory usage.
- $IPC_PRIVATE = 0;
- $IPC_RMID = 0;
+ use IPC::SysV qw(IPC_PRIVATE IPC_RMID S_IRWXU S_IRWXG S_IRWXO);
+
$size = 2000;
- $key = shmget($IPC_PRIVATE, $size , 0777 );
- die unless defined $key;
+ $key = shmget(IPC_PRIVATE, $size, S_IRWXU|S_IRWXG|S_IRWXO) || die "$!";
+ print "shm key $key\n";
$message = "Message #1";
- shmwrite($key, $message, 0, 60 ) || die "$!";
- shmread($key,$buff,0,60) || die "$!";
+ shmwrite($key, $message, 0, 60) || die "$!";
+ print "wrote: '$message'\n";
+ shmread($key, $buff, 0, 60) || die "$!";
+ print "read : '$buff'\n";
- print $buff,"\n";
+ # the buffer of shmread is zero-character end-padded.
+ substr($buff, index($buff, "\0")) = '';
+ print "un" unless $buff eq $message;
+ print "swell\n";
- print "deleting $key\n";
- shmctl($key ,$IPC_RMID, 0) || die "$!";
+ print "deleting shm $key\n";
+ shmctl($key, IPC_RMID, 0) || die "$!";
Here's an example of a semaphore:
+ use IPC::SysV qw(IPC_CREAT);
+
$IPC_KEY = 1234;
- $IPC_RMID = 0;
- $IPC_CREATE = 0001000;
- $key = semget($IPC_KEY, $nsems , 0666 | $IPC_CREATE );
- die if !defined($key);
- print "$key\n";
+ $key = semget($IPC_KEY, 10, 0666 | IPC_CREAT ) || die "$!";
+ print "shm key $key\n";
Put this code in a separate file to be run in more than one process.
Call the file F<take>:
semop($key,$opstring) || die "$!";
The SysV IPC code above was written long ago, and it's definitely
-clunky looking. It should at the very least be made to C<use strict>
-and C<require "sys/ipc.ph">. Better yet, check out the IPC::SysV modules
-on CPAN.
+clunky looking. For a more modern look, see the IPC::SysV module
+which is included with Perl starting from Perl 5.005.
=head1 NOTES
@INC = '../lib';
}
-my @define;
-
-BEGIN {
- @define = qw(
- IPC_PRIVATE
- IPC_RMID
- IPC_NOWAIT
- IPC_STAT
- S_IRWXU
- S_IRWXG
- S_IRWXO
- );
-}
-
use Config;
-use vars map { '$' . $_ } @define;
BEGIN {
unless($Config{'d_msgget'} eq 'define' &&
print "1..0\n";
exit;
}
-
- use strict;
-
- my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth}));
- my %done = ();
- my %define = ();
-
- sub process_file {
- my($file,$level) = @_;
-
- return unless defined $file;
-
- my $path = undef;
- my $dir;
- foreach $dir (@incpath) {
- my $tmp = $dir . "/" . $file;
- next unless -r $tmp;
- $path = $tmp;
- last;
- }
-
- return if exists $done{$path};
- $done{$path} = 1;
-
- if(not defined $path and $level == 0) {
- warn "Cannot find '$file'";
- return;
- }
-
- local(*F);
- open(F,$path) or return;
- $level = 1 unless defined $level;
- my $indent = " " x $level;
- print "#$indent open $path\n";
- while(<F>) {
- s#/\*.*(\*/|$)##;
-
- if ( /^#\s*include\s*[<"]([^>"]+)[>"]/ ) {
- print "#${indent} include $1\n";
- process_file($1,$level+1);
- print "#${indent} done include $1\n";
- print "#${indent} back in $path\n";
- }
-
- s/(?:\([^)]*\)\s*)//;
-
- if ( /^#\s*define\s+(\w+)\s+(\w+)/ ) {
- print "#${indent} define $1 $2\n";
- $define{$1} = $2;
- }
- }
- close(F);
- print "#$indent close $path\n";
- }
-
- process_file("sys/sem.h");
- process_file("sys/ipc.h");
- process_file("sys/stat.h");
-
- foreach my $d (@define) {
- while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) {
- $define{$d} = exists $define{$define{$d}}
- ? $define{$define{$d}} : undef;
- }
- unless(defined $define{$d}) {
- print "# $d undefined\n";
- print "1..0\n";
- exit;
- }
- {
- no strict 'refs';
- ${ $d } = eval $define{$d};
- }
- }
}
use strict;
+use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID
+ S_IRWXU S_IRWXG S_IRWXO);
+
print "1..6\n";
-my $msg = msgget($IPC_PRIVATE, $S_IRWXU | $S_IRWXG | $S_IRWXO);
+my $msg = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
# Very first time called after machine is booted value may be 0
die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
print "ok 2\n";
my $data;
-msgctl($msg,$IPC_STAT,$data) or print "not ";
+msgctl($msg,IPC_STAT,$data) or print "not ";
print "ok 3\n";
print "not " unless length($data);
print "ok 4\n";
my $msgbuf;
-msgrcv($msg,$msgbuf,256,0,$IPC_NOWAIT) or print "not ";
+msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not ";
print "ok 5\n";
my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf);
print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext);
print "ok 6\n";
-msgctl($msg,$IPC_RMID,0);
+msgctl($msg,IPC_RMID,0);
$SIG{__DIE__} = 'cleanup';
}
-my @define;
-
-BEGIN {
- @define = qw(
- GETALL
- SETALL
- IPC_PRIVATE
- IPC_CREAT
- IPC_RMID
- IPC_STAT
- S_IRWXU
- S_IRWXG
- S_IRWXO
- );
-}
-
use Config;
-use vars map { '$' . $_ } @define;
BEGIN {
unless($Config{'d_semget'} eq 'define' &&
print "1..0\n";
exit;
}
-
- use strict;
-
- my @incpath = (split(/\s+/, $Config{usrinc}), split(/\s+/ ,$Config{locincpth}));
- my %done = ();
- my %define = ();
-
- sub process_file {
- my($file,$level) = @_;
-
- return unless defined $file;
-
- my $path = undef;
- my $dir;
- foreach $dir (@incpath) {
- my $tmp = $dir . "/" . $file;
- next unless -r $tmp;
- $path = $tmp;
- last;
- }
-
- return if exists $done{$path};
- $done{$path} = 1;
-
- if(not defined $path and $level == 0) {
- warn "Cannot find '$file'";
- return;
- }
-
- local(*F);
- open(F,$path) or return;
- $level = 1 unless defined $level;
- my $indent = " " x $level;
- print "#$indent open $path\n";
- while(<F>) {
- s#/\*.*(\*/|$)##;
-
- if ( /^#\s*include\s*[<"]([^>"]+)[>"]/ ) {
- print "#${indent} include $1\n";
- process_file($1,$level+1);
- print "#${indent} done include $1\n";
- print "#${indent} back in $path\n";
- }
-
- s/(?:\([^)]*\)\s*)//;
-
- if ( /^#\s*define\s+(\w+)\s+(\w+)/ ) {
- print "#${indent} define $1 $2\n";
- $define{$1} = $2;
- }
- }
- close(F);
- print "#$indent close $path\n";
- }
-
- process_file("sys/sem.h");
- process_file("sys/ipc.h");
- process_file("sys/stat.h");
-
- foreach my $d (@define) {
- while(defined($define{$d}) && $define{$d} !~ /^(0x)?\d+$/) {
- $define{$d} = exists $define{$define{$d}}
- ? $define{$define{$d}} : undef;
- }
- unless(defined $define{$d}) {
- print "# $d undefined\n";
- print "1..0\n";
- exit;
- }
- {
- no strict 'refs';
- ${ $d } = eval $define{$d};
- }
- }
}
use strict;
+use IPC::SysV qw(IPC_PRIVATE IPC_CREAT IPC_STAT IPC_RMID
+ GETALL SETALL
+ S_IRWXU S_IRWXG S_IRWXO);
+
print "1..10\n";
-my $sem = semget($IPC_PRIVATE, 10, $S_IRWXU | $S_IRWXG | $S_IRWXO | $IPC_CREAT);
+my $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
# Very first time called after machine is booted value may be 0
die "semget: $!\n" unless defined($sem) && $sem >= 0;
print "ok 1\n";
my $data;
-semctl($sem,0,$IPC_STAT,$data) or print "not ";
+semctl($sem,0,IPC_STAT,$data) or print "not ";
print "ok 2\n";
print "not " unless length($data);
my $nsem = 10;
-semctl($sem,0,$SETALL,pack($template,(0) x $nsem)) or print "not ";
+semctl($sem,0,SETALL,pack($template,(0) x $nsem)) or print "not ";
print "ok 4\n";
$data = "";
-semctl($sem,0,$GETALL,$data) or print "not ";
+semctl($sem,0,GETALL,$data) or print "not ";
print "ok 5\n";
print "not " unless length($data) == length(pack($template,(0) x $nsem));
my $poke = 2;
$data[$poke] = 1;
-semctl($sem,0,$SETALL,pack($template,@data)) or print "not ";
+semctl($sem,0,SETALL,pack($template,@data)) or print "not ";
print "ok 8\n";
$data = "";
-semctl($sem,0,$GETALL,$data) or print "not ";
+semctl($sem,0,GETALL,$data) or print "not ";
print "ok 9\n";
@data = unpack($template,$data);
print "not " unless join("",@data) eq $bdata;
print "ok 10\n";
-sub cleanup { semctl($sem,0,$IPC_RMID,undef) if defined $sem }
+sub cleanup { semctl($sem,0,IPC_RMID,undef) if defined $sem }
cleanup;
projects / p5sagit/p5-mst-13.2.git / commitdiff