diff options
| -rw-r--r-- | MANIFEST | 29 | ||||
| -rw-r--r-- | ext/IPC/SysV/ChangeLog | 28 | ||||
| -rw-r--r-- | ext/IPC/SysV/Changes | 469 | ||||
| -rw-r--r-- | ext/IPC/SysV/MANIFEST | 11 | ||||
| -rw-r--r-- | ext/IPC/SysV/MANIFEST.SKIP | 14 | ||||
| -rw-r--r-- | ext/IPC/SysV/Makefile.PL | 121 | ||||
| -rw-r--r-- | ext/IPC/SysV/README | 7 | ||||
| -rw-r--r-- | ext/IPC/SysV/SysV.pm | 117 | ||||
| -rw-r--r-- | ext/IPC/SysV/SysV.xs | 702 | ||||
| -rw-r--r-- | ext/IPC/SysV/TODO | 2 | ||||
| -rw-r--r-- | ext/IPC/SysV/const-c.inc | 1087 | ||||
| -rw-r--r-- | ext/IPC/SysV/const-xs.inc | 90 | ||||
| -rw-r--r-- | ext/IPC/SysV/lib/IPC/Msg.pm (renamed from ext/IPC/SysV/Msg.pm) | 49 | ||||
| -rw-r--r-- | ext/IPC/SysV/lib/IPC/Semaphore.pm (renamed from ext/IPC/SysV/Semaphore.pm) | 49 | ||||
| -rw-r--r-- | ext/IPC/SysV/lib/IPC/SharedMem.pm | 276 | ||||
| -rw-r--r-- | ext/IPC/SysV/lib/IPC/SysV.pm | 188 | ||||
| -rw-r--r-- | ext/IPC/SysV/regen.pl | 97 | ||||
| -rwxr-xr-x | ext/IPC/SysV/t/ipcsysv.t | 386 | ||||
| -rwxr-xr-x | ext/IPC/SysV/t/msg.t | 126 | ||||
| -rw-r--r-- | ext/IPC/SysV/t/pod.t | 70 | ||||
| -rw-r--r-- | ext/IPC/SysV/t/podcov.t | 48 | ||||
| -rwxr-xr-x | ext/IPC/SysV/t/sem.t | 99 | ||||
| -rw-r--r-- | ext/IPC/SysV/t/shm.t | 96 | ||||
| -rw-r--r-- | ext/IPC/SysV/typemap | 2 | ||||
| -rw-r--r-- | mkppport.lst | 1 |
25 files changed, 3372 insertions, 792 deletions
@@ -822,19 +822,28 @@ ext/IO/t/io_udp.t See if UDP socket-related methods from IO work 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 diff --git a/ext/IPC/SysV/ChangeLog b/ext/IPC/SysV/ChangeLog deleted file mode 100644 index fff95bec43..0000000000 --- a/ext/IPC/SysV/ChangeLog +++ /dev/null @@ -1,28 +0,0 @@ -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 - diff --git a/ext/IPC/SysV/Changes b/ext/IPC/SysV/Changes new file mode 100644 index 0000000000..29a7511c5c --- /dev/null +++ b/ext/IPC/SysV/Changes @@ -0,0 +1,469 @@ +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 + diff --git a/ext/IPC/SysV/MANIFEST b/ext/IPC/SysV/MANIFEST deleted file mode 100644 index 6b28c2cade..0000000000 --- a/ext/IPC/SysV/MANIFEST +++ /dev/null @@ -1,11 +0,0 @@ -MANIFEST -Makefile.PL -Msg.pm -README -Semaphore.pm -SysV.pm -SysV.xs -t/ipcsysv.t -t/msg.t -t/sem.t -ChangeLog diff --git a/ext/IPC/SysV/MANIFEST.SKIP b/ext/IPC/SysV/MANIFEST.SKIP new file mode 100644 index 0000000000..f5cf3b4254 --- /dev/null +++ b/ext/IPC/SysV/MANIFEST.SKIP @@ -0,0 +1,14 @@ +^Makefile$ +~$ +\.old(?:\..*)?$ +\.swp$ +\.o$ +\.bs$ +\.bak$ +\.orig$ +\.cache\.cm$ +^blib +^pm_to_blib +^backup +^testing +IPC-SysV.*\.tar\.gz$ diff --git a/ext/IPC/SysV/Makefile.PL b/ext/IPC/SysV/Makefile.PL index f994950d19..8b1326692f 100644 --- a/ext/IPC/SysV/Makefile.PL +++ b/ext/IPC/SysV/Makefile.PL @@ -1,37 +1,104 @@ -# 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; +} + diff --git a/ext/IPC/SysV/README b/ext/IPC/SysV/README index d412c4c712..a9cb7bdd4d 100644 --- a/ext/IPC/SysV/README +++ b/ext/IPC/SysV/README @@ -1,5 +1,8 @@ -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 diff --git a/ext/IPC/SysV/SysV.pm b/ext/IPC/SysV/SysV.pm deleted file mode 100644 index c3ebcc2096..0000000000 --- a/ext/IPC/SysV/SysV.pm +++ /dev/null @@ -1,117 +0,0 @@ -# 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 - diff --git a/ext/IPC/SysV/SysV.xs b/ext/IPC/SysV/SysV.xs index b5137cf0a7..17571a7d99 100644 --- a/ext/IPC/SysV/SysV.xs +++ b/ext/IPC/SysV/SysV.xs @@ -1,33 +1,52 @@ +/******************************************************************************* +* +* $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. */ @@ -39,21 +58,71 @@ * 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 @@ -62,383 +131,286 @@ void 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 diff --git a/ext/IPC/SysV/TODO b/ext/IPC/SysV/TODO new file mode 100644 index 0000000000..3d825ef1a6 --- /dev/null +++ b/ext/IPC/SysV/TODO @@ -0,0 +1,2 @@ +* try to port below 5.004_05 ? +* test with more platforms diff --git a/ext/IPC/SysV/const-c.inc b/ext/IPC/SysV/const-c.inc new file mode 100644 index 0000000000..fbc35ba940 --- /dev/null +++ b/ext/IPC/SysV/const-c.inc @@ -0,0 +1,1087 @@ +#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; +} + diff --git a/ext/IPC/SysV/const-xs.inc b/ext/IPC/SysV/const-xs.inc new file mode 100644 index 0000000000..5051fd06aa --- /dev/null +++ b/ext/IPC/SysV/const-xs.inc @@ -0,0 +1,90 @@ +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); + } diff --git a/ext/IPC/SysV/Msg.pm b/ext/IPC/SysV/lib/IPC/Msg.pm index 1edff3b2b7..cef85e8f05 100644 --- a/ext/IPC/SysV/Msg.pm +++ b/ext/IPC/SysV/lib/IPC/Msg.pm @@ -1,8 +1,18 @@ -# 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; @@ -11,9 +21,12 @@ use strict; 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; @@ -91,14 +104,14 @@ sub rcv { 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); } @@ -115,7 +128,7 @@ IPC::Msg - SysV Msg IPC object class 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)); @@ -146,8 +159,8 @@ C<KEY> is equal to C<IPC_PRIVATE> =item * -C<KEY> does not already have a message queue -associated with it, and C<I<FLAGS> & IPC_CREAT> is true. +C<KEY> does not already have a message queue associated with +it, and C<I<FLAGS> & IPC_CREAT> is true. =back @@ -212,17 +225,21 @@ of these fields see you system documentation. =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 diff --git a/ext/IPC/SysV/Semaphore.pm b/ext/IPC/SysV/lib/IPC/Semaphore.pm index 8717a93929..3b81f1a062 100644 --- a/ext/IPC/SysV/Semaphore.pm +++ b/ext/IPC/SysV/lib/IPC/Semaphore.pm @@ -1,8 +1,18 @@ -# 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; @@ -12,9 +22,12 @@ use strict; 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; @@ -89,7 +102,7 @@ sub op { @_ >= 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); } @@ -127,12 +140,12 @@ sub getall { 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); } @@ -157,7 +170,7 @@ IPC::Semaphore - SysV Semaphore IPC object class 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); @@ -192,7 +205,7 @@ C<KEY> is equal to C<IPC_PRIVATE> =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 @@ -287,16 +300,20 @@ of these fields see your system documentation. =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 diff --git a/ext/IPC/SysV/lib/IPC/SharedMem.pm b/ext/IPC/SysV/lib/IPC/SharedMem.pm new file mode 100644 index 0000000000..d4c8a5ac63 --- /dev/null +++ b/ext/IPC/SysV/lib/IPC/SharedMem.pm @@ -0,0 +1,276 @@ +################################################################################ +# +# $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 + diff --git a/ext/IPC/SysV/lib/IPC/SysV.pm b/ext/IPC/SysV/lib/IPC/SysV.pm new file mode 100644 index 0000000000..67eacaa96f --- /dev/null +++ b/ext/IPC/SysV/lib/IPC/SysV.pm @@ -0,0 +1,188 @@ +################################################################################ +# +# $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 + diff --git a/ext/IPC/SysV/regen.pl b/ext/IPC/SysV/regen.pl new file mode 100644 index 0000000000..776991298f --- /dev/null +++ b/ext/IPC/SysV/regen.pl @@ -0,0 +1,97 @@ +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"; +} diff --git a/ext/IPC/SysV/t/ipcsysv.t b/ext/IPC/SysV/t/ipcsysv.t index f0350de422..629e707d3c 100755 --- a/ext/IPC/SysV/t/ipcsysv.t +++ b/ext/IPC/SysV/t/ipcsysv.t @@ -1,43 +1,78 @@ +################################################################################ +# +# $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 @@ -48,45 +83,87 @@ See config(8). 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 @@ -101,104 +178,177 @@ to have more message queue resources. 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; } diff --git a/ext/IPC/SysV/t/msg.t b/ext/IPC/SysV/t/msg.t index e9e241b509..aca6a7dc5f 100755 --- a/ext/IPC/SysV/t/msg.t +++ b/ext/IPC/SysV/t/msg.t @@ -1,65 +1,109 @@ +################################################################################ +# +# $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; } diff --git a/ext/IPC/SysV/t/pod.t b/ext/IPC/SysV/t/pod.t new file mode 100644 index 0000000000..f9beefc50b --- /dev/null +++ b/ext/IPC/SysV/t/pod.t @@ -0,0 +1,70 @@ +################################################################################ +# +# $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); + } +} + diff --git a/ext/IPC/SysV/t/podcov.t b/ext/IPC/SysV/t/podcov.t new file mode 100644 index 0000000000..f607059558 --- /dev/null +++ b/ext/IPC/SysV/t/podcov.t @@ -0,0 +1,48 @@ +################################################################################ +# +# $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"); +} diff --git a/ext/IPC/SysV/t/sem.t b/ext/IPC/SysV/t/sem.t index 2fb594f52d..d51118c654 100755 --- a/ext/IPC/SysV/t/sem.t +++ b/ext/IPC/SysV/t/sem.t @@ -1,25 +1,38 @@ +################################################################################ +# +# $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( @@ -35,48 +48,52 @@ 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 diff --git a/ext/IPC/SysV/t/shm.t b/ext/IPC/SysV/t/shm.t new file mode 100644 index 0000000000..976b79225d --- /dev/null +++ b/ext/IPC/SysV/t/shm.t @@ -0,0 +1,96 @@ +################################################################################ +# +# $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'); + diff --git a/ext/IPC/SysV/typemap b/ext/IPC/SysV/typemap new file mode 100644 index 0000000000..e884838f20 --- /dev/null +++ b/ext/IPC/SysV/typemap @@ -0,0 +1,2 @@ +TYPEMAP +const char * T_PV diff --git a/mkppport.lst b/mkppport.lst index 0e37e5e7dd..2230cecc00 100644 --- a/mkppport.lst +++ b/mkppport.lst @@ -5,5 +5,6 @@ # This file is read by mkppport at build time. # +ext/IPC/SysV ext/Time/HiRes ext/Win32API/File |