fixes unpack("q"...), and semctl() tests for UNICOS

	Message-Id: <199806240855.LAA16152@alpha.hut.fi>
	Subject: [PATCH] 5.004_68: semctl() in UNICOS (was: pack/unpack)

p4raw-id: //depot/perl@1233

diff --git a/pp.c b/pp.c
index 7d51e49..a0949a1 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3448,6 +3448,9 @@ PP(pp_unpack)
            break;
 #ifdef HAS_QUAD
        case 'q':
+           along = (strend - s) / sizeof(Quad_t);
+           if (len > along)
+               len = along;
            EXTEND(SP, len);
            EXTEND_MORTAL(len);
            while (len-- > 0) {
@@ -3466,6 +3469,9 @@ PP(pp_unpack)
            }
            break;
        case 'Q':
+           along = (strend - s) / sizeof(Quad_t);
+           if (len > along)
+               len = along;
            EXTEND(SP, len);
            EXTEND_MORTAL(len);
            while (len-- > 0) {

diff --git a/t/op/ipcsem.t b/t/op/ipcsem.t
index 55e8104..a524674 100755 (executable)
--- a/t/op/ipcsem.t
+++ b/t/op/ipcsem.t
@@ -3,6 +3,7 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    $SIG{__DIE__} = 'cleanup';
 }
 
 my @define;
@@ -123,33 +124,65 @@ print "ok 2\n";
 print "not " unless length($data);
 print "ok 3\n";
 
-semctl($sem,0,$SETALL,pack("s*",(0) x 10)) or print "not ";
+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) {
+    foreach my $t (qw(i q)) { # Try quad last because not supported everywhere.
+       # 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;
+        }
+    }
+}
+
+die "$0: cannot pack native shorts\n" unless defined $template;
+
+$template .= "*";
+
+my $nsem = 10;
+
+semctl($sem,0,$SETALL,pack($template,(0) x $nsem)) or print "not ";
 print "ok 4\n";
 
 $data = "";
 semctl($sem,0,$GETALL,$data) or print "not ";
 print "ok 5\n";
 
-print "not " unless length($data);
+print "not " unless length($data) == length(pack($template,(0) x $nsem));
 print "ok 6\n";
 
-my @data = unpack("s*",$data);
+my @data = unpack($template,$data);
+
+my $adata = "0" x $nsem;
 
-print "not " unless join("",@data) eq "0000000000";
+print "not " unless @data == $nsem and join("",@data) eq $adata;
 print "ok 7\n";
 
-$data[2] = 1;
-semctl($sem,0,$SETALL,pack("s*",@data)) or print "not ";
+my $poke = 2;
+
+$data[$poke] = 1;
+semctl($sem,0,$SETALL,pack($template,@data)) or print "not ";
 print "ok 8\n";
 
 $data = "";
 semctl($sem,0,$GETALL,$data) or print "not ";
 print "ok 9\n";
 
-@data = unpack("s*",$data);
+@data = unpack($template,$data);
+
+my $bdata = "0" x $poke . "1" . "0" x ($nsem-$poke-1);
 
-print "not " unless join("",@data) eq "0010000000";
+print "not " unless join("",@data) eq $bdata;
 print "ok 10\n";
 
-semctl($sem,0,$IPC_RMID,undef);
+sub cleanup { semctl($sem,0,$IPC_RMID,undef) if defined $sem }
 
+cleanup;

diff --git a/t/op/pack.t b/t/op/pack.t
index de5fcff..b8aece6 100755 (executable)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -2,7 +2,7 @@
 
 # $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
 
-print "1..30\n";
+print "1..56\n";
 
 $format = "c2 x5 C C x s d i l a6";
 # Need the expression in here to force ary[5] to be numeric.  This avoids
@@ -106,3 +106,51 @@ print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n");
 # Test 30:
 print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n");
 
+# 31..36: test the pack lengths of s S i I l L
+print "not " unless length(pack("s", 0)) == 2;
+print "ok ", $test++, "\n";
+ 
+print "not " unless length(pack("S", 0)) == 2;
+print "ok ", $test++, "\n";
+ 
+print "not " unless length(pack("i", 0)) >= 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("I", 0)) >= 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("l", 0)) == 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("L", 0)) == 4;
+print "ok ", $test++, "\n";
+
+# 37..40: test the pack lengths of n N v V
+
+print "not " unless length(pack("n", 0)) == 2;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("N", 0)) == 4;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("v", 0)) == 2;
+print "ok ", $test++, "\n";
+
+print "not " unless length(pack("V", 0)) == 4;
+print "ok ", $test++, "\n";
+
+# 41..56: test unpack-pack lengths
+
+my @templates = qw(c C i I s S l L n N v V f d);
+
+# quads not supported everywhere: if not, retest floats/doubles
+# to preserve the test count...
+eval { my $q = pack("q",0) };
+push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d);
+
+foreach my $t (@templates) {
+    my @t = unpack("$t*", pack("$t*", 12, 34));
+    print "not "
+      unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i));
+    print "ok ", $test++, "\n";
+}