ext/IO/t/io_unix.t See if UNIX socket-related methods from IO work
ext/IO/t/io_utf8.t See if perlio opens work
ext/IO/t/io_xs.t See if XSUB methods from IO work
-ext/IPC/SysV/ChangeLog IPC::SysV extension Perl module
+ext/IPC/SysV/Changes IPC::SysV changes
+ext/IPC/SysV/const-c.inc IPC::SysV constants
+ext/IPC/SysV/const-xs.inc IPC::SysV constants
ext/IPC/SysV/hints/cygwin.pl Hint for IPC::SysV for named architecture
ext/IPC/SysV/hints/next_3.pl Hint for IPC::SysV for named architecture
-ext/IPC/SysV/Makefile.PL IPC::SysV extension Perl module
-ext/IPC/SysV/MANIFEST IPC::SysV extension Perl module
-ext/IPC/SysV/Msg.pm IPC::SysV extension Perl module
-ext/IPC/SysV/README IPC::SysV extension Perl module
-ext/IPC/SysV/Semaphore.pm IPC::SysV extension Perl module
-ext/IPC/SysV/SysV.pm IPC::SysV extension Perl module
+ext/IPC/SysV/lib/IPC/Msg.pm IPC::SysV extension Perl module
+ext/IPC/SysV/lib/IPC/Semaphore.pm IPC::SysV extension Perl module
+ext/IPC/SysV/lib/IPC/SharedMem.pm IPC::SysV extension Perl module
+ext/IPC/SysV/lib/IPC/SysV.pm IPC::SysV extension Perl module
+ext/IPC/SysV/Makefile.PL IPC::SysV makefile writer
+ext/IPC/SysV/MANIFEST.SKIP IPC::SysV manifest skip specs
+ext/IPC/SysV/README IPC::SysV README
+ext/IPC/SysV/regen.pl IPC::SysV file regeneration script
ext/IPC/SysV/SysV.xs IPC::SysV extension Perl module
-ext/IPC/SysV/t/ipcsysv.t See if IPC::SysV works
-ext/IPC/SysV/t/msg.t IPC::SysV extension Perl module
-ext/IPC/SysV/t/sem.t IPC::SysV extension Perl module
+ext/IPC/SysV/t/ipcsysv.t IPC::SysV test file
+ext/IPC/SysV/t/pod.t IPC::SysV test file
+ext/IPC/SysV/t/podcov.t IPC::SysV test file
+ext/IPC/SysV/t/msg.t IPC::SysV test file
+ext/IPC/SysV/t/sem.t IPC::SysV test file
+ext/IPC/SysV/t/shm.t IPC::SysV test file
+ext/IPC/SysV/TODO IPC::SysV todo file
+ext/IPC/SysV/typemap IPC::SysV typemap
ext/List/Util/Changes Util extension
ext/List/Util/lib/List/Util.pm List::Util
ext/List/Util/lib/Scalar/Util.pm Scalar::Util
+++ /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
+1.99_07 - 2007-10-22
+
+ * terminate Makefile.PL on MSWin32 with a message that the
+ module cannot be built here
+ * catch SIGSYS locally to skip tests and issue a message
+ on cygwin that cygserver needs to be installed and the
+ CYGWIN environment variable needs to be set
+
+1.99_06 - 2007-10-19
+
+ * handle systems built without SysV IPC support by checking
+ for ENOSYS and skipping the tests (and give a diagnostic
+ message)
+
+1.99_05 - 2007-10-18
+
+ * make sure we can build even without ExtUtils::Constant
+ installed and messed up dependencies
+ * avoid indirect notation in docs
+ * cannot do arithmetics on void pointers
+
+1.99_04 - 2007-10-14
+
+ * add documentation for IPC::SharedMem
+ * add POD coverage test
+ * use less semaphores in t/sem.t to make sure the
+ tests get run on *BSD
+ * rename constant subroutine to _constant, as it's
+ supposed to be private
+
+1.99_03 - 2007-10-13
+
+ * add first IPC::SharedMem implementation
+ * refactor the "stat" pack/unpack code
+
+1.99_02 - 2007-10-13
+
+ * don't plan twice if no semaphores can be allocated
+
+1.99_01 - 2007-10-13
+
+ * dual-life code and tests
+ * backport to 5.004_05
+ * make tests to use Test::More
+ * add shmat(), shmdt(), memread(), memwrite()
+ * improve ftok() interface
+ * fix inconsistencies between SysV.xs and SysV.pm
+ * autogenerate all constants
+ * make checking against ENOSPC more robust
+
+1.04 - 2007-09-27
+
+ Internal version. Integrate all changes up to blead.
+
+ * ChangeLog@1:
+ initial checkin
+
+ * Makefile.PL@2:
+ Change 1407 by gsar@aatma on 1998/07/10 21:35:13
+
+ From: Andy Dougherty <doughera@lafcol.lafayette.edu>
+ Date: Thu, 9 Jul 1998 11:26:03 -0400 (EDT)
+ Subject: [PATCH 5.004_71] Allow static build of IPC::SysV
+ Message-Id: <Pine.SUN.3.96.980709112507.24236B-100000@newton.phys>
+
+ * SysV.xs@5:
+ Change 1443 by gsar@aatma on 1998/07/11 23:08:14
+
+ tweak to get BSDI to build IPC/SysV
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Date: 11 Jul 1998 16:26:44 +0300
+ Message-ID: <oeeww9kecx7.fsf@alpha.hut.fi>
+ Subject: Re: NOT OK: perl5.004_71 on BSDI 3.1
+
+ * SysV.xs@6:
+ Change 1501 by gsar@aatma on 1998/07/15 05:59:49
+
+ apply (reversed) patch
+ From: Peter Wolfe <wolfe@titan.teloseng.com>
+ Date: Tue, 14 Jul 1998 13:01:58 -0700 (PDT)
+ Message-Id: <199807142001.NAA26550@titan.teloseng.com>
+ Subject: NOT_OK: perl 5.00474 on SCO 3.2v5.0.4
+
+ * SysV.xs@7:
+ Change 1578 by gsar@aatma on 1998/07/20 09:38:39
+
+ complete s/foo/PL_foo/ changes (all escaped cases identified with
+ brute force search script). Result builds and passes all tests on
+ Solaris. win32 and PERL_OBJECT are still untested.
+
+ * SysV.xs@8:
+ Change 1760 by gsar@aatma on 1998/08/08 22:18:54
+
+ integrate maint-5.005 changes into mainline
+
+ * Makefile.PL@3:
+ Change 1922 by gsar@aatma on 1998/10/03 03:59:50
+
+ suppress manifypods leak in extensions
+
+ * SysV.xs@9:
+ Change 1904 by gsar@aatma on 1998/10/02 01:53:25
+
+ various Configure and hints updates (prefer drand48() or random()
+ over rand(); add -Dusemultiplicity; enhanced 64-bitness); patch
+ applied modulo SCO hints superceded by later patch
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 29 Sep 1998 00:56:33 +0300 (EET DST)
+ Message-Id: <199809282156.AAA18615@alpha.hut.fi>
+ Subject: [PATCH] 5.005_52: Configure et al:
+
+ * hints@1:
+ no comment
+
+ * hints/next_3.pl@1:
+ Change 1904 by gsar@aatma on 1998/10/02 01:53:25
+
+ various Configure and hints updates (prefer drand48() or random()
+ over rand(); add -Dusemultiplicity; enhanced 64-bitness); patch
+ applied modulo SCO hints superceded by later patch
+ From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Tue, 29 Sep 1998 00:56:33 +0300 (EET DST)
+ Message-Id: <199809282156.AAA18615@alpha.hut.fi>
+ Subject: [PATCH] 5.005_52: Configure et al:
+
+ * Makefile.PL@4:
+ Change 1967 by gsar@aatma on 1998/10/15 02:46:08
+
+ correct bugs exposed in MM_Unix.pm by commenting out Selfloader
+ (MAN3PODS cannot be set to ' '; stray stricture violation)
+
+ * Msg.pm@2:
+ Change 2220 by gsar@aatma on 1998/11/08 21:13:07
+
+ integrate changes#2120,2168,2218 from maint-5.005;
+ add new vtbls; s/\bvtbl_/PL_vtbl_/; remove trailing comma in
+ enum; make regen_headers
+
+ * SysV.xs@10:
+ Change 2145 by gsar@aatma on 1998/10/30 18:46:58
+
+ remaining PL_foo stragglers
+
+ * SysV.xs@11:
+ Change 2695 by gsar@sparc26 on 1999/01/24 07:09:05
+
+ integrate cfgperl changes into mainline
+
+ * SysV.xs@12:
+ Change 2830 by gsar@sparc26 on 1999/02/08 00:19:46
+
+ integrate cfgperl changes into mainline
+
+ * SysV.xs@13:
+ Change 2958 by gsar@sparc26 on 1999/02/16 06:18:27
+
+ integrate change#2852 from maint-5.005; integrate cfgperl contents;
+ elide dups and non-dependents from Changes
+
+ * SysV.xs@14:
+ Change 3217 by gsar@sparc26 on 1999/04/04 01:59:26
+
+ correct places that said newSVpv() when they meant newSVpvn()
+
+ * SysV.xs@15:
+ Change 3518 by gsar@sparc26 on 1999/06/02 04:47:10
+
+ remove _() non-ansism
+
+ * SysV.pm@5:
+ Change 4910 by gsar@rake on 2000/01/27 03:56:48
+
+ various pod nits identified by installhtml (all fixed except
+ unresolved links)
+
+ * hints/cygwin.pl@1:
+ Change 4769 by gsar@auger on 2000/01/07 18:23:16
+
+ cygwin update (from Eric Fifer <EFifer@sanwaint.com>)
+
+ * Makefile.PL@5:
+ Change 6383 by gsar@auger on 2000/07/12 16:00:51
+
+ don't clobber *.orig files on *clean targets
+
+ * Msg.pm@3:
+ Change 5507 by gsar@auger on 2000/03/04 04:27:51
+
+ more whitespace removal (from Michael G Schwern)
+
+ * Msg.pm@4:
+ Change 5822 by gsar@auger on 2000/03/19 07:34:29
+
+ integrate cfgperl contents into mainline
+
+ * Semaphore.pm@2:
+ Change 5507 by gsar@auger on 2000/03/04 04:27:51
+
+ more whitespace removal (from Michael G Schwern)
+
+ * Makefile.PL@6:
+ Change 6398 by gsar@auger on 2000/07/14 08:55:38
+
+ rename totally bletcherous SvLOCK() thingy (doesn't do what the
+ name suggests anyway)
+
+ * Msg.pm@5:
+ Change 9176 by jhi@alpha on 2001/03/16 02:56:04
+
+ Subject: [PATCH] more pod patches
+ From: Michael Stevens <michael@etla.org>
+ Date: Thu, 15 Mar 2001 21:25:18 +0000
+ Message-ID: <20010315212518.A18870@firedrake.org>
+
+ * SysV.xs@16:
+ Change 7614 by jhi@alpha on 2000/11/08 22:42:55
+
+ A missing aTHX_.
+
+ * SysV.xs@17:
+ Change 8837 by jhi@alpha on 2001/02/18 22:16:50
+
+ Subject: [patch] -Wall cleanup round 2
+ From: Doug MacEachern <dougm@covalent.net>
+ Date: Sun, 18 Feb 2001 13:08:04 -0800 (PST)
+ Message-ID: <Pine.LNX.4.21.0102181304520.10021-100000@mako.covalent.net>
+
+ * Semaphore.pm@3, SysV.pm@6:
+ Change 9176 by jhi@alpha on 2001/03/16 02:56:04
+
+ Subject: [PATCH] more pod patches
+ From: Michael Stevens <michael@etla.org>
+ Date: Thu, 15 Mar 2001 21:25:18 +0000
+ Message-ID: <20010315212518.A18870@firedrake.org>
+
+ * t/msg.t@2, t/sem.t@2:
+ Change 10684 by jhi@alpha on 2001/06/18 12:25:55
+
+ Guard the SysV IPC tests against being invoked in
+ SysV-IPC-less places.
+
+ * Semaphore.pm@4:
+ Change 10839 by jhi@alpha on 2001/06/22 21:15:32
+
+ The packs must be done in native shorts, fix from Mark P. Lutz.
+
+ * Semaphore.pm@5:
+ Change 10980 by jhi@alpha on 2001/06/27 11:45:29
+
+ "lose the it's", from Abhijit Menon-Sen.
+ ("It's" not searched, pods not searched.)
+
+ * SysV.xs@18:
+ Change 11012 by jhi@alpha on 2001/06/28 21:36:36
+
+ Cannot DIE() in a void function,
+ from Richard Hatch <rhatch@austin.ibm.com>.
+
+ * t/msg.t@3, t/sem.t@3:
+ Change 10712 by jhi@alpha on 2001/06/19 10:34:35
+
+ One test lost in the big shuffle restored.
+
+ * Msg.pm@6:
+ Change 11016 by jhi@alpha on 2001/06/29 03:38:56
+
+ Bump up the VERSIONs of modules that have changed since 5.6.0,
+ the modules found using a script written by Larry Schatzer Jr.
+
+ * Msg.pm@7:
+ Change 11047 by jhi@alpha on 2001/06/30 16:03:40
+
+ More VERSION tuning: to avoid unnecessary Perl upgrades
+ by CPAN.pm, use rather _00.
+
+ * Semaphore.pm@6, SysV.pm@7:
+ Change 11016 by jhi@alpha on 2001/06/29 03:38:56
+
+ Bump up the VERSIONs of modules that have changed since 5.6.0,
+ the modules found using a script written by Larry Schatzer Jr.
+
+ * Semaphore.pm@7:
+ Change 11047 by jhi@alpha on 2001/06/30 16:03:40
+
+ More VERSION tuning: to avoid unnecessary Perl upgrades
+ by CPAN.pm, use rather _00.
+
+ * Semaphore.pm@8:
+ Change 14864 by jhi@alpha on 2002/02/25 13:51:32
+
+ Typo corrections from John P. Linderman.
+
+ * SysV.pm@8:
+ Change 11047 by jhi@alpha on 2001/06/30 16:03:40
+
+ More VERSION tuning: to avoid unnecessary Perl upgrades
+ by CPAN.pm, use rather _00.
+
+ * SysV.xs@19:
+ Change 11051 by jhi@alpha on 2001/06/30 20:59:57
+
+ Code cleanup based on turning off the -woffs in IRIX.
+ Not all of the gripes cleaned up (hairy code in hv.c and
+ regcomp.c; unused newsp, gimme, and optype from cop.h macros;
+ unused 'key' arguments in ?DBM_File.xs) (and the -woffs left
+ to the IRIX hints)
+
+ * Msg.pm@8, Semaphore.pm@9, SysV.pm@9:
+ Change 16822 by jhi@alpha on 2002/05/27 20:42:47
+
+ Subject: Re: [PATCH] Version tango
+ From: sthoenna@efn.org (Yitzchak Scott-Thoennes)
+ Date: Mon, 27 May 2002 13:20:56 -0700
+ Message-ID: <oUp88gzkgy+T092yn@efn.org>
+
+ * Msg.pm@9:
+ Change 18811 by hv@hv-crypt.org on 2003/03/02 22:30:50
+
+ Subject: [perl #21289] [Fwd: IPC::Msg bug report]
+ From: Edmund Bacon (via RT) <perlbug-followup@perl.org>
+ Date: 18 Feb 2003 21:05:15 -0000
+ Message-Id: <rt-21289-52384.13.2700974026643@bugs6.perl.org>
+
+ * Semaphore.pm@10:
+ Change 17825 by hv@hv-crypt.org on 2002/09/04 10:53:59
+
+ Subject: Re: Possible bug in IPC/Semaphore.pm [PATCH]
+ From: "John P. Linderman" <jpl@research.att.com>
+ Date: Wed, 28 Aug 2002 08:04:29 -0400 (EDT)
+ Message-Id: <200208271900.PAA98096@raptor.research.att.com>
+
+ * t/msg.t@4:
+ Change 19358 by jhi@kosh on 2003/04/28 08:27:15
+
+ SysV msg queues can be something hanging (witnessed in IRIX),
+ so let's use IPC_NOWAIT.
+
+ * MANIFEST@3, t/ipcsysv.t@1:
+ Change 20269 by jhi@kosh on 2003/07/28 15:07:22
+
+ No more ext/*/*.t, move them all to ext/*/t.
+
+ * Msg.pm@10:
+ Change 20686 by jhi@kosh on 2003/08/13 18:42:50
+
+ Subject: Re: script wanted
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Wed, 13 Aug 2003 20:46:09 +0100
+ Message-ID: <20030813204609.G20130@plum.flirble.org>
+
+ * Msg.pm@11:
+ Change 20687 by jhi@kosh on 2003/08/13 18:53:15
+
+ Alpha version numbers noticed by Schwern.
+ (These hacks are no more needed since the PAUSE indexer no
+ more indexes the insides of Perl distributions, says Andreas.)
+
+ * Semaphore.pm@11:
+ Change 20686 by jhi@kosh on 2003/08/13 18:42:50
+
+ Subject: Re: script wanted
+ From: Nicholas Clark <nick@ccl4.org>
+ Date: Wed, 13 Aug 2003 20:46:09 +0100
+ Message-ID: <20030813204609.G20130@plum.flirble.org>
+
+ * t/msg.t@5, t/sem.t@4:
+ Change 20490 by jhi@kosh on 2003/08/05 06:28:06
+
+ [perl #23216] ext/IPC/SysV/t/sem.t don't remove semaphore on NetBSD sparc
+ Try to remove the created message queues and semaphores
+ even in the case of failures.
+
+ * Semaphore.pm@12, SysV.pm@10:
+ Change 20687 by jhi@kosh on 2003/08/13 18:53:15
+
+ Alpha version numbers noticed by Schwern.
+ (These hacks are no more needed since the PAUSE indexer no
+ more indexes the insides of Perl distributions, says Andreas.)
+
+ * hints/cygwin.pl@2:
+ Change 22358 by rgs@rgs-home on 2004/02/22 21:49:47
+
+ Subject: initial patch for cygwin IPC via cygserver
+ From: Yitzchak Scott-Thoennes <sthoenna@efn.org>
+ Date: Thu, 19 Feb 2004 09:01:13 -0800
+ Message-ID: <20040219170113.GA2792@efn.org>
+
+ * t/ipcsysv.t@2, t/sem.t@5:
+ Change 28131 by nicholas@nicholas-saigo on 2006/05/08 21:11:37
+
+ Subject: [PATCH] ext/IPC/SysV/t/ipcsysv.t using test.pl
+ From: David Landgren <david@landgren.net>
+ Message-ID: <445B694B.8060901@landgren.net>
+ Date: Fri, 05 May 2006 17:03:39 +0200
+
+ Subject: Re: [PATCH] ext/IPC/SysV/t/sem.t using test.pl
+ From: David Landgren <david@landgren.net>
+ Message-ID: <445B75EF.3000100@landgren.net>
+ Date: Fri, 05 May 2006 17:57:35 +0200
+
+ * Msg.pm@12, Semaphore.pm@13, SysV.pm@11:
+ Change 28313 by stevep@stevep-kirk on 2006/05/26 15:03:12
+
+ Subject: [PATCH] SysV IPC
+ From: Jarkko Hietaniemi <jhietaniemi@gmail.com>
+ Date: Thu, 25 May 2006 18:49:33 +0300
+ Message-ID: <4475D20D.9010600@gmail.com>
+
+ * t/sem.t@6:
+ Change 28138 by rgs@stencil on 2006/05/09 13:45:43
+
+ Subject: Re: [PATCH] ext/IPC/SysV/t/ipcsysv.t using test.pl
+ From: David Landgren <david@landgren.net>
+ Date: Tue, 09 May 2006 13:03:22 +0200
+ Message-ID: <446076FA.6010409@landgren.net>
+
+ * SysV.xs@20:
+ Change 29977 by nicholas@entropy on 2007/01/25 20:57:56
+
+ The last parameter to gv_stashpv/gv_stashpvn/gv_stashsv is a bitmask
+ of flags, not a boolean, so correct the documenation and callers.
+
+ * SysV.xs@21:
+ Change 31702 by ams@penne on 2007/08/12 14:10:10
+
+ Use sysconf/getpagesize/page.h to determine page size on Linux,
+ in that order.
+
+ Subject: Re: [PATCH] Various Gentoo Patches
+ From: Marcus Holland-Moritz <mhx-perl@gmx.net>
+ Date: Sun, 12 Aug 2007 13:16:52 +0200
+ Message-Id: <20070812131652.16ca5444@r2d2>
+
+ * t/ipcsysv.t@3:
+ Change 31967 by rgs@stcosmo on 2007/09/25 13:16:19
+
+ Subject: Re: [perl #45513] Test failures on amd64-freebsd 6.2
+ From: Slaven Rezic <slaven@rezic.de>
+ Date: 19 Sep 2007 21:56:00 +0200
+ Message-ID: <87abri1lbj.fsf@biokovo-amd64.herceg.de>
+
+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/ipcsysv.t
-t/msg.t
-t/sem.t
-ChangeLog
--- /dev/null
+^Makefile$
+~$
+\.old(?:\..*)?$
+\.swp$
+\.o$
+\.bs$
+\.bak$
+\.orig$
+\.cache\.cm$
+^blib
+^pm_to_blib
+^backup
+^testing
+IPC-SysV.*\.tar\.gz$
-# This -*- perl -*- script makes the Makefile
-# $Id: Makefile.PL,v 1.3 1997/03/04 09:21:12 gbarr Exp $
+################################################################################
+#
+# $Revision: 14 $
+# $Author: mhx $
+# $Date: 2007/10/22 13:14:21 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
-require 5.002;
+require 5.004_05;
+
+use strict;
use ExtUtils::MakeMaker;
+unless ($ENV{'PERL_CORE'}) {
+ $ENV{'PERL_CORE'} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV;
+}
+
+if ($^O eq 'MSWin32') {
+ my $msg = "The IPC::SysV module cannot be built on the $^O platform.";
+ my $str = '*' x length $msg;
+ die "\n$str\n$msg\n$str\n\n";
+}
+
+WriteMakefile(
+ NAME => 'IPC::SysV',
+ VERSION_FROM => 'lib/IPC/SysV.pm',
+ PREREQ_PM => {
+ 'Test::More' => 0.45,
+ },
+ CONFIGURE => \&configure,
+);
+
+sub configure
+{
+ my @moreopts;
+ my %depend;
+
+ if (eval $ExtUtils::MakeMaker::VERSION >= 6) {
+ push @moreopts, AUTHOR => 'Marcus Holland-Moritz <mhx@cpan.org>',
+ ABSTRACT_FROM => 'lib/IPC/SysV.pm';
+ }
+
+ if (eval $ExtUtils::MakeMaker::VERSION >= 6.30_01) {
+ print "Setting license tag...\n";
+ push @moreopts, LICENSE => 'perl';
+ }
+
+ if ($ENV{'PERL_CORE'}) {
+ # Pods will be built by installman.
+ push @moreopts, MAN3PODS => {};
+ }
+ else {
+ # IPC::SysV is in the core since 5.005
+ push @moreopts, INSTALLDIRS => ($] >= 5.005 ? 'perl' : 'site');
+ }
+
+ $depend{'SysV.xs'} = 'const-c.inc const-xs.inc';
+
+ return {
+ depend => \%depend,
+ @moreopts
+ };
+}
+
+
#--- MY package
sub MY::libscan
{
- my($self,$path) = @_;
-
- return ''
- if($path =~ m:/(RCS|CVS|SCCS)/: ||
- $path =~ m:[~%]$: ||
- $path =~ m:\.(orig|rej)$:
- );
-
+ my($self, $path) = @_;
+ return '' if $path =~ m! /(RCS|CVS|SCCS)/ | [~%]$ | \.(orig|rej)$ !x;
$path;
}
-WriteMakefile(
- VERSION_FROM => "SysV.pm",
- NAME => "IPC::SysV",
- MAN3PODS => {}, # Pods will be built by installman.
-
- 'dist' => {COMPRESS => 'gzip -9f',
- SUFFIX => 'gz',
- DIST_DEFAULT => 'all tardist',
- },
-
- 'clean' => {FILES => join(" ",
- map { "$_ */$_ */*/$_" }
- qw(*% *.html *.b[ac]k *.old))
- },
- 'macro' => { INSTALLDIRS => 'perl' },
-);
+sub MY::postamble
+{
+ package MY;
+ my $post = shift->SUPER::postamble(@_);
+ $post .= <<'POSTAMBLE';
+
+purge_all: realclean
+ @$(RM_F) const-c.inc const-xs.inc
+
+regen:
+ $(PERL) -I$(PERL_ARCHLIB) -I$(PERL_LIB) regen.pl
+
+const-c.inc: lib/IPC/SysV.pm regen.pl
+ @$(MAKE) regen
+
+const-xs.inc: lib/IPC/SysV.pm regen.pl
+ @$(MAKE) regen
+
+POSTAMBLE
+ return $post;
+}
+
-Copyright (c) 1997 Graham Barr <gbarr@pobox.com>. All rights reserved.
-This package is free software; you can redistribute it and/or
+Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz.
+
+Version 1.x, Copyright (c) 1997, Graham Barr.
+
+This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
The SysV-IPC contains three packages
+++ /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 $XS_VERSION);
-use Carp;
-use Config;
-
-require Exporter;
-@ISA = qw(Exporter);
-
-$VERSION = "1.05";
-$XS_VERSION = $VERSION;
-$VERSION = eval $VERSION;
-
-@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__, $XS_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. Common ones include
-
- IPC_CREATE IPC_EXCL IPC_NOWAIT IPC_PRIVATE IPC_RMID IPC_SET IPC_STAT
- GETVAL SETVAL GETPID GETNCNT GETZCNT GETALL SETALL
- SEM_A SEM_R SEM_UNDO
- SHM_RDONLY SHM_RND SHMLBA
-
-and auxiliary ones
-
- S_IRUSR S_IWUSR S_IRWXU
- S_IRGRP S_IWGRP S_IRWXG
- S_IROTH S_IWOTH S_IRWXO
-
-but your system might have more.
-
-=over 4
-
-=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>
-
-=back
-
-=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
-
+/*******************************************************************************
+*
+* $Revision: 30 $
+* $Author: mhx $
+* $Date: 2007/10/18 19:57:29 +0200 $
+*
+********************************************************************************
+*
+* Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+* Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+*
+* This program is free software; you can redistribute it and/or
+* modify it under the same terms as Perl itself.
+*
+*******************************************************************************/
+
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
+#define NEED_sv_2pv_flags
+#define NEED_sv_pvn_force_flags
+#include "ppport.h"
+
#include <sys/types.h>
+
#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
-#ifndef HAS_SEM
-# include <sys/ipc.h>
-#endif
-# ifdef HAS_MSG
-# include <sys/msg.h>
-# endif
-# ifdef HAS_SHM
-# if defined(PERL_SCO) || defined(PERL_ISC)
-# include <sys/sysmacros.h> /* SHMLBA */
-# endif
-# include <sys/shm.h>
-# ifndef HAS_SHMAT_PROTOTYPE
- extern Shmat_t shmat (int, char *, int);
-# endif
-# if defined(HAS_SYSCONF) && defined(_SC_PAGESIZE)
-# undef SHMLBA /* not static: determined at boot time */
-# define SHMLBA sysconf(_SC_PAGESIZE)
-# elif defined(HAS_GETPAGESIZE)
-# undef SHMLBA /* not static: determined at boot time */
-# define SHMLBA getpagesize()
-# elif defined(__linux__)
-# include <asm/page.h>
-# endif
-# endif
+# ifndef HAS_SEM
+# include <sys/ipc.h>
+# endif
+# ifdef HAS_MSG
+# include <sys/msg.h>
+# endif
+# ifdef HAS_SHM
+# if defined(PERL_SCO) || defined(PERL_ISC)
+# include <sys/sysmacros.h> /* SHMLBA */
+# endif
+# include <sys/shm.h>
+# ifndef HAS_SHMAT_PROTOTYPE
+ extern Shmat_t shmat(int, char *, int);
+# endif
+# if defined(HAS_SYSCONF) && defined(_SC_PAGESIZE)
+# undef SHMLBA /* not static: determined at boot time */
+# define SHMLBA sysconf(_SC_PAGESIZE)
+# elif defined(HAS_GETPAGESIZE)
+# undef SHMLBA /* not static: determined at boot time */
+# define SHMLBA getpagesize()
+# endif
+# endif
#endif
/* Required to get 'struct pte' for SHMLBA on ULTRIX. */
* Ugly. More beautiful solutions welcome.
* Shouting at BSDI sounds quite beautiful. */
#ifdef __bsdi__
-# include <vm/vm_param.h> /* move upwards under HAS_SHM? */
+# include <vm/vm_param.h> /* move upwards under HAS_SHM? */
#endif
#ifndef S_IRWXU
-# ifdef S_IRUSR
-# define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR)
-# define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP)
-# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH)
-# else
-# define S_IRWXU 0700
-# define S_IRWXG 0070
-# define S_IRWXO 0007
-# endif
+# ifdef S_IRUSR
+# define S_IRWXU (S_IRUSR|S_IWUSR|S_IXUSR)
+# define S_IRWXG (S_IRGRP|S_IWGRP|S_IXGRP)
+# define S_IRWXO (S_IROTH|S_IWOTH|S_IXOTH)
+# else
+# define S_IRWXU 0700
+# define S_IRWXG 0070
+# define S_IRWXO 0007
+# endif
#endif
+#define AV_FETCH_IV(ident, av, index) \
+ STMT_START { \
+ SV **svp; \
+ if ((svp = av_fetch((av), (index), FALSE)) != NULL) \
+ ident = SvIV(*svp); \
+ } STMT_END
+
+#define AV_STORE_IV(ident, av, index) \
+ av_store((av), (index), newSViv(ident))
+
+static const char *s_fmt_not_isa = "Method %s not called a %s object";
+static const char *s_bad_length = "Bad arg length for %s, length is %d, should be %d";
+static const char *s_sysv_unimpl PERL_UNUSED_DECL
+ = "System V %sxxx is not implemented on this machine";
+
+static const char *s_pkg_msg = "IPC::Msg::stat";
+static const char *s_pkg_sem = "IPC::Semaphore::stat";
+static const char *s_pkg_shm = "IPC::SharedMem::stat";
+
+static void *sv2addr(SV *sv)
+{
+ if (SvPOK(sv) && SvCUR(sv) == sizeof(void *))
+ {
+ return *((void **) SvPVX(sv));
+ }
+
+ croak("invalid address value");
+
+ return 0;
+}
+
+static void assert_sv_isa(SV *sv, const char *name, const char *method)
+{
+ if (!sv_isa(sv, name))
+ {
+ croak(s_fmt_not_isa, method, name);
+ }
+}
+
+static void assert_data_length(const char *name, int got, int expected)
+{
+ if (got != expected)
+ {
+ croak(s_bad_length, name, got, expected);
+ }
+}
+
+#include "const-c.inc"
+
+
MODULE=IPC::SysV PACKAGE=IPC::Msg::stat
PROTOTYPES: ENABLE
pack(obj)
SV * obj
PPCODE:
-{
+ {
#ifdef HAS_MSG
- SV *sv;
+ AV *list = (AV*) SvRV(obj);
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(newSVpvn((char *)&ds,sizeof(ds)));
+ assert_sv_isa(obj, s_pkg_msg, "pack");
+ AV_FETCH_IV(ds.msg_perm.uid , list, 0);
+ AV_FETCH_IV(ds.msg_perm.gid , list, 1);
+ AV_FETCH_IV(ds.msg_perm.cuid, list, 2);
+ AV_FETCH_IV(ds.msg_perm.cgid, list, 3);
+ AV_FETCH_IV(ds.msg_perm.mode, list, 4);
+ AV_FETCH_IV(ds.msg_qnum , list, 5);
+ AV_FETCH_IV(ds.msg_qbytes , list, 6);
+ AV_FETCH_IV(ds.msg_lspid , list, 7);
+ AV_FETCH_IV(ds.msg_lrpid , list, 8);
+ AV_FETCH_IV(ds.msg_stime , list, 9);
+ AV_FETCH_IV(ds.msg_rtime , list, 10);
+ AV_FETCH_IV(ds.msg_ctime , list, 11);
+ ST(0) = sv_2mortal(newSVpvn((char *) &ds, sizeof(ds)));
XSRETURN(1);
#else
- croak("System V msgxxx is not implemented on this machine");
+ croak(s_sysv_unimpl, "msg");
#endif
-}
+ }
void
-unpack(obj,buf)
+unpack(obj, ds)
SV * obj
- SV * buf
+ SV * ds
PPCODE:
-{
+ {
#ifdef HAS_MSG
+ AV *list = (AV*) SvRV(obj);
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);
+ const struct msqid_ds *data = (struct msqid_ds *) SvPV_const(ds, len);
+ assert_sv_isa(obj, s_pkg_msg, "unpack");
+ assert_data_length(s_pkg_msg, len, sizeof(*data));
+ AV_STORE_IV(data->msg_perm.uid , list, 0);
+ AV_STORE_IV(data->msg_perm.gid , list, 1);
+ AV_STORE_IV(data->msg_perm.cuid, list, 2);
+ AV_STORE_IV(data->msg_perm.cgid, list, 3);
+ AV_STORE_IV(data->msg_perm.mode, list, 4);
+ AV_STORE_IV(data->msg_qnum , list, 5);
+ AV_STORE_IV(data->msg_qbytes , list, 6);
+ AV_STORE_IV(data->msg_lspid , list, 7);
+ AV_STORE_IV(data->msg_lrpid , list, 8);
+ AV_STORE_IV(data->msg_stime , list, 9);
+ AV_STORE_IV(data->msg_rtime , list, 10);
+ AV_STORE_IV(data->msg_ctime , list, 11);
XSRETURN(1);
#else
- croak("System V msgxxx is not implemented on this machine");
+ croak(s_sysv_unimpl, "msg");
#endif
-}
+ }
+
MODULE=IPC::SysV PACKAGE=IPC::Semaphore::stat
+PROTOTYPES: ENABLE
+
void
-unpack(obj,ds)
+pack(obj)
+ SV * obj
+PPCODE:
+ {
+#ifdef HAS_SEM
+ AV *list = (AV*) SvRV(obj);
+ struct semid_ds ds;
+ assert_sv_isa(obj, s_pkg_sem, "pack");
+ AV_FETCH_IV(ds.sem_perm.uid , list, 0);
+ AV_FETCH_IV(ds.sem_perm.gid , list, 1);
+ AV_FETCH_IV(ds.sem_perm.cuid, list, 2);
+ AV_FETCH_IV(ds.sem_perm.cgid, list, 3);
+ AV_FETCH_IV(ds.sem_perm.mode, list, 4);
+ AV_FETCH_IV(ds.sem_ctime , list, 5);
+ AV_FETCH_IV(ds.sem_otime , list, 6);
+ AV_FETCH_IV(ds.sem_nsems , list, 7);
+ ST(0) = sv_2mortal(newSVpvn((char *) &ds, sizeof(ds)));
+ XSRETURN(1);
+#else
+ croak(s_sysv_unimpl, "sem");
+#endif
+ }
+
+void
+unpack(obj, ds)
SV * obj
SV * ds
PPCODE:
-{
+ {
#ifdef HAS_SEM
+ AV *list = (AV*) SvRV(obj);
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);
+ const struct semid_ds *data = (struct semid_ds *) SvPV_const(ds, len);
+ assert_sv_isa(obj, s_pkg_sem, "unpack");
+ assert_data_length(s_pkg_sem, len, sizeof(*data));
+ AV_STORE_IV(data->sem_perm.uid , list, 0);
+ AV_STORE_IV(data->sem_perm.gid , list, 1);
+ AV_STORE_IV(data->sem_perm.cuid, list, 2);
+ AV_STORE_IV(data->sem_perm.cgid, list, 3);
+ AV_STORE_IV(data->sem_perm.mode, list, 4);
+ AV_STORE_IV(data->sem_ctime , list, 5);
+ AV_STORE_IV(data->sem_otime , list, 6);
+ AV_STORE_IV(data->sem_nsems , list, 7);
XSRETURN(1);
#else
- croak("System V semxxx is not implemented on this machine");
+ croak(s_sysv_unimpl, "sem");
#endif
-}
+ }
+
+
+MODULE=IPC::SysV PACKAGE=IPC::SharedMem::stat
+
+PROTOTYPES: ENABLE
void
pack(obj)
SV * obj
PPCODE:
-{
-#ifdef HAS_SEM
- SV **sv_ptr;
- 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_ptr)
- ds.sem_perm.uid = SvIV(*sv_ptr);
- if((sv_ptr = av_fetch(list,1,TRUE)) && *sv_ptr)
- ds.sem_perm.gid = SvIV(*sv_ptr);
- if((sv_ptr = av_fetch(list,2,TRUE)) && *sv_ptr)
- ds.sem_perm.cuid = SvIV(*sv_ptr);
- if((sv_ptr = av_fetch(list,3,TRUE)) && *sv_ptr)
- ds.sem_perm.cgid = SvIV(*sv_ptr);
- if((sv_ptr = av_fetch(list,4,TRUE)) && *sv_ptr)
- ds.sem_perm.mode = SvIV(*sv_ptr);
- if((sv_ptr = av_fetch(list,5,TRUE)) && *sv_ptr)
- ds.sem_ctime = SvIV(*sv_ptr);
- if((sv_ptr = av_fetch(list,6,TRUE)) && *sv_ptr)
- ds.sem_otime = SvIV(*sv_ptr);
- if((sv_ptr = av_fetch(list,7,TRUE)) && *sv_ptr)
- ds.sem_nsems = SvIV(*sv_ptr);
- ST(0) = sv_2mortal(newSVpvn((char *)&ds,sizeof(ds)));
+ {
+#ifdef HAS_SHM
+ AV *list = (AV*) SvRV(obj);
+ struct shmid_ds ds;
+ assert_sv_isa(obj, s_pkg_shm, "pack");
+ AV_FETCH_IV(ds.shm_perm.uid , list, 0);
+ AV_FETCH_IV(ds.shm_perm.gid , list, 1);
+ AV_FETCH_IV(ds.shm_perm.cuid, list, 2);
+ AV_FETCH_IV(ds.shm_perm.cgid, list, 3);
+ AV_FETCH_IV(ds.shm_perm.mode, list, 4);
+ AV_FETCH_IV(ds.shm_segsz , list, 5);
+ AV_FETCH_IV(ds.shm_lpid , list, 6);
+ AV_FETCH_IV(ds.shm_cpid , list, 7);
+ AV_FETCH_IV(ds.shm_nattch , list, 8);
+ AV_FETCH_IV(ds.shm_atime , list, 9);
+ AV_FETCH_IV(ds.shm_dtime , list, 10);
+ AV_FETCH_IV(ds.shm_ctime , list, 11);
+ ST(0) = sv_2mortal(newSVpvn((char *) &ds, sizeof(ds)));
XSRETURN(1);
#else
- croak("System V semxxx is not implemented on this machine");
+ croak(s_sysv_unimpl, "shm");
#endif
-}
+ }
+
+void
+unpack(obj, ds)
+ SV * obj
+ SV * ds
+PPCODE:
+ {
+#ifdef HAS_SHM
+ AV *list = (AV*) SvRV(obj);
+ STRLEN len;
+ const struct shmid_ds *data = (struct shmid_ds *) SvPV_const(ds, len);
+ assert_sv_isa(obj, s_pkg_shm, "unpack");
+ assert_data_length(s_pkg_shm, len, sizeof(*data));
+ AV_STORE_IV(data->shm_perm.uid , list, 0);
+ AV_STORE_IV(data->shm_perm.gid , list, 1);
+ AV_STORE_IV(data->shm_perm.cuid, list, 2);
+ AV_STORE_IV(data->shm_perm.cgid, list, 3);
+ AV_STORE_IV(data->shm_perm.mode, list, 4);
+ AV_STORE_IV(data->shm_segsz , list, 5);
+ AV_STORE_IV(data->shm_lpid , list, 6);
+ AV_STORE_IV(data->shm_cpid , list, 7);
+ AV_STORE_IV(data->shm_nattch , list, 8);
+ AV_STORE_IV(data->shm_atime , list, 9);
+ AV_STORE_IV(data->shm_dtime , list, 10);
+ AV_STORE_IV(data->shm_ctime , list, 11);
+ XSRETURN(1);
+#else
+ croak(s_sysv_unimpl, "shm");
+#endif
+ }
+
MODULE=IPC::SysV PACKAGE=IPC::SysV
+PROTOTYPES: ENABLE
+
void
-ftok(path, id)
- char * path
- int id
- CODE:
+ftok(path, id = &PL_sv_undef)
+ const char *path
+ SV *id
+ PREINIT:
+ int proj_id = 1;
+ key_t k;
+ CODE:
#if defined(HAS_SEM) || defined(HAS_SHM)
- key_t k = ftok(path, id);
- ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k));
+ if (SvOK(id))
+ {
+ if (SvIOK(id))
+ {
+ proj_id = (int) SvIVX(id);
+ }
+ else if (SvPOK(id) && SvCUR(id) == sizeof(char))
+ {
+ proj_id = (int) *SvPVX(id);
+ }
+ else
+ {
+ croak("invalid project id");
+ }
+ }
+
+ k = ftok(path, proj_id);
+ ST(0) = k == (key_t) -1 ? &PL_sv_undef : sv_2mortal(newSViv(k));
+ XSRETURN(1);
#else
- Perl_die(aTHX_ PL_no_func, "ftok"); return;
+ Perl_die(aTHX_ PL_no_func, "ftok"); return;
#endif
void
-SHMLBA()
- CODE:
-#ifdef SHMLBA
- ST(0) = sv_2mortal(newSViv(SHMLBA));
+memread(addr, sv, pos, size)
+ SV *addr
+ SV *sv
+ int pos
+ int size
+ CODE:
+ char *caddr = sv2addr(addr);
+ char *dst;
+ if (!SvOK(sv))
+ {
+ sv_setpvn(sv, "", 0);
+ }
+ SvPV_force_nolen(sv);
+ dst = SvGROW(sv, (STRLEN) size + 1);
+ Copy(caddr + pos, dst, size, char);
+ SvCUR_set(sv, size);
+ *SvEND(sv) = '\0';
+ SvSETMAGIC(sv);
+#ifndef INCOMPLETE_TAINTS
+ /* who knows who has been playing with this memory? */
+ SvTAINTED_on(sv);
+#endif
+ XSRETURN_YES;
+
+void
+memwrite(addr, sv, pos, size)
+ SV *addr
+ SV *sv
+ int pos
+ int size
+ CODE:
+ char *caddr = sv2addr(addr);
+ STRLEN len;
+ const char *src = SvPV_const(sv, len);
+ int n = ((int) len > size) ? size : (int) len;
+ Copy(src, caddr + pos, n, char);
+ if (n < size)
+ {
+ memzero(caddr + pos + n, size - n);
+ }
+ XSRETURN_YES;
+
+void
+shmat(id, addr, flag)
+ int id
+ SV *addr
+ int flag
+ CODE:
+#ifdef HAS_SHM
+ void *caddr = SvOK(addr) ? sv2addr(addr) : NULL;
+ void *shm = (void *) shmat(id, caddr, flag);
+ ST(0) = shm == (void *) -1 ? &PL_sv_undef
+ : sv_2mortal(newSVpvn((char *) &shm, sizeof(void *)));
+ XSRETURN(1);
#else
- croak("SHMLBA is not defined on this architecture");
+ Perl_die(aTHX_ PL_no_func, "shmat"); return;
#endif
-BOOT:
-{
- HV *stash = gv_stashpvn("IPC::SysV", 9, GV_ADD);
- /*
- * constant subs for IPC::SysV
- */
- struct { const 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_GETACL},
-#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},
+void
+shmdt(addr)
+ SV *addr
+ CODE:
+#ifdef HAS_SHM
+ void *caddr = sv2addr(addr);
+ int rv = shmdt(caddr);
+ ST(0) = rv == -1 ? &PL_sv_undef : sv_2mortal(newSViv(rv));
+ XSRETURN(1);
+#else
+ Perl_die(aTHX_ PL_no_func, "shmdt"); return;
#endif
- {Nullch,0}};
- const char *name;
- int i;
- for(i = 0 ; (name = IPC__SysV__const[i].n) ; i++) {
- newCONSTSUB(stash,name, newSViv(IPC__SysV__const[i].v));
- }
-}
+INCLUDE: const-xs.inc
--- /dev/null
+* try to port below 5.004_05 ?
+* test with more platforms
--- /dev/null
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant_5 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ IPC_M IPC_R IPC_W MSG_R MSG_W SEM_A SEM_R SHM_A SHM_R SHM_W */
+ /* Offset 1 gives the best switch position. */
+ switch (name[1]) {
+ case 'E':
+ if (memEQ(name, "SEM_A", 5)) {
+ /* ^ */
+#ifdef SEM_A
+ *iv_return = SEM_A;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SEM_R", 5)) {
+ /* ^ */
+#ifdef SEM_R
+ *iv_return = SEM_R;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'H':
+ if (memEQ(name, "SHM_A", 5)) {
+ /* ^ */
+#ifdef SHM_A
+ *iv_return = SHM_A;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_R", 5)) {
+ /* ^ */
+#ifdef SHM_R
+ *iv_return = SHM_R;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_W", 5)) {
+ /* ^ */
+#ifdef SHM_W
+ *iv_return = SHM_W;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "IPC_M", 5)) {
+ /* ^ */
+#ifdef IPC_M
+ *iv_return = IPC_M;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "IPC_R", 5)) {
+ /* ^ */
+#ifdef IPC_R
+ *iv_return = IPC_R;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "IPC_W", 5)) {
+ /* ^ */
+#ifdef IPC_W
+ *iv_return = IPC_W;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "MSG_R", 5)) {
+ /* ^ */
+#ifdef MSG_R
+ *iv_return = MSG_R;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "MSG_W", 5)) {
+ /* ^ */
+#ifdef MSG_W
+ *iv_return = MSG_W;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_6 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ ENOSPC ENOSYS GETALL GETPID GETVAL SETALL SETVAL SHMLBA */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'A':
+ if (memEQ(name, "GETVAL", 6)) {
+ /* ^ */
+#ifdef GETVAL
+ *iv_return = GETVAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SETVAL", 6)) {
+ /* ^ */
+#ifdef SETVAL
+ *iv_return = SETVAL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'B':
+ if (memEQ(name, "SHMLBA", 6)) {
+ /* ^ */
+#ifdef SHMLBA
+ *iv_return = SHMLBA;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "GETPID", 6)) {
+ /* ^ */
+#ifdef GETPID
+ *iv_return = GETPID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "GETALL", 6)) {
+ /* ^ */
+#ifdef GETALL
+ *iv_return = GETALL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SETALL", 6)) {
+ /* ^ */
+#ifdef SETALL
+ *iv_return = SETALL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'P':
+ if (memEQ(name, "ENOSPC", 6)) {
+ /* ^ */
+#ifdef ENOSPC
+ *iv_return = ENOSPC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Y':
+ if (memEQ(name, "ENOSYS", 6)) {
+ /* ^ */
+#ifdef ENOSYS
+ *iv_return = ENOSYS;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_7 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ GETNCNT GETZCNT IPC_SET SEM_ERR SHM_MAP SHM_RND S_IRGRP S_IROTH S_IRUSR
+ S_IRWXG S_IRWXO S_IRWXU S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'C':
+ if (memEQ(name, "GETNCNT", 7)) {
+ /* ^ */
+#ifdef GETNCNT
+ *iv_return = GETNCNT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "GETZCNT", 7)) {
+ /* ^ */
+#ifdef GETZCNT
+ *iv_return = GETZCNT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "SEM_ERR", 7)) {
+ /* ^ */
+#ifdef SEM_ERR
+ *iv_return = SEM_ERR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "S_IRGRP", 7)) {
+ /* ^ */
+#ifdef S_IRGRP
+ *iv_return = S_IRGRP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IWGRP", 7)) {
+ /* ^ */
+#ifdef S_IWGRP
+ *iv_return = S_IWGRP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IXGRP", 7)) {
+ /* ^ */
+#ifdef S_IXGRP
+ *iv_return = S_IXGRP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "SHM_MAP", 7)) {
+ /* ^ */
+#ifdef SHM_MAP
+ *iv_return = SHM_MAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "S_IROTH", 7)) {
+ /* ^ */
+#ifdef S_IROTH
+ *iv_return = S_IROTH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IWOTH", 7)) {
+ /* ^ */
+#ifdef S_IWOTH
+ *iv_return = S_IWOTH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IXOTH", 7)) {
+ /* ^ */
+#ifdef S_IXOTH
+ *iv_return = S_IXOTH;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "SHM_RND", 7)) {
+ /* ^ */
+#ifdef SHM_RND
+ *iv_return = SHM_RND;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "IPC_SET", 7)) {
+ /* ^ */
+#ifdef IPC_SET
+ *iv_return = IPC_SET;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "S_IRUSR", 7)) {
+ /* ^ */
+#ifdef S_IRUSR
+ *iv_return = S_IRUSR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IWUSR", 7)) {
+ /* ^ */
+#ifdef S_IWUSR
+ *iv_return = S_IWUSR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IXUSR", 7)) {
+ /* ^ */
+#ifdef S_IXUSR
+ *iv_return = S_IXUSR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "S_IRWXG", 7)) {
+ /* ^ */
+#ifdef S_IRWXG
+ *iv_return = S_IRWXG;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IRWXO", 7)) {
+ /* ^ */
+#ifdef S_IRWXO
+ *iv_return = S_IRWXO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "S_IRWXU", 7)) {
+ /* ^ */
+#ifdef S_IRWXU
+ *iv_return = S_IRWXU;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_8 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ IPC_EXCL IPC_INFO IPC_RMID IPC_STAT MSG_INFO MSG_STAT MSG_WAIT SEM_DEST
+ SEM_INFO SEM_STAT SEM_UNDO SHM_COPY SHM_DEST SHM_FMAP SHM_INFO SHM_INIT
+ SHM_LOCK SHM_SIZE SHM_STAT */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'C':
+ if (memEQ(name, "SHM_COPY", 8)) {
+ /* ^ */
+#ifdef SHM_COPY
+ *iv_return = SHM_COPY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'D':
+ if (memEQ(name, "SEM_DEST", 8)) {
+ /* ^ */
+#ifdef SEM_DEST
+ *iv_return = SEM_DEST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_DEST", 8)) {
+ /* ^ */
+#ifdef SHM_DEST
+ *iv_return = SHM_DEST;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "IPC_EXCL", 8)) {
+ /* ^ */
+#ifdef IPC_EXCL
+ *iv_return = IPC_EXCL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "SHM_FMAP", 8)) {
+ /* ^ */
+#ifdef SHM_FMAP
+ *iv_return = SHM_FMAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "IPC_INFO", 8)) {
+ /* ^ */
+#ifdef IPC_INFO
+ *iv_return = IPC_INFO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "MSG_INFO", 8)) {
+ /* ^ */
+#ifdef MSG_INFO
+ *iv_return = MSG_INFO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SEM_INFO", 8)) {
+ /* ^ */
+#ifdef SEM_INFO
+ *iv_return = SEM_INFO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_INFO", 8)) {
+ /* ^ */
+#ifdef SHM_INFO
+ *iv_return = SHM_INFO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_INIT", 8)) {
+ /* ^ */
+#ifdef SHM_INIT
+ *iv_return = SHM_INIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "SHM_LOCK", 8)) {
+ /* ^ */
+#ifdef SHM_LOCK
+ *iv_return = SHM_LOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "IPC_RMID", 8)) {
+ /* ^ */
+#ifdef IPC_RMID
+ *iv_return = IPC_RMID;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "IPC_STAT", 8)) {
+ /* ^ */
+#ifdef IPC_STAT
+ *iv_return = IPC_STAT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "MSG_STAT", 8)) {
+ /* ^ */
+#ifdef MSG_STAT
+ *iv_return = MSG_STAT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SEM_STAT", 8)) {
+ /* ^ */
+#ifdef SEM_STAT
+ *iv_return = SEM_STAT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_SIZE", 8)) {
+ /* ^ */
+#ifdef SHM_SIZE
+ *iv_return = SHM_SIZE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_STAT", 8)) {
+ /* ^ */
+#ifdef SHM_STAT
+ *iv_return = SHM_STAT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "SEM_UNDO", 8)) {
+ /* ^ */
+#ifdef SEM_UNDO
+ *iv_return = SEM_UNDO;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "MSG_WAIT", 8)) {
+ /* ^ */
+#ifdef MSG_WAIT
+ *iv_return = MSG_WAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_9 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ IPC_ALLOC IPC_CREAT MSG_FWAIT MSG_MWAIT MSG_QWAIT MSG_RWAIT MSG_WWAIT
+ SEM_ALLOC SEM_ORDER SHM_CLEAR SHM_REMAP */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'A':
+ if (memEQ(name, "IPC_ALLOC", 9)) {
+ /* ^ */
+#ifdef IPC_ALLOC
+ *iv_return = IPC_ALLOC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SEM_ALLOC", 9)) {
+ /* ^ */
+#ifdef SEM_ALLOC
+ *iv_return = SEM_ALLOC;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'C':
+ if (memEQ(name, "IPC_CREAT", 9)) {
+ /* ^ */
+#ifdef IPC_CREAT
+ *iv_return = IPC_CREAT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_CLEAR", 9)) {
+ /* ^ */
+#ifdef SHM_CLEAR
+ *iv_return = SHM_CLEAR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'F':
+ if (memEQ(name, "MSG_FWAIT", 9)) {
+ /* ^ */
+#ifdef MSG_FWAIT
+ *iv_return = MSG_FWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "MSG_MWAIT", 9)) {
+ /* ^ */
+#ifdef MSG_MWAIT
+ *iv_return = MSG_MWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'O':
+ if (memEQ(name, "SEM_ORDER", 9)) {
+ /* ^ */
+#ifdef SEM_ORDER
+ *iv_return = SEM_ORDER;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'Q':
+ if (memEQ(name, "MSG_QWAIT", 9)) {
+ /* ^ */
+#ifdef MSG_QWAIT
+ *iv_return = MSG_QWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "MSG_RWAIT", 9)) {
+ /* ^ */
+#ifdef MSG_RWAIT
+ *iv_return = MSG_RWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_REMAP", 9)) {
+ /* ^ */
+#ifdef SHM_REMAP
+ *iv_return = SHM_REMAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "MSG_WWAIT", 9)) {
+ /* ^ */
+#ifdef MSG_WWAIT
+ *iv_return = MSG_WWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_10 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ IPC_GETACL IPC_LOCKED IPC_NOWAIT IPC_SETACL IPC_WANTED MSG_EXCEPT
+ MSG_LOCKED SHM_DCACHE SHM_ECACHE SHM_ICACHE SHM_LOCKED SHM_NOSWAP
+ SHM_RDONLY SHM_SHATTR SHM_UNLOCK */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'D':
+ if (memEQ(name, "SHM_DCACHE", 10)) {
+ /* ^ */
+#ifdef SHM_DCACHE
+ *iv_return = SHM_DCACHE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'E':
+ if (memEQ(name, "MSG_EXCEPT", 10)) {
+ /* ^ */
+#ifdef MSG_EXCEPT
+ *iv_return = MSG_EXCEPT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_ECACHE", 10)) {
+ /* ^ */
+#ifdef SHM_ECACHE
+ *iv_return = SHM_ECACHE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "IPC_GETACL", 10)) {
+ /* ^ */
+#ifdef IPC_GETACL
+ *iv_return = IPC_GETACL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "SHM_ICACHE", 10)) {
+ /* ^ */
+#ifdef SHM_ICACHE
+ *iv_return = SHM_ICACHE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'L':
+ if (memEQ(name, "IPC_LOCKED", 10)) {
+ /* ^ */
+#ifdef IPC_LOCKED
+ *iv_return = IPC_LOCKED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "MSG_LOCKED", 10)) {
+ /* ^ */
+#ifdef MSG_LOCKED
+ *iv_return = MSG_LOCKED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_LOCKED", 10)) {
+ /* ^ */
+#ifdef SHM_LOCKED
+ *iv_return = SHM_LOCKED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'N':
+ if (memEQ(name, "IPC_NOWAIT", 10)) {
+ /* ^ */
+#ifdef IPC_NOWAIT
+ *iv_return = IPC_NOWAIT;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_NOSWAP", 10)) {
+ /* ^ */
+#ifdef SHM_NOSWAP
+ *iv_return = SHM_NOSWAP;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'R':
+ if (memEQ(name, "SHM_RDONLY", 10)) {
+ /* ^ */
+#ifdef SHM_RDONLY
+ *iv_return = SHM_RDONLY;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "IPC_SETACL", 10)) {
+ /* ^ */
+#ifdef IPC_SETACL
+ *iv_return = IPC_SETACL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "SHM_SHATTR", 10)) {
+ /* ^ */
+#ifdef SHM_SHATTR
+ *iv_return = SHM_SHATTR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'U':
+ if (memEQ(name, "SHM_UNLOCK", 10)) {
+ /* ^ */
+#ifdef SHM_UNLOCK
+ *iv_return = SHM_UNLOCK;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'W':
+ if (memEQ(name, "IPC_WANTED", 10)) {
+ /* ^ */
+#ifdef IPC_WANTED
+ *iv_return = IPC_WANTED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant_11 (pTHX_ const char *name, IV *iv_return) {
+ /* When generated this function returned values for the list of names given
+ here. However, subsequent manual editing may have added or removed some.
+ IPC_NOERROR IPC_PRIVATE MSG_NOERROR SHM_HUGETLB SHM_REMOVED */
+ /* Offset 6 gives the best switch position. */
+ switch (name[6]) {
+ case 'E':
+ if (memEQ(name, "IPC_NOERROR", 11)) {
+ /* ^ */
+#ifdef IPC_NOERROR
+ *iv_return = IPC_NOERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ if (memEQ(name, "MSG_NOERROR", 11)) {
+ /* ^ */
+#ifdef MSG_NOERROR
+ *iv_return = MSG_NOERROR;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'G':
+ if (memEQ(name, "SHM_HUGETLB", 11)) {
+ /* ^ */
+#ifdef SHM_HUGETLB
+ *iv_return = SHM_HUGETLB;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'I':
+ if (memEQ(name, "IPC_PRIVATE", 11)) {
+ /* ^ */
+#ifdef IPC_PRIVATE
+ *iv_return = IPC_PRIVATE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'M':
+ if (memEQ(name, "SHM_REMOVED", 11)) {
+ /* ^ */
+#ifdef SHM_REMOVED
+ *iv_return = SHM_REMOVED;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
+static int
+constant (pTHX_ const char *name, STRLEN len, IV *iv_return) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/home/mhx/perl/blead-debug/bin/perl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw(IV)};
+my @names = (qw(ENOSPC ENOSYS GETALL GETNCNT GETPID GETVAL GETZCNT IPC_ALLOC
+ IPC_CREAT IPC_EXCL IPC_GETACL IPC_INFO 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_EXCEPT
+ MSG_FWAIT MSG_INFO MSG_LOCKED MSG_MWAIT MSG_NOERROR MSG_QWAIT
+ MSG_R MSG_RWAIT MSG_STAT MSG_W MSG_WAIT MSG_WWAIT SEM_A
+ SEM_ALLOC SEM_DEST SEM_ERR SEM_INFO SEM_ORDER SEM_R SEM_STAT
+ SEM_UNDO SETALL SETVAL SHMLBA SHM_A SHM_CLEAR SHM_COPY
+ SHM_DCACHE SHM_DEST SHM_ECACHE SHM_FMAP SHM_HUGETLB SHM_ICACHE
+ SHM_INFO SHM_INIT SHM_LOCK SHM_LOCKED SHM_MAP SHM_NORESERVE
+ SHM_NOSWAP SHM_R SHM_RDONLY SHM_REMAP SHM_REMOVED SHM_RND
+ SHM_SHARE_MMU SHM_SHATTR SHM_SIZE SHM_STAT SHM_UNLOCK SHM_W
+ S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_IWGRP S_IWOTH
+ S_IWUSR S_IXGRP S_IXOTH S_IXUSR));
+
+print constant_types(), "\n"; # macro defs
+foreach (C_constant ("IPC::SysV", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "\n#### XS Section:\n";
+print XS_constant ("IPC::SysV", $types);
+__END__
+ */
+
+ switch (len) {
+ case 5:
+ return constant_5 (aTHX_ name, iv_return);
+ break;
+ case 6:
+ return constant_6 (aTHX_ name, iv_return);
+ break;
+ case 7:
+ return constant_7 (aTHX_ name, iv_return);
+ break;
+ case 8:
+ return constant_8 (aTHX_ name, iv_return);
+ break;
+ case 9:
+ return constant_9 (aTHX_ name, iv_return);
+ break;
+ case 10:
+ return constant_10 (aTHX_ name, iv_return);
+ break;
+ case 11:
+ return constant_11 (aTHX_ name, iv_return);
+ break;
+ case 12:
+ if (memEQ(name, "IPC_SETLABEL", 12)) {
+#ifdef IPC_SETLABEL
+ *iv_return = IPC_SETLABEL;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 13:
+ /* Names all of length 13. */
+ /* SHM_NORESERVE SHM_SHARE_MMU */
+ /* Offset 4 gives the best switch position. */
+ switch (name[4]) {
+ case 'N':
+ if (memEQ(name, "SHM_NORESERVE", 13)) {
+ /* ^ */
+#ifdef SHM_NORESERVE
+ *iv_return = SHM_NORESERVE;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ case 'S':
+ if (memEQ(name, "SHM_SHARE_MMU", 13)) {
+ /* ^ */
+#ifdef SHM_SHARE_MMU
+ *iv_return = SHM_SHARE_MMU;
+ return PERL_constant_ISIV;
+#else
+ return PERL_constant_NOTDEF;
+#endif
+ }
+ break;
+ }
+ break;
+ }
+ return PERL_constant_NOTFOUND;
+}
+
--- /dev/null
+void
+_constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ IV iv;
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ /* Change this to constant(aTHX_ s, len, &iv, &nv);
+ if you need to return both NVs and IVs */
+ type = constant(aTHX_ s, len, &iv);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv =
+ sv_2mortal(newSVpvf("%s is not a valid IPC::SysV macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined IPC::SysV macro %s, used",
+ s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break;
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ /* Uncomment this if you need to return PVs
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break; */
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing IPC::SysV macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
-# 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.
+# $Revision: 17 $
+# $Author: mhx $
+# $Date: 2007/10/15 20:29:06 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
package IPC::Msg;
use vars qw($VERSION);
use Carp;
-$VERSION = "1.02";
+$VERSION = do { my @r = '$Snapshot: /IPC-SysV/1.99_07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
$VERSION = eval $VERSION;
+# Figure out if we have support for native sized types
+my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
+
{
package IPC::Msg::stat;
msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or
return;
my $type;
- ($type,$_[0]) = unpack("l! a*",$buf);
+ ($type,$_[0]) = unpack("l$N a*",$buf);
$type;
}
sub snd {
@_ <= 4 && @_ >= 3 or croak '$msg->snd( TYPE, BUF, FLAGS )';
my $self = shift;
- msgsnd($$self,pack("l! a*",$_[0],$_[1]), $_[2] || 0);
+ msgsnd($$self,pack("l$N a*",$_[0],$_[1]), $_[2] || 0);
}
use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR);
use IPC::Msg;
- $msg = new IPC::Msg(IPC_PRIVATE, S_IRUSR | S_IWUSR);
+ $msg = IPC::Msg->new(IPC_PRIVATE, S_IRUSR | S_IWUSR);
$msg->snd(pack("l! a*",$msgtype,$msg));
=item *
-C<KEY> does not already have a message queue
-associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
+C<KEY> does not already have a message queue associated with
+it, and C<I<FLAGS> & IPC_CREAT> is true.
=back
=head1 SEE ALSO
-L<IPC::SysV> L<Class::Struct>
+L<IPC::SysV>, L<Class::Struct>
-=head1 AUTHOR
+=head1 AUTHORS
-Graham Barr <gbarr@pobox.com>
+Graham Barr <gbarr@pobox.com>,
+Marcus Holland-Moritz <mhx@cpan.org>
=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.
+Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz.
+
+Version 1.x, Copyright (c) 1997, Graham Barr.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
=cut
-# 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.
+# $Revision: 18 $
+# $Author: mhx $
+# $Date: 2007/10/15 20:29:08 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
package IPC::Semaphore;
use vars qw($VERSION);
use Carp;
-$VERSION = "1.02";
+$VERSION = do { my @r = '$Snapshot: /IPC-SysV/1.99_07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
$VERSION = eval $VERSION;
+# Figure out if we have support for native sized types
+my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
+
{
package IPC::Semaphore::stat;
@_ >= 4 || croak '$sem->op( OPLIST )';
my $self = shift;
croak 'Bad arg count' if @_ % 3;
- my $data = pack("s!*",@_);
+ my $data = pack("s$N*",@_);
semop($$self,$data);
}
my $data = "";
semctl($$self,0,GETALL,$data)
or return ();
- (unpack("s!*",$data));
+ (unpack("s$N*",$data));
}
sub setall {
my $self = shift;
- my $data = pack("s!*",@_);
+ my $data = pack("s$N*",@_);
semctl($$self,0,SETALL,$data);
}
use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR IPC_CREAT);
use IPC::Semaphore;
- $sem = new IPC::Semaphore(IPC_PRIVATE, 10, S_IRUSR | S_IWUSR | IPC_CREAT);
+ $sem = IPC::Semaphore->new(IPC_PRIVATE, 10, S_IRUSR | S_IWUSR | IPC_CREAT);
$sem->setall( (0) x 10);
=item *
-C<KEY> does not already have a semaphore identifier
+C<KEY> does not already have a semaphore identifier
associated with it, and C<I<FLAGS> & IPC_CREAT> is true.
=back
=head1 SEE ALSO
-L<IPC::SysV> L<Class::Struct> L<semget> L<semctl> L<semop>
+L<IPC::SysV>, L<Class::Struct>, L<semget>, L<semctl>, L<semop>
-=head1 AUTHOR
+=head1 AUTHORS
-Graham Barr <gbarr@pobox.com>
+Graham Barr <gbarr@pobox.com>,
+Marcus Holland-Moritz <mhx@cpan.org>
=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.
+Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz.
+
+Version 1.x, Copyright (c) 1997, Graham Barr.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
=cut
--- /dev/null
+################################################################################
+#
+# $Revision: 2 $
+# $Author: mhx $
+# $Date: 2007/10/14 05:16:08 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
+package IPC::SharedMem;
+
+use IPC::SysV qw(IPC_STAT IPC_RMID shmat shmdt memread memwrite);
+use strict;
+use vars qw($VERSION);
+use Carp;
+
+$VERSION = do { my @r = '$Snapshot: /IPC-SysV/1.99_07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
+$VERSION = eval $VERSION;
+
+# Figure out if we have support for native sized types
+my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
+
+{
+ package IPC::SharedMem::stat;
+
+ use Class::Struct qw(struct);
+
+ struct 'IPC::SharedMem::stat' => [
+ uid => '$',
+ gid => '$',
+ cuid => '$',
+ cgid => '$',
+ mode => '$',
+ segsz => '$',
+ lpid => '$',
+ cpid => '$',
+ nattch => '$',
+ atime => '$',
+ dtime => '$',
+ ctime => '$',
+ ];
+}
+
+sub new
+{
+ @_ == 4 or croak 'IPC::SharedMem->new(KEY, SIZE, FLAGS)';
+ my($class, $key, $size, $flags) = @_;
+
+ my $id = shmget $key, $size, $flags or return undef;
+
+ bless { _id => $id, _addr => undef, _isrm => 0 }, $class
+}
+
+sub id
+{
+ my $self = shift;
+ $self->{_id};
+}
+
+sub addr
+{
+ my $self = shift;
+ $self->{_addr};
+}
+
+sub stat
+{
+ my $self = shift;
+ my $data = '';
+ shmctl $self->id, IPC_STAT, $data or return undef;
+ IPC::SharedMem::stat->new->unpack($data);
+}
+
+sub attach
+{
+ @_ >= 1 && @_ <= 2 or croak '$shm->attach([FLAG])';
+ my($self, $flag) = @_;
+ defined $self->addr and return undef;
+ $self->{_addr} = shmat($self->id, undef, $flag || 0);
+ defined $self->addr;
+}
+
+sub detach
+{
+ my $self = shift;
+ defined $self->addr or return undef;
+ my $rv = defined shmdt($self->addr);
+ undef $self->{_addr} if $rv;
+ $rv;
+}
+
+sub remove
+{
+ my $self = shift;
+ return undef if $self->is_removed;
+ my $rv = shmctl $self->id, IPC_RMID, 0;
+ $self->{_isrm} = 1 if $rv;
+ return $rv;
+}
+
+sub is_removed
+{
+ my $self = shift;
+ $self->{_isrm};
+}
+
+sub read
+{
+ @_ == 3 or croak '$shm->read(POS, SIZE)';
+ my($self, $pos, $size) = @_;
+ my $buf = '';
+ if (defined $self->addr) {
+ memread($self->addr, $buf, $pos, $size) or return undef;
+ }
+ else {
+ shmread($self->id, $buf, $pos, $size) or return undef;
+ }
+ $buf;
+}
+
+sub write
+{
+ @_ == 4 or croak '$shm->write(STRING, POS, SIZE)';
+ my($self, $str, $pos, $size) = @_;
+ if (defined $self->addr) {
+ return memwrite($self->addr, $str, $pos, $size);
+ }
+ else {
+ return shmwrite($self->id, $str, $pos, $size);
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::SharedMem - SysV Shared Memory IPC object class
+
+=head1 SYNOPSIS
+
+ use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR);
+ use IPC::SharedMem;
+
+ $shm = IPC::SharedMem->new(IPC_PRIVATE, 8, S_IRWXU);
+
+ $shm->write(pack("S", 4711), 2, 2);
+
+ $data = $shm->read(0, 2);
+
+ $ds = $shm->stat;
+
+ $shm->remove;
+
+=head1 DESCRIPTION
+
+A class providing an object based interface to SysV IPC shared memory.
+
+=head1 METHODS
+
+=over 4
+
+=item new ( KEY , SIZE , FLAGS )
+
+Creates a new shared memory segment associated with C<KEY>. A new
+segment is created if
+
+=over 4
+
+=item *
+
+C<KEY> is equal to C<IPC_PRIVATE>
+
+=item *
+
+C<KEY> does not already have a shared memory segment associated
+with it, and C<I<FLAGS> & IPC_CREAT> is true.
+
+=back
+
+On creation of a new shared memory segment C<FLAGS> is used to
+set the permissions. Be careful not to set any flags that the
+Sys V IPC implementation does not allow: in some systems setting
+execute bits makes the operations fail.
+
+=item id
+
+Returns the shared memory identifier.
+
+=item read ( POS, SIZE )
+
+Read C<SIZE> bytes from the shared memory segment at C<POS>. Returns
+the string read, or C<undef> if there was an error. The return value
+becomes tainted. See L<shmread>.
+
+=item write ( STRING, POS, SIZE )
+
+Write C<SIZE> bytes to the shared memory segment at C<POS>. Returns
+true if successful, or false if there is an error. See L<shmwrite>.
+
+=item remove
+
+Remove the shared memory segment from the system or mark it as
+removed as long as any processes are still attached to it.
+
+=item is_removed
+
+Returns true if the shared memory segment has been removed or
+marked for removal.
+
+=item stat
+
+Returns an object of type C<IPC::SharedMem::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
+ segsz
+ lpid
+ cpid
+ nattach
+ atime
+ dtime
+ ctime
+
+=item attach ( [FLAG] )
+
+Permanently attach to the shared memory segment. When a C<IPC::SharedMem>
+object is attached, it will use L<memread> and L<memwrite> instead of
+L<shmread> and L<shmwrite> for accessing the shared memory segment.
+Returns true if successful, or false on error. See L<shmat>.
+
+=item detach
+
+Detach from the shared memory segment that previously has been attached
+to. Returns true if successful, or false on error. See L<shmdt>.
+
+=item addr
+
+Returns the address of the shared memory that has been attached to in a
+format suitable for use with C<pack('P')>. Returns C<undef> if the shared
+memory has not been attached.
+
+=back
+
+=head1 SEE ALSO
+
+L<IPC::SysV>, L<Class::Struct>
+
+=head1 AUTHORS
+
+Marcus Holland-Moritz <mhx@cpan.org>
+
+=head1 COPYRIGHT
+
+Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz.
+
+Version 1.x, Copyright (c) 1997, Graham Barr.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+################################################################################
+#
+# $Revision: 23 $
+# $Author: mhx $
+# $Date: 2007/10/19 20:46:32 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>.
+#
+# 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 $XS_VERSION $AUTOLOAD);
+use Carp;
+use Config;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = do { my @r = '$Snapshot: /IPC-SysV/1.99_07 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
+$XS_VERSION = $VERSION;
+$VERSION = eval $VERSION;
+
+# To support new constants, just add them to @EXPORT_OK
+# and the C/XS code will be generated automagically.
+@EXPORT_OK = (qw(
+
+ GETALL GETNCNT GETPID GETVAL GETZCNT
+
+ IPC_ALLOC IPC_CREAT IPC_EXCL IPC_GETACL IPC_INFO 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_EXCEPT MSG_FWAIT MSG_INFO MSG_LOCKED MSG_MWAIT MSG_NOERROR
+ MSG_QWAIT MSG_R MSG_RWAIT MSG_STAT MSG_W MSG_WAIT MSG_WWAIT
+
+ SEM_A SEM_ALLOC SEM_DEST SEM_ERR SEM_INFO SEM_ORDER SEM_R
+ SEM_STAT SEM_UNDO
+
+ SETALL SETVAL
+
+ SHMLBA
+
+ SHM_A SHM_CLEAR SHM_COPY SHM_DCACHE SHM_DEST SHM_ECACHE
+ SHM_FMAP SHM_HUGETLB SHM_ICACHE SHM_INFO SHM_INIT SHM_LOCK
+ SHM_LOCKED SHM_MAP SHM_NORESERVE SHM_NOSWAP SHM_R SHM_RDONLY
+ SHM_REMAP SHM_REMOVED SHM_RND SHM_SHARE_MMU SHM_SHATTR
+ SHM_SIZE SHM_STAT SHM_UNLOCK SHM_W
+
+ S_IRUSR S_IWUSR S_IXUSR S_IRWXU
+ S_IRGRP S_IWGRP S_IXGRP S_IRWXG
+ S_IROTH S_IWOTH S_IXOTH S_IRWXO
+
+ ENOSPC ENOSYS
+
+), qw(
+
+ ftok shmat shmdt memread memwrite
+
+));
+
+sub AUTOLOAD
+{
+ my $constname = $AUTOLOAD;
+ $constname =~ s/.*:://;
+ die "&IPC::SysV::_constant not defined" if $constname eq '_constant';
+ my ($error, $val) = _constant($constname);
+ if ($error) {
+ my (undef, $file, $line) = caller;
+ die "$error at $file line $line.\n";
+ }
+ {
+ no strict 'refs';
+ *$AUTOLOAD = sub { $val };
+ }
+ goto &$AUTOLOAD;
+}
+
+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__, $XS_VERSION);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IPC::SysV - System V IPC constants and system calls
+
+=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. Common ones include
+
+ IPC_CREATE IPC_EXCL IPC_NOWAIT IPC_PRIVATE IPC_RMID IPC_SET IPC_STAT
+ GETVAL SETVAL GETPID GETNCNT GETZCNT GETALL SETALL
+ SEM_A SEM_R SEM_UNDO
+ SHM_RDONLY SHM_RND SHMLBA
+
+and auxiliary ones
+
+ S_IRUSR S_IWUSR S_IRWXU
+ S_IRGRP S_IWGRP S_IRWXG
+ S_IROTH S_IWOTH S_IRWXO
+
+but your system might have more.
+
+=over 4
+
+=item ftok( PATH )
+
+=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>.
+
+If ID is omitted, it defaults to C<1>. If a single character is
+given for ID, the numeric value of that character is used.
+
+=item shmat( ID, ADDR, FLAG )
+
+Attach the shared memory segment identified by ID to the address
+space of the calling process. See L<shmat>.
+
+ADDR should be C<undef> unless you really know what you're doing.
+
+=item shmdt( ADDR )
+
+Detach the shared memory segment located at the address specified
+by ADDR from the address space of the calling process. See L<shmdt>.
+
+=item memread( ADDR, VAR, POS, SIZE )
+
+Reads SIZE bytes from a memory segment at ADDR starting at position POS.
+VAR must be a variable that will hold the data read. Returns true if
+successful, or false if there is an error. memread() taints the variable.
+
+=item memwrite( ADDR, STRING, POS, SIZE )
+
+Writes SIZE bytes from STRING to a memory segment at ADDR starting at
+position POS. If STRING is too long, only SIZE bytes are used; if STRING
+is too short, nulls are written to fill out SIZE bytes. Returns true if
+successful, or false if there is an error.
+
+=back
+
+=head1 SEE ALSO
+
+L<IPC::Msg>, L<IPC::Semaphore>, L<IPC::SharedMem>, L<ftok>, L<shmat>, L<shmdt>
+
+=head1 AUTHORS
+
+Graham Barr <gbarr@pobox.com>,
+Jarkko Hietaniemi <jhi@iki.fi>,
+Marcus Holland-Moritz <mhx@cpan.org>
+
+=head1 COPYRIGHT
+
+Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz.
+
+Version 1.x, Copyright (c) 1997, Graham Barr.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+use strict;
+
+unless (@ARGV) {
+ @ARGV = qw( constants );
+}
+
+my %gen = map { ($_ => 1) } @ARGV;
+
+if (delete $gen{constants}) {
+ make_constants();
+}
+
+for my $key (keys %gen) {
+ print STDERR "Invalid request to regenerate $key!\n";
+}
+
+sub make_constants
+{
+ unless (eval { require ExtUtils::Constant; 1 }) {
+ my @files = qw( const-c.inc const-xs.inc );
+
+ die "Cannot regenerate constants:\n$@\n" if grep { !-f } @files;
+
+ my @deps = qw( regen.pl lib/IPC/SysV.pm );
+
+ my $oldage = (sort { $a <=> $b } map { -M } @files)[-1]; # age of oldest file
+ my $depage = (sort { $a <=> $b } map { -M } @deps)[0]; # age of newest dependency
+ my @outdated = grep { (-M) > $depage } @files;
+ my @newdeps = grep { (-M) < $oldage } @deps;
+
+ print STDERR <<EOM;
+
+***********************************************************************
+
+ The following files seem to be out of date:
+
+ @outdated
+
+ The reason is probably that you modified these files:
+
+ @newdeps
+
+ If you're absolutely sure you didn't touch the files, please ignore
+ this message.
+
+ Otherwise, please install the ExtUtils::Constant module.
+
+***********************************************************************
+
+EOM
+
+ exit 0; # will build anyway, since the files exist
+ }
+
+ my $source = 'lib/IPC/SysV.pm';
+ local $_;
+ local *SYSV;
+
+ open SYSV, $source or die "$source: $!\n";
+
+ my $parse = 0;
+ my @const;
+
+ while (<SYSV>) {
+ if ($parse) {
+ if (/^\)/) { $parse++; last }
+ push @const, split;
+ }
+ /^\@EXPORT_OK\s*=/ and $parse++;
+ }
+
+ close SYSV;
+
+ die "couldn't parse $source" if $parse != 2;
+
+ eval {
+ ExtUtils::Constant::WriteConstants(
+ NAME => 'IPC::SysV',
+ NAMES => \@const,
+ XS_FILE => 'const-xs.inc',
+ C_FILE => 'const-c.inc',
+ XS_SUBNAME => '_constant',
+ );
+ };
+
+ if ($@) {
+ my $err = "Cannot regenerate constants:\n$@\n";
+ if ($[ < 5.006) {
+ print STDERR $err;
+ exit 0;
+ }
+ die $err;
+ }
+
+ print "Writing const-xs.inc\n";
+ print "Writing const-c.inc\n";
+}
+################################################################################
+#
+# $Revision: 12 $
+# $Author: mhx $
+# $Date: 2007/10/22 13:10:22 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
BEGIN {
+ if ($ENV{'PERL_CORE'}) {
chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+ }
- @INC = qw(. ../lib);
+ require Test::More; import Test::More;
+ require Config; import Config;
- require Config; import Config;
- require 'test.pl';
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ plan(skip_all => 'IPC::SysV was not built');
+ }
}
-if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
- skip_all('IPC::SysV was not built');
-}
-elsif ($Config{'d_sem'} ne 'define') {
- skip_all('$Config{d_sem} undefined');
+if ($Config{'d_sem'} ne 'define') {
+ plan(skip_all => '$Config{d_sem} undefined');
}
elsif ($Config{'d_msg'} ne 'define') {
- skip_all('$Config{d_msg} undefined');
-}
-else {
- plan( tests => 17 );
+ plan(skip_all => '$Config{d_msg} undefined');
}
+plan(tests => 38);
+
# These constants are common to all tests.
# Later the sem* tests will import more for themselves.
use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
use strict;
-my $msg;
-my $sem;
+{
+ my $did_diag = 0;
+
+ sub do_sys_diag
+ {
+ return if $did_diag++;
+
+ if ($^O eq 'cygwin') {
+ diag(<<EOM);
+
+It may be that the cygserver service isn't running.
+
+EOM
+
+ diag(<<EOM) unless exists $ENV{CYGWIN} && $ENV{CYGWIN} eq 'server';
+You also may have to set the CYGWIN environment variable
+to 'server' before running the test suite:
+
+ export CYGWIN=server
+
+EOM
+ }
+ else {
+ diag(<<EOM);
-# FreeBSD is known to throw this if there's no SysV IPC in the kernel.
-$SIG{SYS} = sub {
- diag(<<EOM);
-SIGSYS caught.
It may be that your kernel does not have SysV IPC configured.
EOM
- if ($^O eq 'freebsd') {
- diag(<<EOM);
+
+ diag(<<EOM) if $^O eq 'freebsd';
You must have following options in your kernel:
options SYSVSHM
EOM
}
+ }
+}
+
+{
+ my $SIGSYS_caught = 0;
+
+ sub skip_or_die
+ {
+ my($what, $why) = @_;
+ if ($SIGSYS_caught) {
+ do_sys_diag();
+ return "$what failed: SIGSYS caught";
+ }
+ my $info = "$what failed: $why";
+ if ($why == &IPC::SysV::ENOSPC || $why == &IPC::SysV::ENOSYS) {
+ do_sys_diag() if $why == &IPC::SysV::ENOSYS;
+ return $info;
+ }
+ die $info;
+ }
+
+ sub catchsig
+ {
+ my $code = shift;
+ if (exists $SIG{SYS}) {
+ local $SIG{SYS} = sub { $SIGSYS_caught++ };
+ return $code->();
+ }
+ return $code->();
+ }
+}
+
+# FreeBSD and cygwin are known to throw this if there's no SysV IPC
+# in the kernel or the cygserver isn't running properly.
+if (exists $SIG{SYS}) { # No SIGSYS with older perls...
+ $SIG{SYS} = sub {
+ do_sys_diag();
diag('Bail out! SIGSYS caught');
exit(1);
-};
+ };
+}
+
+my $msg;
my $perm = S_IRWXU;
+my $test_name;
+my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
SKIP: {
+ skip('lacking d_msgget d_msgctl d_msgsnd d_msgrcv', 6) unless
+ $Config{'d_msgget'} eq 'define' &&
+ $Config{'d_msgctl'} eq 'define' &&
+ $Config{'d_msgsnd'} eq 'define' &&
+ $Config{'d_msgrcv'} eq 'define';
-skip( 'lacking d_msgget d_msgctl d_msgsnd d_msgrcv', 6 ) unless
- $Config{'d_msgget'} eq 'define' &&
- $Config{'d_msgctl'} eq 'define' &&
- $Config{'d_msgsnd'} eq 'define' &&
- $Config{'d_msgrcv'} eq 'define';
+ $msg = catchsig(sub { msgget(IPC_PRIVATE, $perm) });
- $msg = msgget(IPC_PRIVATE, $perm);
- # Very first time called after machine is booted value may be 0
- if (!(defined($msg) && $msg >= 0)) {
- skip( "msgget failed: $!", 6);
- }
- else {
- pass('msgget IPC_PRIVATE S_IRWXU');
- }
+ # Very first time called after machine is booted value may be 0
+ unless (defined $msg && $msg >= 0) {
+ skip(skip_or_die('msgget', $!), 6);
+ }
- #Putting a message on the queue
- my $msgtype = 1;
- my $msgtext = "hello";
+ pass('msgget IPC_PRIVATE S_IRWXU');
- my $test2bad;
- my $test5bad;
- my $test6bad;
+ #Putting a message on the queue
+ my $msgtype = 1;
+ my $msgtext = "hello";
- my $test_name = 'queue a message';
- if (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
- pass($test_name);
- }
- else {
- fail($test_name);
- $test2bad = 1;
- diag(<<EOM);
+ my $test2bad;
+ my $test5bad;
+ my $test6bad;
+
+ $test_name = 'queue a message';
+
+ if (msgsnd($msg, pack("L$N a*", $msgtype, $msgtext), IPC_NOWAIT)) {
+ pass($test_name);
+ }
+ else {
+ fail($test_name);
+ $test2bad = 1;
+ diag(<<EOM);
The failure of the subtest #2 may indicate that the message queue
resource limits either of the system or of the testing account
have been reached. Error message "Operating would block" is
Because of the subtest #2 failing also the substests #5 and #6 will
very probably also fail.
EOM
- }
+ }
- my $data;
- ok(msgctl($msg,IPC_STAT,$data),'msgctl IPC_STAT call');
+ my $data = '';
+ ok(msgctl($msg, IPC_STAT, $data), 'msgctl IPC_STAT call');
- cmp_ok(length($data),'>',0,'msgctl IPC_STAT data');
+ cmp_ok(length($data), '>', 0, 'msgctl IPC_STAT data');
- my $test_name = 'message get call';
- my $msgbuf;
- if (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
- pass($test_name);
- }
- else {
- fail($test_name);
- $test5bad = 1;
- }
- if ($test5bad && $test2bad) {
- diag(<<EOM);
+ $test_name = 'message get call';
+
+ my $msgbuf = '';
+ if (msgrcv($msg, $msgbuf, 256, 0, IPC_NOWAIT)) {
+ pass($test_name);
+ }
+ else {
+ fail($test_name);
+ $test5bad = 1;
+ }
+ if ($test5bad && $test2bad) {
+ diag(<<EOM);
This failure was to be expected because the subtest #2 failed.
EOM
- }
+ }
- my $test_name = 'message get data';
- my($rmsgtype,$rmsgtext);
- ($rmsgtype,$rmsgtext) = unpack("L! a*",$msgbuf);
- if ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
- pass($test_name);
- }
- else {
- fail($test_name);
- $test6bad = 1;
- }
- if ($test6bad && $test2bad) {
+ $test_name = 'message get data';
+
+ my($rmsgtype, $rmsgtext);
+ ($rmsgtype, $rmsgtext) = unpack("L$N a*", $msgbuf);
+
+ if ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
+ pass($test_name);
+ }
+ else {
+ fail($test_name);
+ $test6bad = 1;
+ }
+
+ if ($test6bad && $test2bad) {
print <<EOM;
This failure was to be expected because the subtest #2 failed.
EOM
- }
-} # SKIP
+ }
+}
+
+my $sem;
SKIP: {
+ skip('lacking d_semget d_semctl', 11) unless
+ $Config{'d_semget'} eq 'define' &&
+ $Config{'d_semctl'} eq 'define';
- skip('lacking d_semget d_semctl', 11) unless
- $Config{'d_semget'} eq 'define' &&
- $Config{'d_semctl'} eq 'define';
+ use IPC::SysV qw(IPC_CREAT GETALL SETALL);
- use IPC::SysV qw(IPC_CREAT GETALL SETALL);
+ # FreeBSD's default limit seems to be 9
+ my $nsem = 5;
- # FreeBSD's default limit seems to be 9
- my $nsem = 5;
+ $sem = catchsig(sub { semget(IPC_PRIVATE, $nsem, $perm | IPC_CREAT) });
- my $test_name = 'sem acquire';
- $sem = semget(IPC_PRIVATE, $nsem, $perm | IPC_CREAT);
- if ($sem) {
- pass($test_name);
- }
- else {
- diag("cannot proceed: semget() error: $!");
- skip('semget() resource unavailable', 11)
- if $! eq 'No space left on device';
+ # Very first time called after machine is booted value may be 0
+ unless (defined $sem && $sem >= 0) {
+ skip(skip_or_die('semget', $!), 11);
+ }
- # Very first time called after machine is booted value may be 0
- die "semget: $!\n" unless defined($sem) && $sem >= 0;
- }
+ pass('sem acquire');
+
+ my $data = '';
+ ok(semctl($sem, 0, IPC_STAT, $data), 'sem data call');
+
+ cmp_ok(length($data), '>', 0, 'sem data len');
+
+ ok(semctl($sem, 0, SETALL, pack("s$N*", (0) x $nsem)), 'set all sems');
- my $data;
- ok(semctl($sem,0,IPC_STAT,$data),'sem data call');
+ $data = "";
+ ok(semctl($sem, 0, GETALL, $data), 'get all sems');
- cmp_ok(length($data),'>',0,'sem data len');
+ is(length($data), length(pack("s$N*", (0) x $nsem)), 'right length');
- ok(semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)), 'set all sems');
+ my @data = unpack("s$N*", $data);
- $data = "";
- ok(semctl($sem,0,GETALL,$data), 'get all sems');
+ my $adata = "0" x $nsem;
- is(length($data),length(pack("s!*",(0) x $nsem)), 'right length');
+ is(scalar(@data), $nsem, 'right amount');
+ cmp_ok(join("", @data), 'eq', $adata, 'right data');
- my @data = unpack("s!*",$data);
+ my $poke = 2;
- my $adata = "0" x $nsem;
+ $data[$poke] = 1;
+ ok(semctl($sem, 0, SETALL, pack("s$N*", @data)), 'poke it');
+
+ $data = "";
+ ok(semctl($sem, 0, GETALL, $data), 'and get it back');
+
+ @data = unpack("s$N*", $data);
+ my $bdata = "0" x $poke . "1" . "0" x ($nsem - $poke - 1);
+
+ cmp_ok(join("", @data), 'eq', $bdata, 'changed');
+}
+
+SKIP: {
+ skip('lacking d_shm', 10) unless
+ $Config{'d_shm'} eq 'define';
- is(scalar(@data),$nsem,'right amount');
- cmp_ok(join("",@data),'eq',$adata,'right data');
+ use IPC::SysV qw(shmat shmdt memread memwrite ftok);
- my $poke = 2;
+ my $shm = catchsig(sub { shmget(IPC_PRIVATE, 4, S_IRWXU) });
- $data[$poke] = 1;
- ok(semctl($sem,0,SETALL,pack("s!*",@data)),'poke it');
-
- $data = "";
- ok(semctl($sem,0,GETALL,$data),'and get it back');
+ # Very first time called after machine is booted value may be 0
+ unless (defined $shm && $shm >= 0) {
+ skip(skip_or_die('shmget', $!), 10);
+ }
- @data = unpack("s!*",$data);
- my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
+ pass("shm acquire");
- cmp_ok(join("",@data),'eq',$bdata,'changed');
-} # SKIP
+ ok(shmwrite($shm, pack("N", 0xdeadbeef), 0, 4), 'shmwrite(0xdeadbeef)');
+
+ my $addr = shmat($shm, undef, 0);
+ ok(defined $addr, 'shmat');
+
+ is(unpack("N", unpack("P4", $addr)), 0xdeadbeef, 'read shm by addr');
+
+ ok(defined shmctl($shm, IPC_RMID, 0), 'shmctl(IPC_RMID)');
+
+ my $var = '';
+ ok(memread($addr, $var, 0, 4), 'memread($var)');
+
+ is(unpack("N", $var), 0xdeadbeef, 'read shm by memread');
+
+ ok(memwrite($addr, pack("N", 0xbadc0de5), 0, 4), 'memwrite(0xbadc0de5)');
+
+ is(unpack("N", unpack("P4", $addr)), 0xbadc0de5, 'read modified shm by addr');
+
+ ok(defined shmdt($addr), 'shmdt');
+}
+
+SKIP: {
+ skip('lacking d_shm', 11) unless
+ $Config{'d_shm'} eq 'define';
+
+ use IPC::SysV qw(ftok);
+
+ my $key1i = ftok($0);
+ my $key1e = ftok($0, 1);
+
+ ok(defined $key1i, 'ftok implicit project id');
+ ok(defined $key1e, 'ftok explicit project id');
+ is($key1i, $key1e, 'keys match');
+
+ my $keyAsym = ftok($0, 'A');
+ my $keyAnum = ftok($0, ord('A'));
+
+ ok(defined $keyAsym, 'ftok symbolic project id');
+ ok(defined $keyAnum, 'ftok numeric project id');
+ is($keyAsym, $keyAnum, 'keys match');
+
+ my $two = '2';
+ my $key1 = ftok($0, 2);
+ my $key2 = ftok($0, ord('2'));
+ my $key3 = ftok($0, $two);
+ my $key4 = ftok($0, int($two));
+
+ is($key1, $key4, 'keys match');
+ isnt($key1, $key2, 'keys do not match');
+ is($key2, $key3, 'keys match');
+
+ eval { my $foo = ftok($0, 'AA') };
+ ok(index($@, 'invalid project id') >= 0, 'ftok error');
+
+ eval { my $foo = ftok($0, 3.14159) };
+ ok(index($@, 'invalid project id') >= 0, 'ftok error');
+}
END {
- msgctl($msg,IPC_RMID,0) if defined $msg;
- semctl($sem,0,IPC_RMID,undef) if defined $sem;
+ msgctl($msg, IPC_RMID, 0) if defined $msg;
+ semctl($sem, 0, IPC_RMID, 0) if defined $sem;
}
+################################################################################
+#
+# $Revision: 10 $
+# $Author: mhx $
+# $Date: 2007/10/22 13:10:24 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
BEGIN {
+ if ($ENV{'PERL_CORE'}) {
chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+ }
- @INC = '../lib';
-
- require Config; import Config;
+ require Test::More; import Test::More;
+ require Config; import Config;
- my $reason;
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ plan(skip_all => 'IPC::SysV was not built');
+ }
+}
- if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
- $reason = 'IPC::SysV was not built';
- } elsif ($Config{'d_sem'} ne 'define') {
- $reason = '$Config{d_sem} undefined';
- } elsif ($Config{'d_msg'} ne 'define') {
- $reason = '$Config{d_msg} undefined';
- }
- if ($reason) {
- print "1..0 # Skip: $reason\n";
- exit 0;
- }
+if ($Config{'d_sem'} ne 'define') {
+ plan(skip_all => '$Config{d_sem} undefined');
+} elsif ($Config{'d_msg'} ne 'define') {
+ plan(skip_all => '$Config{d_msg} undefined');
}
use IPC::SysV qw(IPC_PRIVATE IPC_RMID IPC_NOWAIT IPC_STAT S_IRWXU S_IRWXG S_IRWXO);
+use strict;
use IPC::Msg;
#Creating a message queue
-print "1..9\n";
+my $msq = sub {
+ my $code = shift;
+ if (exists $SIG{SYS}) {
+ local $SIG{SYS} = sub { plan(skip_all => "SIGSYS caught") };
+ return $code->();
+ }
+ return $code->();
+}->(sub { new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO) });
+
+unless (defined $msq) {
+ my $info = "IPC::Msg->new failed: $!";
+ if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS) {
+ plan(skip_all => $info);
+ }
+ else {
+ die $info;
+ }
+}
-my $msq =
- new IPC::Msg(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO)
- || die "msgget: ",$!+0," $!\n";
-
-print "ok 1\n";
+plan(tests => 9);
+
+pass('create message queue');
#Putting a message on the queue
-$msgtype = 1;
-$msg = "hello";
-print $msq->snd($msgtype,$msg,IPC_NOWAIT) ? "ok 2\n" : "not ok 2 # $!\n";
+my $test_name = 'enqueue message';
-#Check if there are messages on the queue
-$ds = $msq->stat() or print "not ";
-print "ok 3\n";
+my $msgtype = 1;
+my $msg = "hello";
+if ($msq->snd($msgtype,$msg,IPC_NOWAIT)) {
+ pass($test_name);
+}
+else {
+ print "# snd: $!\n";
+ fail($test_name);
+}
-print "not " unless $ds && $ds->qnum() == 1;
-print "ok 4\n";
+#Check if there are messages on the queue
+my $ds = $msq->stat;
+ok($ds, 'stat');
-#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";
+if ($ds) {
+ is($ds->qnum, 1, 'qnum');
+}
+else {
+ fail('qnum');
+}
-print "not " unless $rmsgtype == $msgtype && $rmsg eq $msg;
-print "ok 6\n";
+#Retrieving a message from the queue
+my $rmsg;
+my $rmsgtype = 0; # Give me any type
+$rmsgtype = $msq->rcv($rmsg,256,$rmsgtype,IPC_NOWAIT);
+is($rmsgtype, $msgtype, 'rmsgtype');
+is($rmsg, $msg, 'rmsg');
-$ds = $msq->stat() or print "not ";
-print "ok 7\n";
+$ds = $msq->stat;
+ok($ds, 'stat');
-print "not " unless $ds && $ds->qnum() == 0;
-print "ok 8\n";
+if ($ds) {
+ is($ds->qnum, 0, 'qnum');
+}
+else {
+ fail('qnum');
+}
END {
- (defined $msq && $msq->remove) || print "not ";
- print "ok 9\n";
+ ok($msq->remove, 'remove message') if defined $msq;
}
--- /dev/null
+################################################################################
+#
+# $Revision: 3 $
+# $Author: mhx $
+# $Date: 2007/10/13 19:07:53 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+ }
+
+ require Test::More; import Test::More;
+ require Config; import Config;
+
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ plan(skip_all => 'IPC::SysV was not built');
+ }
+}
+
+use strict;
+
+my @pods;
+
+# find all potential pod files
+if (open F, "MANIFEST") {
+ chomp(my @files = <F>);
+ close F;
+ for my $f (@files) {
+ next if $f =~ /ppport/;
+ if (open F, $f) {
+ while (<F>) {
+ if (/^=\w+/) {
+ push @pods, $f;
+ last;
+ }
+ }
+ close F;
+ }
+ }
+}
+
+# load Test::Pod if possible, otherwise load Test::More
+eval {
+ require Test::Pod;
+ $Test::Pod::VERSION >= 0.95
+ or die "Test::Pod version only $Test::Pod::VERSION";
+ import Test::Pod tests => scalar @pods;
+};
+
+if ($@) {
+ require Test::More;
+ import Test::More skip_all => "testing pod requires Test::Pod";
+}
+else {
+ for my $pod (@pods) {
+ pod_file_ok($pod);
+ }
+}
+
--- /dev/null
+################################################################################
+#
+# $Revision: 2 $
+# $Author: mhx $
+# $Date: 2007/10/14 05:39:15 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+ }
+
+ require Test::More; import Test::More;
+ require Config; import Config;
+
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ plan(skip_all => 'IPC::SysV was not built');
+ }
+}
+
+use strict;
+
+my @modules = qw( IPC::SysV IPC::Msg IPC::Semaphore IPC::SharedMem );
+
+eval 'use Pod::Coverage 0.10';
+plan skip_all => "testing pod coverage requires Pod::Coverage 0.10" if $@;
+
+eval 'use Test::Pod::Coverage 1.08';
+plan skip_all => "testing pod coverage requires Test::Pod::Coverage 1.08" if $@;
+
+plan tests => scalar @modules;
+
+my $mod = shift @modules;
+pod_coverage_ok($mod, { trustme => [qw( dl_load_flags )] }, "$mod is covered");
+
+for my $mod (@modules) {
+ pod_coverage_ok($mod, "$mod is covered");
+}
+################################################################################
+#
+# $Revision: 14 $
+# $Author: mhx $
+# $Date: 2007/10/22 13:10:24 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
BEGIN {
+ if ($ENV{'PERL_CORE'}) {
chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+ }
- @INC = qw(. ../lib);
- require 'test.pl';
-}
-
-require Config; import Config;
-
-$TEST_COUNT = 11;
+ require Test::More; import Test::More;
+ require Config; import Config;
-if ($Config{'extensions'} !~ /\bIPC\/SysV\b/) {
- skip_all('IPC::SysV was not built');
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ plan(skip_all => 'IPC::SysV was not built');
+ }
}
-elsif ($Config{'d_sem'} ne 'define') {
- skip_all('$Config{d_sem} undefined');
+
+if ($Config{'d_sem'} ne 'define') {
+ plan(skip_all => '$Config{d_sem} undefined');
}
elsif ($Config{'d_msg'} ne 'define') {
- skip_all('$Config{d_msg} undefined');
-}
-else {
- plan( tests => $TEST_COUNT );
+ plan(skip_all => '$Config{d_msg} undefined');
}
use IPC::SysV qw(
);
use IPC::Semaphore;
-SKIP: {
-
-my $sem =
- IPC::Semaphore->new(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
-if (!$sem) {
- if ($! eq 'No space left on device') {
- # "normal" error
- skip( "cannot proceed: IPC::Semaphore->new() said: $!", $TEST_COUNT);
- }
- else {
- # unexpected error
- die "IPC::Semaphore->new(): ",$!+0," $!\n";
- }
+# FreeBSD's default limit seems to be 9
+my $nsem = 5;
+my $sem = sub {
+ my $code = shift;
+ if (exists $SIG{SYS}) {
+ local $SIG{SYS} = sub { plan(skip_all => "SIGSYS caught") };
+ return $code->();
+ }
+ return $code->();
+}->(sub { IPC::Semaphore->new(IPC_PRIVATE, $nsem, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT) });
+
+unless (defined $sem) {
+ my $info = "IPC::Semaphore->new failed: $!";
+ if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS) {
+ plan(skip_all => $info);
+ }
+ else {
+ die $info;
+ }
}
+plan(tests => 11);
+
pass('acquired a semaphore');
ok(my $st = $sem->stat,'stat it');
-ok($sem->setall( (0) x 10),'set all');
+ok($sem->setall((0) x $nsem), 'set all');
my @sem = $sem->getall;
-cmp_ok(join("",@sem),'eq',"0000000000",'get all');
+cmp_ok(join("", @sem), 'eq', "00000", 'get all');
$sem[2] = 1;
-ok($sem->setall( @sem ),'set after change');
+ok($sem->setall(@sem), 'set after change');
@sem = $sem->getall;
-cmp_ok(join("",@sem),'eq',"0010000000",'get again');
+cmp_ok(join("", @sem), 'eq', "00100", 'get again');
my $ncnt = $sem->getncnt(0);
-ok(!$sem->getncnt(0),'procs waiting now');
-ok(defined($ncnt),'prev procs waiting');
+ok(!$sem->getncnt(0), 'procs waiting now');
+ok(defined($ncnt), 'prev procs waiting');
-ok($sem->op(2,-1,IPC_NOWAIT),'op nowait');
+ok($sem->op(2, -1, IPC_NOWAIT), 'op nowait');
-ok(!$sem->getncnt(0),'no procs waiting');
+ok(!$sem->getncnt(0), 'no procs waiting');
END {
- if ($sem) {
- ok($sem->remove,'release');
- }
+ ok($sem->remove, 'remove semaphore') if defined $sem;
}
-
-} # SKIP
--- /dev/null
+################################################################################
+#
+# $Revision: 4 $
+# $Author: mhx $
+# $Date: 2007/10/22 13:10:24 +0200 $
+#
+################################################################################
+#
+# Version 2.x, Copyright (C) 2007, Marcus Holland-Moritz <mhx@cpan.org>.
+# Version 1.x, Copyright (C) 1999, Graham Barr <gbarr@pobox.com>.
+#
+# This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+#
+################################################################################
+
+BEGIN {
+ if ($ENV{'PERL_CORE'}) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib' && -d '../ext';
+ }
+
+ require Test::More; import Test::More;
+ require Config; import Config;
+
+ if ($ENV{'PERL_CORE'} && $Config{'extensions'} !~ m[\bIPC/SysV\b]) {
+ plan(skip_all => 'IPC::SysV was not built');
+ }
+}
+
+if ($Config{'d_shm'} ne 'define') {
+ plan(skip_all => '$Config{d_shm} undefined');
+}
+
+use IPC::SysV qw( IPC_PRIVATE S_IRWXU );
+use IPC::SharedMem;
+
+my $shm = sub {
+ my $code = shift;
+ if (exists $SIG{SYS}) {
+ local $SIG{SYS} = sub { plan(skip_all => "SIGSYS caught") };
+ return $code->();
+ }
+ return $code->();
+}->(sub { IPC::SharedMem->new(IPC_PRIVATE, 8, S_IRWXU) });
+
+unless (defined $shm) {
+ my $info = "IPC::SharedMem->new failed: $!";
+ if ($! == &IPC::SysV::ENOSPC || $! == &IPC::SysV::ENOSYS) {
+ plan(skip_all => $info);
+ }
+ else {
+ die $info;
+ }
+}
+
+plan(tests => 23);
+
+pass('acquired shared mem');
+
+my $st = $shm->stat;
+
+ok($st, 'stat it');
+is($st->nattch, 0, 'st->nattch');
+is($st->cpid, $$, 'cpid');
+ok($st->segsz >= 8, 'segsz');
+
+ok($shm->write(pack("N", 4711), 0, 4), 'write(offs=0)');
+ok($shm->write(pack("N", 210577), 4, 4), 'write(offs=4)');
+
+is($shm->read(0, 4), pack("N", 4711), 'read(offs=0)');
+is($shm->read(4, 4), pack("N", 210577), 'read(offs=4)');
+
+ok($shm->attach, 'attach');
+
+$st = $shm->stat;
+
+ok($st, 'stat it');
+is($st->nattch, 1, 'st->nattch');
+is($st->cpid, $$, 'lpid');
+
+is($shm->read(0, 4), pack("N", 4711), 'read(offs=0)');
+is($shm->read(4, 4), pack("N", 210577), 'read(offs=4)');
+
+ok($shm->write("Shared", 1, 6), 'write(offs=1)');
+
+ok(!$shm->is_removed, '!is_removed');
+ok($shm->remove, 'remove');
+ok($shm->is_removed, 'is_removed');
+
+is($shm->read(1, 6), 'Shared', 'read(offs=1)');
+ok($shm->write("Memory", 0, 6), 'write(offs=0)');
+is(unpack("P6", $shm->addr), 'Memory', 'read using unpack');
+
+ok($shm->detach, 'detach');
+
--- /dev/null
+TYPEMAP
+const char * T_PV
# This file is read by mkppport at build time.
#
+ext/IPC/SysV
ext/Time/HiRes
ext/Win32API/File
projects / platform / upstream / perl.git / commitdiff