-#!./perl
-
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw(. ../lib);
require Config; import Config;
+ require 'test.pl';
+}
- my $reason;
-
- 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{'extensions'} !~ /\bIPC\/SysV\b/) {
+ skip_all('IPC::SysV was not built');
+}
+elsif ($Config{'d_sem'} ne 'define') {
+ skip_all('$Config{d_sem} undefined');
+}
+elsif ($Config{'d_msg'} ne 'define') {
+ skip_all('$Config{d_msg} undefined');
+}
+else {
+ plan( tests => 17 );
}
# These constants are common to all tests.
use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID S_IRWXU);
use strict;
-print "1..16\n";
-
my $msg;
my $sem;
-$SIG{__DIE__} = 'cleanup'; # will cleanup $msg and $sem if needed
-
# FreeBSD is known to throw this if there's no SysV IPC in the kernel.
$SIG{SYS} = sub {
- print STDERR <<EOM;
+ diag(<<EOM);
SIGSYS caught.
It may be that your kernel does not have SysV IPC configured.
EOM
if ($^O eq 'freebsd') {
- print STDERR <<EOM;
+ diag(<<EOM);
You must have following options in your kernel:
options SYSVSHM
options SYSVMSG
See config(8).
+
EOM
}
+ diag('Bail out! SIGSYS caught');
exit(1);
};
my $perm = S_IRWXU;
-if ($Config{'d_msgget'} eq 'define' &&
+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') {
+ $Config{'d_msgrcv'} eq 'define';
$msg = msgget(IPC_PRIVATE, $perm);
# Very first time called after machine is booted value may be 0
- die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
-
- print "ok 1\n";
+ if (!(defined($msg) && $msg >= 0)) {
+ skip( "msgget failed: $!", 6);
+ }
+ else {
+ pass('msgget IPC_PRIVATE S_IRWXU');
+ }
#Putting a message on the queue
my $msgtype = 1;
my $test5bad;
my $test6bad;
- unless (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
- print "not ";
- $test2bad = 1;
+ my $test_name = 'queue a message';
+ if (msgsnd($msg,pack("L! a*",$msgtype,$msgtext),IPC_NOWAIT)) {
+ pass($test_name);
}
- print "ok 2\n";
- if ($test2bad) {
- print <<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.
-#
+ 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;
- msgctl($msg,IPC_STAT,$data) or print "not ";
- print "ok 3\n";
+ ok(msgctl($msg,IPC_STAT,$data),'msgctl IPC_STAT call');
- print "not " unless length($data);
- print "ok 4\n";
+ cmp_ok(length($data),'>',0,'msgctl IPC_STAT data');
+ my $test_name = 'message get call';
my $msgbuf;
- unless (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
- print "not ";
- $test5bad = 1;
+ if (msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT)) {
+ pass($test_name);
+ }
+ else {
+ fail($test_name);
+ $test5bad = 1;
}
- print "ok 5\n";
if ($test5bad && $test2bad) {
- print <<EOM;
-#
-# This failure was to be expected because the subtest #2 failed.
-#
+ 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);
- unless ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
- print "not ";
- $test6bad = 1;
+ if ($rmsgtype == $msgtype && $rmsgtext eq $msgtext) {
+ pass($test_name);
+ }
+ else {
+ fail($test_name);
+ $test6bad = 1;
}
- print "ok 6\n";
if ($test6bad && $test2bad) {
- print <<EOM;
-#
-# This failure was to be expected because the subtest #2 failed.
-#
+ print <<EOM;
+This failure was to be expected because the subtest #2 failed.
EOM
}
-} else {
- for (1..6) {
- print "ok $_\n"; # fake it
- }
-}
+} # SKIP
-if($Config{'d_semget'} eq 'define' &&
- $Config{'d_semctl'} eq 'define') {
+SKIP: {
- if ($Config{'d_semctl_semid_ds'} eq 'define' ||
- $Config{'d_semctl_semun'} 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);
- $sem = semget(IPC_PRIVATE, 10, $perm | IPC_CREAT);
- # Very first time called after machine is booted value may be 0
- die "semget: $!\n" unless defined($sem) && $sem >= 0;
+ my $test_name = 'sem acquire';
+ $sem = semget(IPC_PRIVATE, 10, $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';
- print "ok 7\n";
+ # Very first time called after machine is booted value may be 0
+ die "semget: $!\n" unless defined($sem) && $sem >= 0;
+ }
- my $data;
- semctl($sem,0,IPC_STAT,$data) or print "not ";
- print "ok 8\n";
-
- print "not " unless length($data);
- print "ok 9\n";
+ my $data;
+ ok(semctl($sem,0,IPC_STAT,$data),'sem data call');
+
+ cmp_ok(length($data),'>',0,'sem data len');
- my $nsem = 10;
+ my $nsem = 10;
- semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)) or print "not ";
- print "ok 10\n";
+ ok(semctl($sem,0,SETALL,pack("s!*",(0) x $nsem)), 'set all sems');
- $data = "";
- semctl($sem,0,GETALL,$data) or print "not ";
- print "ok 11\n";
+ $data = "";
+ ok(semctl($sem,0,GETALL,$data), 'get all sems');
- print "not " unless length($data) == length(pack("s!*",(0) x $nsem));
- print "ok 12\n";
+ is(length($data),length(pack("s!*",(0) x $nsem)), 'right length');
- my @data = unpack("s!*",$data);
+ my @data = unpack("s!*",$data);
- my $adata = "0" x $nsem;
+ my $adata = "0" x $nsem;
- print "not " unless @data == $nsem and join("",@data) eq $adata;
- print "ok 13\n";
+ is(scalar(@data),$nsem,'right amount');
+ cmp_ok(join("",@data),'eq',$adata,'right data');
- my $poke = 2;
+ my $poke = 2;
- $data[$poke] = 1;
- semctl($sem,0,SETALL,pack("s!*",@data)) or print "not ";
- print "ok 14\n";
+ $data[$poke] = 1;
+ ok(semctl($sem,0,SETALL,pack("s!*",@data)),'poke it');
- $data = "";
- semctl($sem,0,GETALL,$data) or print "not ";
- print "ok 15\n";
+ $data = "";
+ ok(semctl($sem,0,GETALL,$data),'and get it back');
- @data = unpack("s!*",$data);
+ @data = unpack("s!*",$data);
+ my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
- my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
+ cmp_ok(join("",@data),'eq',$bdata,'changed');
+} # SKIP
- print "not " unless join("",@data) eq $bdata;
- print "ok 16\n";
- } else {
- for (7..16) {
- print "ok $_ # skipped, no semctl possible\n";
- }
- }
-} else {
- for (7..16) {
- print "ok $_\n"; # fake it
- }
-}
-
-sub cleanup {
+END {
msgctl($msg,IPC_RMID,0) if defined $msg;
semctl($sem,0,IPC_RMID,undef) if defined $sem;
}
-
-cleanup;
BEGIN {
chdir 't' if -d 't';
- @INC = '../lib';
+ @INC = qw(. ../lib);
require Config; import Config;
+ require 'test.pl';
+}
- my $reason;
-
- 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{'extensions'} !~ /\bIPC\/SysV\b/) {
+ skip_all('IPC::SysV was not built');
+}
+elsif ($Config{'d_sem'} ne 'define') {
+ skip_all('$Config{d_sem} undefined');
+}
+elsif ($Config{'d_msg'} ne 'define') {
+ skip_all('$Config{d_msg} undefined');
+}
+else {
+ plan( tests => 11 );
}
use IPC::SysV qw(
);
use IPC::Semaphore;
-print "1..10\n";
-
my $sem =
- new IPC::Semaphore(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT)
- || die "semget: ",$!+0," $!\n";
+ 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
+ diag("Bail out! cannot acquire a semaphore: $!");
+ exit(1);
+ }
+ else {
+ # unexpected error
+ die "semget: ",$!+0," $!\n";
+ }
+}
-print "ok 1\n";
+pass('acquired a semaphore');
-my $st = $sem->stat || print "not ";
-print "ok 2\n";
+ok(my $st = $sem->stat,'stat it');
-$sem->setall( (0) x 10) || print "not ";
-print "ok 3\n";
+ok($sem->setall( (0) x 10),'set all');
my @sem = $sem->getall;
-print "not " unless join("",@sem) eq "0000000000";
-print "ok 4\n";
+cmp_ok(join("",@sem),'eq',"0000000000",'get all');
$sem[2] = 1;
-$sem->setall( @sem ) || print "not ";
-print "ok 5\n";
+ok($sem->setall( @sem ),'set after change');
@sem = $sem->getall;
-print "not " unless join("",@sem) eq "0010000000";
-print "ok 6\n";
+cmp_ok(join("",@sem),'eq',"0010000000",'get again');
my $ncnt = $sem->getncnt(0);
-print "not " if $sem->getncnt(0) || !defined($ncnt);
-print "ok 7\n";
+ok(!$sem->getncnt(0),'procs waiting now');
+ok(defined($ncnt),'prev procs waiting');
-$sem->op(2,-1,IPC_NOWAIT) || print "not ";
-print "ok 8\n";
+ok($sem->op(2,-1,IPC_NOWAIT),'op nowait');
-print "not " if $sem->getncnt(0);
-print "ok 9\n";
+ok(!$sem->getncnt(0),'no procs waiting');
END {
- (defined $sem && $sem->remove) || print "not ";
- print "ok 10\n";
+ if ($sem) {
+ ok($sem->remove,'release');
+ }
}
projects / platform / upstream / perl.git / commitdiff