1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
|
#!./perl
# $RCSfile: pack.t,v $$Revision: 4.1 $$Date: 92/08/07 18:28:11 $
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
# test2 failing because ary2 goes str->numeric->str and ary doesn't.
@ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef");
$foo = pack($format,@ary);
@ary2 = unpack($format,$foo);
print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n");
$out1=join(':',@ary);
$out2=join(':',@ary2);
print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n");
print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n");
# How about counting bits?
print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16
? "ok 4\n" : "not ok 4 $x\n";
print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12
? "ok 5\n" : "not ok 5 $x\n";
print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9
? "ok 6\n" : "not ok 6 $x\n";
print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == 129
? "ok 7\n" : "not ok 7 $x\n";
open(BIN, "./perl") || open(BIN, "./perl.exe")
|| die "Can't open ../perl or ../perl.exe: $!\n";
sysread BIN, $foo, 8192;
close BIN;
$sum = unpack("%32b*", $foo);
$longway = unpack("b*", $foo);
print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n";
print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF
? "ok 9\n" : "not ok 9 $x\n";
# check 'w'
my $test=10;
my @x = (5,130,256,560,32000,3097152,268435455,1073741844,
'4503599627365785','23728385234614992549757750638446');
my $x = pack('w*', @x);
my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e';
print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++;
@y = unpack('w*', $y);
my $a;
while ($a = pop @x) {
my $b = pop @y;
print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++;
}
@y = unpack('w2', $x);
print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++;
print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++;
# test exeptions
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff};
print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff};
print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff};
print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++;
#
# test the "p" template
# literals
print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n");
# scalars
print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n");
# temps
sub foo { my $a = "a"; return $a . $a++ . $a++ }
{
local $^W = 1;
my $last = $test;
local $SIG{__WARN__} = sub {
print "ok ",$test++,"\n" if $_[0] =~ /temporary val/
};
my $junk = pack("p", &foo);
print "not ok ", $test++, "\n" if $last == $test;
}
# undef should give null pointer
print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n");
# Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives
# 4294967295 instead of -1)
# see #ifdef __osf__ in pp.c pp_unpack
# 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";
}
|
