summaryrefslogtreecommitdiff
path: root/gnu/usr.bin/perl/cpan/IPC-SysV/t
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/usr.bin/perl/cpan/IPC-SysV/t')
-rwxr-xr-xgnu/usr.bin/perl/cpan/IPC-SysV/t/ipcsysv.t350
-rwxr-xr-xgnu/usr.bin/perl/cpan/IPC-SysV/t/msg.t110
-rwxr-xr-xgnu/usr.bin/perl/cpan/IPC-SysV/t/pod.t70
-rwxr-xr-xgnu/usr.bin/perl/cpan/IPC-SysV/t/podcov.t48
-rwxr-xr-xgnu/usr.bin/perl/cpan/IPC-SysV/t/sem.t100
-rwxr-xr-xgnu/usr.bin/perl/cpan/IPC-SysV/t/shm.t97
6 files changed, 775 insertions, 0 deletions
diff --git a/gnu/usr.bin/perl/cpan/IPC-SysV/t/ipcsysv.t b/gnu/usr.bin/perl/cpan/IPC-SysV/t/ipcsysv.t
new file mode 100755
index 00000000000..8c167850ee4
--- /dev/null
+++ b/gnu/usr.bin/perl/cpan/IPC-SysV/t/ipcsysv.t
@@ -0,0 +1,350 @@
+################################################################################
+#
+# $Revision: 13 $
+# $Author: mhx $
+# $Date: 2008/11/28 18:08:11 +0100 $
+#
+################################################################################
+#
+# 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 {
+ 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_sem'} ne 'define') {
+ plan(skip_all => '$Config{d_sem} undefined');
+}
+elsif ($Config{'d_msg'} ne 'define') {
+ 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 $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);
+
+It may be that your kernel does not have SysV IPC configured.
+
+EOM
+
+ diag(<<EOM) if $^O eq 'freebsd';
+You must have following options in your kernel:
+
+options SYSVSHM
+options SYSVSEM
+options SYSVMSG
+
+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 ||
+ $why == &IPC::SysV::ENOMEM || $why == &IPC::SysV::EACCES) {
+ 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';
+
+ $msg = catchsig(sub { msgget(IPC_PRIVATE, $perm) });
+
+ # Very first time called after machine is booted value may be 0
+ unless (defined $msg && $msg >= 0) {
+ skip(skip_or_die('msgget', $!), 6);
+ }
+
+ pass('msgget IPC_PRIVATE S_IRWXU');
+
+ #Putting a message on the queue
+ my $msgtype = 1;
+ my $msgtext = "hello";
+
+ 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
+usually indicative of this situation. The error message was now:
+"$!"
+
+You can check the message queues with the 'ipcs' command and
+you can remove unneeded queues with the 'ipcrm -q id' command.
+You may also consider configuring your system or account
+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');
+
+ cmp_ok(length($data), '>', 0, 'msgctl IPC_STAT data');
+
+ $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
+ }
+
+ $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
+ }
+}
+
+my $sem;
+
+SKIP: {
+ 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);
+
+ # FreeBSD's default limit seems to be 9
+ my $nsem = 5;
+
+ $sem = catchsig(sub { semget(IPC_PRIVATE, $nsem, $perm | IPC_CREAT) });
+
+ # Very first time called after machine is booted value may be 0
+ unless (defined $sem && $sem >= 0) {
+ skip(skip_or_die('semget', $!), 11);
+ }
+
+ 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');
+
+ $data = "";
+ ok(semctl($sem, 0, GETALL, $data), 'get all sems');
+
+ is(length($data), length(pack("s$N*", (0) x $nsem)), 'right length');
+
+ my @data = unpack("s$N*", $data);
+
+ my $adata = "0" x $nsem;
+
+ is(scalar(@data), $nsem, 'right amount');
+ cmp_ok(join("", @data), 'eq', $adata, 'right data');
+
+ my $poke = 2;
+
+ $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';
+
+ use IPC::SysV qw(shmat shmdt memread memwrite ftok);
+
+ my $shm = catchsig(sub { shmget(IPC_PRIVATE, 4, S_IRWXU) });
+
+ # Very first time called after machine is booted value may be 0
+ unless (defined $shm && $shm >= 0) {
+ skip(skip_or_die('shmget', $!), 10);
+ }
+
+ pass("shm acquire");
+
+ 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, 0) if defined $sem;
+}
diff --git a/gnu/usr.bin/perl/cpan/IPC-SysV/t/msg.t b/gnu/usr.bin/perl/cpan/IPC-SysV/t/msg.t
new file mode 100755
index 00000000000..32dd9ffa752
--- /dev/null
+++ b/gnu/usr.bin/perl/cpan/IPC-SysV/t/msg.t
@@ -0,0 +1,110 @@
+################################################################################
+#
+# $Revision: 11 $
+# $Author: mhx $
+# $Date: 2008/11/28 18:08:11 +0100 $
+#
+################################################################################
+#
+# 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_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
+
+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 ||
+ $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
+ plan(skip_all => $info);
+ }
+ else {
+ die $info;
+ }
+}
+
+plan(tests => 9);
+
+pass('create message queue');
+
+#Putting a message on the queue
+my $test_name = 'enqueue message';
+
+my $msgtype = 1;
+my $msg = "hello";
+if ($msq->snd($msgtype,$msg,IPC_NOWAIT)) {
+ pass($test_name);
+}
+else {
+ print "# snd: $!\n";
+ fail($test_name);
+}
+
+#Check if there are messages on the queue
+my $ds = $msq->stat;
+ok($ds, 'stat');
+
+if ($ds) {
+ is($ds->qnum, 1, 'qnum');
+}
+else {
+ fail('qnum');
+}
+
+#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;
+ok($ds, 'stat');
+
+if ($ds) {
+ is($ds->qnum, 0, 'qnum');
+}
+else {
+ fail('qnum');
+}
+
+END {
+ ok($msq->remove, 'remove message') if defined $msq;
+}
diff --git a/gnu/usr.bin/perl/cpan/IPC-SysV/t/pod.t b/gnu/usr.bin/perl/cpan/IPC-SysV/t/pod.t
new file mode 100755
index 00000000000..f9beefc50b5
--- /dev/null
+++ b/gnu/usr.bin/perl/cpan/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/gnu/usr.bin/perl/cpan/IPC-SysV/t/podcov.t b/gnu/usr.bin/perl/cpan/IPC-SysV/t/podcov.t
new file mode 100755
index 00000000000..f6070595582
--- /dev/null
+++ b/gnu/usr.bin/perl/cpan/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/gnu/usr.bin/perl/cpan/IPC-SysV/t/sem.t b/gnu/usr.bin/perl/cpan/IPC-SysV/t/sem.t
new file mode 100755
index 00000000000..60fd039843e
--- /dev/null
+++ b/gnu/usr.bin/perl/cpan/IPC-SysV/t/sem.t
@@ -0,0 +1,100 @@
+################################################################################
+#
+# $Revision: 15 $
+# $Author: mhx $
+# $Date: 2008/11/28 18:08:11 +0100 $
+#
+################################################################################
+#
+# 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_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(
+ SETALL
+ IPC_PRIVATE
+ IPC_CREAT
+ IPC_RMID
+ IPC_NOWAIT
+ IPC_STAT
+ S_IRWXU
+ S_IRWXG
+ S_IRWXO
+);
+use IPC::Semaphore;
+
+# 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 ||
+ $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
+ 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 $nsem), 'set all');
+
+my @sem = $sem->getall;
+cmp_ok(join("", @sem), 'eq', "00000", 'get all');
+
+$sem[2] = 1;
+ok($sem->setall(@sem), 'set after change');
+
+@sem = $sem->getall;
+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->op(2, -1, IPC_NOWAIT), 'op nowait');
+
+ok(!$sem->getncnt(0), 'no procs waiting');
+
+END {
+ ok($sem->remove, 'remove semaphore') if defined $sem;
+}
diff --git a/gnu/usr.bin/perl/cpan/IPC-SysV/t/shm.t b/gnu/usr.bin/perl/cpan/IPC-SysV/t/shm.t
new file mode 100755
index 00000000000..f38f88eaa0b
--- /dev/null
+++ b/gnu/usr.bin/perl/cpan/IPC-SysV/t/shm.t
@@ -0,0 +1,97 @@
+################################################################################
+#
+# $Revision: 5 $
+# $Author: mhx $
+# $Date: 2008/11/28 18:08:11 +0100 $
+#
+################################################################################
+#
+# 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 ||
+ $! == &IPC::SysV::ENOMEM || $! == &IPC::SysV::EACCES) {
+ 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');
+
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-28 02:06:10 +0000