Commit | Line | Data |
---|---|---|
a687059c LW |
1 | #!./perl |
2 | ||
a1a0e61e TD |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
93430cb4 | 5 | unshift @INC, '../lib' if -d '../lib'; |
a1a0e61e TD |
6 | require Config; import Config; |
7 | } | |
8 | ||
726ea183 | 9 | print "1..98\n"; |
a687059c | 10 | |
bbdab043 | 11 | $format = "c2 x5 C C x s d i l a6"; |
450a55e4 LW |
12 | # Need the expression in here to force ary[5] to be numeric. This avoids |
13 | # test2 failing because ary2 goes str->numeric->str and ary doesn't. | |
14 | @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef"); | |
a687059c LW |
15 | $foo = pack($format,@ary); |
16 | @ary2 = unpack($format,$foo); | |
17 | ||
18 | print ($#ary == $#ary2 ? "ok 1\n" : "not ok 1\n"); | |
19 | ||
20 | $out1=join(':',@ary); | |
21 | $out2=join(':',@ary2); | |
22 | print ($out1 eq $out2 ? "ok 2\n" : "not ok 2\n"); | |
23 | ||
24 | print ($foo =~ /def/ ? "ok 3\n" : "not ok 3\n"); | |
79072805 LW |
25 | |
26 | # How about counting bits? | |
27 | ||
28 | print +($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16 | |
29 | ? "ok 4\n" : "not ok 4 $x\n"; | |
30 | ||
31 | print +($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 | |
32 | ? "ok 5\n" : "not ok 5 $x\n"; | |
33 | ||
34 | print +($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 | |
35 | ? "ok 6\n" : "not ok 6 $x\n"; | |
36 | ||
9d116dd7 | 37 | my $sum = 129; # ASCII |
a1a0e61e | 38 | $sum = 103 if ($Config{ebcdic} eq 'define'); |
9d116dd7 JH |
39 | |
40 | print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum | |
79072805 LW |
41 | ? "ok 7\n" : "not ok 7 $x\n"; |
42 | ||
b8440792 IZ |
43 | open(BIN, "./perl") || open(BIN, "./perl.exe") |
44 | || die "Can't open ../perl or ../perl.exe: $!\n"; | |
79072805 LW |
45 | sysread BIN, $foo, 8192; |
46 | close BIN; | |
47 | ||
48 | $sum = unpack("%32b*", $foo); | |
49 | $longway = unpack("b*", $foo); | |
50 | print $sum == $longway =~ tr/1/1/ ? "ok 8\n" : "not ok 8\n"; | |
73a1c01a KA |
51 | |
52 | print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF | |
53 | ? "ok 9\n" : "not ok 9 $x\n"; | |
def98dd4 UP |
54 | |
55 | # check 'w' | |
56 | my $test=10; | |
55497cff | 57 | my @x = (5,130,256,560,32000,3097152,268435455,1073741844, |
58 | '4503599627365785','23728385234614992549757750638446'); | |
def98dd4 | 59 | my $x = pack('w*', @x); |
55497cff | 60 | my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f848080801487ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; |
def98dd4 UP |
61 | |
62 | print $x eq $y ? "ok $test\n" : "not ok $test\n"; $test++; | |
63 | ||
64 | @y = unpack('w*', $y); | |
55497cff | 65 | my $a; |
66 | while ($a = pop @x) { | |
67 | my $b = pop @y; | |
68 | print $a eq $b ? "ok $test\n" : "not ok $test\n$a\n$b\n"; $test++; | |
69 | } | |
def98dd4 UP |
70 | |
71 | @y = unpack('w2', $x); | |
72 | ||
73 | print scalar(@y) == 2 ? "ok $test\n" : "not ok $test\n"; $test++; | |
74 | print $y[1] == 130 ? "ok $test\n" : "not ok $test\n"; $test++; | |
75 | ||
55497cff | 76 | # test exeptions |
def98dd4 UP |
77 | eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; |
78 | print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; | |
79 | ||
80 | eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; | |
81 | print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; | |
82 | ||
83 | eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; | |
84 | print $@ ne '' ? "ok $test\n" : "not ok $test\n"; $test++; | |
85 | ||
84902520 TB |
86 | # |
87 | # test the "p" template | |
88 | ||
89 | # literals | |
90 | print((unpack("p",pack("p","foo")) eq "foo" ? "ok " : "not ok "),$test++,"\n"); | |
91 | ||
92 | # scalars | |
93 | print((unpack("p",pack("p",$test)) == $test ? "ok " : "not ok "),$test++,"\n"); | |
94 | ||
95 | # temps | |
96 | sub foo { my $a = "a"; return $a . $a++ . $a++ } | |
97 | { | |
98 | local $^W = 1; | |
99 | my $last = $test; | |
100 | local $SIG{__WARN__} = sub { | |
101 | print "ok ",$test++,"\n" if $_[0] =~ /temporary val/ | |
102 | }; | |
103 | my $junk = pack("p", &foo); | |
104 | print "not ok ", $test++, "\n" if $last == $test; | |
105 | } | |
106 | ||
107 | # undef should give null pointer | |
108 | print((pack("p", undef) =~ /^\0+/ ? "ok " : "not ok "),$test++,"\n"); | |
109 | ||
20408e3c GS |
110 | # Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives |
111 | # 4294967295 instead of -1) | |
112 | # see #ifdef __osf__ in pp.c pp_unpack | |
113 | # Test 30: | |
114 | print( ((unpack("i",pack("i",-1))) == -1 ? "ok " : "not ok "),$test++,"\n"); | |
115 | ||
d4217c7e JH |
116 | # 31..36: test the pack lengths of s S i I l L |
117 | print "not " unless length(pack("s", 0)) == 2; | |
118 | print "ok ", $test++, "\n"; | |
119 | ||
120 | print "not " unless length(pack("S", 0)) == 2; | |
121 | print "ok ", $test++, "\n"; | |
122 | ||
123 | print "not " unless length(pack("i", 0)) >= 4; | |
124 | print "ok ", $test++, "\n"; | |
125 | ||
126 | print "not " unless length(pack("I", 0)) >= 4; | |
127 | print "ok ", $test++, "\n"; | |
128 | ||
129 | print "not " unless length(pack("l", 0)) == 4; | |
130 | print "ok ", $test++, "\n"; | |
131 | ||
132 | print "not " unless length(pack("L", 0)) == 4; | |
133 | print "ok ", $test++, "\n"; | |
134 | ||
135 | # 37..40: test the pack lengths of n N v V | |
136 | ||
137 | print "not " unless length(pack("n", 0)) == 2; | |
138 | print "ok ", $test++, "\n"; | |
139 | ||
140 | print "not " unless length(pack("N", 0)) == 4; | |
141 | print "ok ", $test++, "\n"; | |
142 | ||
143 | print "not " unless length(pack("v", 0)) == 2; | |
144 | print "ok ", $test++, "\n"; | |
145 | ||
146 | print "not " unless length(pack("V", 0)) == 4; | |
147 | print "ok ", $test++, "\n"; | |
148 | ||
149 | # 41..56: test unpack-pack lengths | |
150 | ||
151 | my @templates = qw(c C i I s S l L n N v V f d); | |
152 | ||
153 | # quads not supported everywhere: if not, retest floats/doubles | |
154 | # to preserve the test count... | |
155 | eval { my $q = pack("q",0) }; | |
156 | push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d); | |
157 | ||
158 | foreach my $t (@templates) { | |
159 | my @t = unpack("$t*", pack("$t*", 12, 34)); | |
160 | print "not " | |
161 | unless @t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i)); | |
162 | print "ok ", $test++, "\n"; | |
163 | } | |
9d116dd7 | 164 | |
eddc390b | 165 | # 57..60: uuencode/decode |
9d116dd7 | 166 | |
ef54e1a4 JH |
167 | # Note that first uuencoding known 'text' data and then checking the |
168 | # binary values of the uuencoded version would not be portable between | |
169 | # character sets. Uuencoding is meant for encoding binary data, not | |
170 | # text data. | |
171 | ||
342930fb | 172 | $in = pack 'C*', 0 .. 255; |
ba1ac976 GS |
173 | |
174 | # just to be anal, we do some random tr/`/ / | |
9d116dd7 | 175 | $uu = <<'EOUU'; |
ba1ac976 | 176 | M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL |
9d116dd7 JH |
177 | M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9 |
178 | M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6& | |
179 | MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S | |
180 | MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@ | |
ba1ac976 | 181 | ?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P ` |
9d116dd7 JH |
182 | EOUU |
183 | ||
ba1ac976 GS |
184 | $_ = $uu; |
185 | tr/ /`/; | |
186 | print "not " unless pack('u', $in) eq $_; | |
9d116dd7 JH |
187 | print "ok ", $test++, "\n"; |
188 | ||
189 | print "not " unless unpack('u', $uu) eq $in; | |
190 | print "ok ", $test++, "\n"; | |
191 | ||
eddc390b JH |
192 | $in = "\x1f\x8b\x08\x08\x58\xdc\xc4\x35\x02\x03\x4a\x41\x50\x55\x00\xf3\x2a\x2d\x2e\x51\x48\xcc\xcb\x2f\xc9\x48\x2d\x52\x08\x48\x2d\xca\x51\x28\x2d\x4d\xce\x4f\x49\x2d\xe2\x02\x00\x64\x66\x60\x5c\x1a\x00\x00\x00"; |
193 | $uu = <<'EOUU'; | |
194 | M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F | |
195 | &8%P:```` | |
196 | EOUU | |
197 | ||
198 | print "not " unless unpack('u', $uu) eq $in; | |
199 | print "ok ", $test++, "\n"; | |
200 | ||
201 | # 60 identical to 59 except that backquotes have been changed to spaces | |
202 | ||
203 | $uu = <<'EOUU'; | |
204 | M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F | |
205 | &8%P: | |
206 | EOUU | |
207 | ||
208 | print "not " unless unpack('u', $uu) eq $in; | |
209 | print "ok ", $test++, "\n"; | |
210 | ||
ef54e1a4 | 211 | # 61..72: test the ascii template types (A, a, Z) |
5a929a98 VU |
212 | |
213 | print "not " unless pack('A*', "foo\0bar\0 ") eq "foo\0bar\0 "; | |
214 | print "ok ", $test++, "\n"; | |
215 | ||
216 | print "not " unless pack('A11', "foo\0bar\0 ") eq "foo\0bar\0 "; | |
217 | print "ok ", $test++, "\n"; | |
218 | ||
219 | print "not " unless unpack('A*', "foo\0bar \0") eq "foo\0bar"; | |
220 | print "ok ", $test++, "\n"; | |
221 | ||
222 | print "not " unless unpack('A8', "foo\0bar \0") eq "foo\0bar"; | |
223 | print "ok ", $test++, "\n"; | |
224 | ||
225 | print "not " unless pack('a*', "foo\0bar\0 ") eq "foo\0bar\0 "; | |
226 | print "ok ", $test++, "\n"; | |
227 | ||
228 | print "not " unless pack('a11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; | |
229 | print "ok ", $test++, "\n"; | |
230 | ||
231 | print "not " unless unpack('a*', "foo\0bar \0") eq "foo\0bar \0"; | |
232 | print "ok ", $test++, "\n"; | |
233 | ||
234 | print "not " unless unpack('a8', "foo\0bar \0") eq "foo\0bar "; | |
235 | print "ok ", $test++, "\n"; | |
236 | ||
237 | print "not " unless pack('Z*', "foo\0bar\0 ") eq "foo\0bar\0 "; | |
238 | print "ok ", $test++, "\n"; | |
239 | ||
240 | print "not " unless pack('Z11', "foo\0bar\0 ") eq "foo\0bar\0 \0\0"; | |
241 | print "ok ", $test++, "\n"; | |
242 | ||
243 | print "not " unless unpack('Z*', "foo\0bar \0") eq "foo"; | |
244 | print "ok ", $test++, "\n"; | |
245 | ||
246 | print "not " unless unpack('Z8', "foo\0bar \0") eq "foo"; | |
247 | print "ok ", $test++, "\n"; | |
248 | ||
726ea183 | 249 | # 73..78: packing native shorts/ints/longs |
ef54e1a4 JH |
250 | |
251 | print "not " unless length(pack("s_", 0)) == $Config{shortsize}; | |
252 | print "ok ", $test++, "\n"; | |
253 | ||
254 | print "not " unless length(pack("i_", 0)) == $Config{intsize}; | |
255 | print "ok ", $test++, "\n"; | |
256 | ||
257 | print "not " unless length(pack("l_", 0)) == $Config{longsize}; | |
258 | print "ok ", $test++, "\n"; | |
259 | ||
260 | print "not " unless length(pack("s_", 0)) <= length(pack("i_", 0)); | |
261 | print "ok ", $test++, "\n"; | |
262 | ||
263 | print "not " unless length(pack("i_", 0)) <= length(pack("l_", 0)); | |
264 | print "ok ", $test++, "\n"; | |
265 | ||
266 | print "not " unless length(pack("i_", 0)) == length(pack("i", 0)); | |
267 | print "ok ", $test++, "\n"; | |
268 | ||
726ea183 JH |
269 | # 79..94: test the limits |
270 | ||
271 | print "not " unless unpack("c", pack("c", 127)) == 127; | |
272 | print "ok ", $test++, "\n"; | |
273 | ||
274 | print "not " unless unpack("c", pack("c", -128)) == -128; | |
275 | print "ok ", $test++, "\n"; | |
276 | ||
277 | print "not " unless unpack("C", pack("C", 255)) == 255; | |
278 | print "ok ", $test++, "\n"; | |
279 | ||
280 | print "not " unless unpack("s", pack("s", 32767)) == 32767; | |
281 | print "ok ", $test++, "\n"; | |
282 | ||
283 | print "not " unless unpack("s", pack("s", -32768)) == -32768; | |
284 | print "ok ", $test++, "\n"; | |
285 | ||
286 | print "not " unless unpack("S", pack("S", 65535)) == 65535; | |
287 | print "ok ", $test++, "\n"; | |
288 | ||
289 | print "not " unless unpack("i", pack("i", 2147483647)) == 2147483647; | |
290 | print "ok ", $test++, "\n"; | |
291 | ||
292 | print "not " unless unpack("i", pack("i", -2147483648)) == -2147483648; | |
293 | print "ok ", $test++, "\n"; | |
294 | ||
295 | print "not " unless unpack("I", pack("I", 4294967295)) == 4294967295; | |
296 | print "ok ", $test++, "\n"; | |
297 | ||
298 | print "not " unless unpack("l", pack("l", 2147483647)) == 2147483647; | |
299 | print "ok ", $test++, "\n"; | |
300 | ||
301 | print "not " unless unpack("l", pack("l", -2147483648)) == -2147483648; | |
302 | print "ok ", $test++, "\n"; | |
303 | ||
304 | print "not " unless unpack("L", pack("L", 4294967295)) == 4294967295; | |
305 | print "ok ", $test++, "\n"; | |
306 | ||
307 | print "not " unless unpack("n", pack("n", 65535)) == 65535; | |
308 | print "ok ", $test++, "\n"; | |
309 | ||
310 | print "not " unless unpack("n", pack("v", 65535)) == 65535; | |
311 | print "ok ", $test++, "\n"; | |
312 | ||
313 | print "not " unless unpack("N", pack("N", 4294967295)) == 4294967295; | |
314 | print "ok ", $test++, "\n"; | |
315 | ||
316 | print "not " unless unpack("V", pack("V", 4294967295)) == 4294967295; | |
317 | print "ok ", $test++, "\n"; | |
318 | ||
319 | # 95..98 test the n/v/N/V byteorder | |
320 | ||
321 | if ($Config{byteorder} =~ /^1234(5678)?$/ || | |
322 | $Config{byteorder} =~ /^(8765)?4321$/) { | |
323 | ||
324 | print "not " unless pack("n", 0xdead) eq "\xde\xad"; | |
325 | print "ok ", $test++, "\n"; | |
326 | ||
327 | print "not " unless pack("v", 0xdead) eq "\xad\xde"; | |
328 | print "ok ", $test++, "\n"; | |
329 | ||
330 | print "not " unless pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"; | |
331 | print "ok ", $test++, "\n"; | |
332 | ||
333 | print "not " unless pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"; | |
334 | print "ok ", $test++, "\n"; | |
335 | ||
336 | } else { | |
337 | # weird byteorders require more thought | |
338 | foreach (95..98) { | |
339 | print "ok ", $test++, " # skipped\n"; | |
340 | } | |
341 | } | |
342 |