[PATCH] ext/IPC/SysV/t/ipcsysv.t using test.pl

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

p4raw-id: //depot/perl@28131

2 files changed, 149 insertions, 162 deletions

diff --git a/ext/IPC/SysV/t/ipcsysv.t b/ext/IPC/SysV/t/ipcsysv.t
index 795ad5d6c7..54bab4377a 100755
--- a/ext/IPC/SysV/t/ipcsysv.t
+++ b/ext/IPC/SysV/t/ipcsysv.t
@@ -1,25 +1,23 @@
-#!./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.
@@ -28,22 +26,18 @@ BEGIN {
 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
@@ -51,23 +45,31 @@ options         SYSVSEM
 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;
@@ -77,142 +79,125 @@ if ($Config{'d_msgget'} eq 'define' &&
     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;
diff --git a/ext/IPC/SysV/t/sem.t b/ext/IPC/SysV/t/sem.t
index d506519804..d7f89d28c6 100755
--- a/ext/IPC/SysV/t/sem.t
+++ b/ext/IPC/SysV/t/sem.t
@@ -1,23 +1,23 @@
 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(
@@ -33,43 +33,45 @@ 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');
+    }
 }