Update IPC SysV test from blead (hopefully is more graceful under duress)

git-svn-id: http://perl5005.googlecode.com/svn/trunk@10 e77bdc90-ac31-0410-a84a-cbf48518d05f

2 files changed, 129 insertions, 98 deletions

diff --git a/Changes b/Changes
index 44b4763d3b..f7064457b2 100644
--- a/Changes
+++ b/Changes
@@ -80,6 +80,12 @@ Version 5.005_04        Fourth maintenance release of 5.005
 
 
 ____________________________________________________________________________
+[      ] By: acme                                  on 2007/06/10  13:21:12
+        Log: Update IPC SysV test from blead (hopefully is more graceful
+             under duress)
+     Branch: maint-5.005/perl
+           ! t/lib/ipc_sysv.t
+____________________________________________________________________________
 [      ] By: acme                                  on 2007/06/10  13:05:58
         Log: Update perlbug email address to perlbug@perl.org
      Branch: maint-5.005/perl
diff --git a/t/lib/ipc_sysv.t b/t/lib/ipc_sysv.t
index 30ea48d999..ade423cb95 100755
--- a/t/lib/ipc_sysv.t
+++ b/t/lib/ipc_sysv.t
@@ -1,42 +1,43 @@
-#!./perl
-
 BEGIN {
     chdir 't' if -d 't';
 
-    @INC = '../lib';
+    @INC = qw(. ../lib);
 
     require Config; import Config;
+    require 'test.pl';
+}
 
-    unless ($Config{'d_msg'} eq 'define' &&
-	    $Config{'d_sem'} eq 'define') {
-	print "1..0\n";
-	exit;
-    }
+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.
 # Later the sem* tests will import more for themselves.
 
-use IPC::SysV qw(IPC_PRIVATE IPC_NOWAIT IPC_STAT IPC_RMID
-		 S_IRWXU S_IRWXG S_IRWXO);
+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
@@ -44,135 +45,159 @@ options         SYSVSEM
 options         SYSVMSG
 
 See config(8).
+
 EOM
     }
+    diag('Bail out! SIGSYS caught');
     exit(1);
 };
 
-if ($Config{'d_msgget'} eq 'define' &&
+my $perm = S_IRWXU;
+
+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 = msgget(IPC_PRIVATE, S_IRWXU | S_IRWXG | S_IRWXO);
-    # Very first time called after machine is booted value may be 0 
-    die "msgget failed: $!\n" unless defined($msg) && $msg >= 0;
+    $Config{'d_msgrcv'} eq 'define';
 
-    print "ok 1\n";
+    $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');
+    }
 
     #Putting a message on the queue
     my $msgtype = 1;
     my $msgtext = "hello";
 
-    msgsnd($msg,pack("L a*",$msgtype,$msgtext),0) or print "not ";
-    print "ok 2\n";
+    my $test2bad;
+    my $test5bad;
+    my $test6bad;
+
+    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);
+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;
-    msgrcv($msg,$msgbuf,256,0,IPC_NOWAIT) or print "not ";
-    print "ok 5\n";
-
-    my($rmsgtype,$rmsgtext) = unpack("L a*",$msgbuf);
-
-    print "not " unless($rmsgtype == $msgtype && $rmsgtext eq $msgtext);
-    print "ok 6\n";
-} else {
-    for (1..6) {
-	print "ok $_\n"; # fake it
+    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
     }
-}
 
-if($Config{'d_semget'} eq 'define' &&
-   $Config{'d_semctl'} eq 'define') {
+    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) {
+    print <<EOM;
+This failure was to be expected because the subtest #2 failed.
+EOM
+     }
+} # SKIP
 
-    use IPC::SysV qw(IPC_CREAT GETALL SETALL);
+SKIP: {
 
-    $sem = semget(IPC_PRIVATE, 10, S_IRWXU | S_IRWXG | S_IRWXO | IPC_CREAT);
-    # Very first time called after machine is booted value may be 0 
-    die "semget: $!\n" unless defined($sem) && $sem >= 0;
+    skip('lacking d_semget d_semctl', 11) unless
+        $Config{'d_semget'} eq 'define' &&
+        $Config{'d_semctl'} eq 'define';
 
-    print "ok 7\n";
+    use IPC::SysV qw(IPC_CREAT GETALL SETALL);
 
-    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 $template;
-
-    # Find the pack/unpack template capable of handling native C shorts.
-
-    if      ($Config{shortsize} == 2) {
-	$template = "s";
-    } elsif ($Config{shortsize} == 4) {
-	$template = "l";
-    } elsif ($Config{shortsize} == 8) {
-	# Try quad last because not supported everywhere.
-	foreach my $t (qw(i q)) {
-	    # We could trap the unsupported quad template with eval
-	    # but if we get this far we should have quad support anyway.
-	    if (length(pack($t, 0)) == 8) {
-		$template = $t;
-		last;
-	    }
-	}
+    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';
 
-    die "$0: cannot pack native shorts\n" unless defined $template;
+        # Very first time called after machine is booted value may be 0 
+        die "semget: $!\n" unless defined($sem) && $sem >= 0;
+    }
 
-    $template .= "*";
+    my $data;
+    ok(semctl($sem,0,IPC_STAT,$data),'sem data call');
+    
+    cmp_ok(length($data),'>',0,'sem data len');
 
     my $nsem = 10;
 
-    semctl($sem,0,SETALL,pack($template,(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";
+    ok(semctl($sem,0,GETALL,$data), 'get all sems');
 
-    print "not " unless length($data) == length(pack($template,(0) x $nsem));
-    print "ok 12\n";
+    is(length($data),length(pack("s*",(0) x $nsem)), 'right length');
 
-    my @data = unpack($template,$data);
+    my @data = unpack("s*",$data);
 
     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;
 
     $data[$poke] = 1;
-    semctl($sem,0,SETALL,pack($template,@data)) or print "not ";
-    print "ok 14\n";
+    ok(semctl($sem,0,SETALL,pack("s*",@data)),'poke it');
     
     $data = "";
-    semctl($sem,0,GETALL,$data) or print "not ";
-    print "ok 15\n";
-
-    @data = unpack($template,$data);
+    ok(semctl($sem,0,GETALL,$data),'and get it back');
 
+    @data = unpack("s*",$data);
     my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
 
-    print "not " unless join("",@data) eq $bdata;
-    print "ok 16\n";
-} else {
-    for (7..16) {
-	print "ok $_\n"; # fake it
-    }
-}
+    cmp_ok(join("",@data),'eq',$bdata,'changed');
+} # SKIP
 
-sub cleanup {
+END {
     msgctl($msg,IPC_RMID,0)       if defined $msg;
     semctl($sem,0,IPC_RMID,undef) if defined $sem;
 }
-
-cleanup;