From: Jarkko Hietaniemi Date: Wed, 24 Jun 1998 11:55:09 +0000 (+0300) Subject: fixes unpack("q"...), and semctl() tests for UNICOS X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d4217c7e457268e98e8711256888e15d5de11f46;p=p5sagit%2Fp5-mst-13.2.git 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 --- 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 --- 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 --- 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"; +}