Commit | Line | Data |
d50dd4e4 |
1 | #!./perl -w |
a687059c |
2 | |
bf80f5a2 |
3 | print "1..613\n"; |
fa8ec7c1 |
4 | |
a1a0e61e |
5 | BEGIN { |
6 | chdir 't' if -d 't'; |
20822f61 |
7 | @INC = '../lib'; |
b23b8711 |
8 | } |
9 | |
fa8ec7c1 |
10 | use strict; |
11 | use warnings; |
b23b8711 |
12 | use Config; |
13 | |
fa8ec7c1 |
14 | my $Is_EBCDIC = (defined $Config{ebcdic} && $Config{ebcdic} eq 'define'); |
b23b8711 |
15 | |
16 | my $test = 1; |
fa8ec7c1 |
17 | # Using Test considered bad plan in op/*.t ? |
c274e827 |
18 | |
fa8ec7c1 |
19 | sub encode { |
20 | my @result = @_; |
b85d93de |
21 | foreach (@result) { |
22 | s/([[:cntrl:]\177 ])/sprintf "\\%03o", ord $1/ge if defined; |
23 | } |
fa8ec7c1 |
24 | @result; |
25 | } |
17639bde |
26 | |
b85d93de |
27 | sub encode_list { |
28 | my @result = @_; |
29 | foreach (@result) { |
30 | if (defined) { |
31 | s/([[:cntrl:]\177])/sprintf "\\%03o", ord $1/ge; |
32 | $_ = qq("$_"); |
33 | } else { |
34 | $_ = 'undef'; |
35 | } |
36 | } |
37 | if (@result == 1) { |
38 | return @result; |
39 | } |
40 | return '(' . join (', ', @result) . ')'; |
41 | } |
42 | |
fa8ec7c1 |
43 | sub ok { |
44 | my ($pass, $wrong, $err) = @_; |
45 | if ($pass) { |
46 | print "ok $test\n"; |
b23b8711 |
47 | $test++; |
fa8ec7c1 |
48 | return 1; |
49 | } else { |
50 | if ($err) { |
51 | chomp $err; |
7eed2ccc |
52 | print "not ok $test # $err\n"; |
fa8ec7c1 |
53 | } else { |
54 | if (defined $wrong) { |
55 | $wrong = ", got $wrong"; |
56 | } else { |
57 | $wrong = ''; |
58 | } |
59 | printf "not ok $test # line %d$wrong\n", (caller)[2]; |
60 | } |
61 | } |
62 | $test++; |
63 | return; |
a1a0e61e |
64 | } |
65 | |
b85d93de |
66 | sub list_eq ($$) { |
67 | my ($l, $r) = @_; |
68 | return unless @$l == @$r; |
69 | for my $i (0..$#$l) { |
70 | if (defined $l->[$i]) { |
71 | return unless defined ($r->[$i]) && $l->[$i] eq $r->[$i]; |
72 | } else { |
73 | return if defined $r->[$i] |
74 | } |
75 | } |
76 | return 1; |
77 | } |
78 | |
79 | ############################################################################## |
80 | # |
81 | # Here starteth the tests |
82 | # |
83 | |
fa8ec7c1 |
84 | { |
85 | my $format = "c2 x5 C C x s d i l a6"; |
450a55e4 |
86 | # Need the expression in here to force ary[5] to be numeric. This avoids |
87 | # test2 failing because ary2 goes str->numeric->str and ary doesn't. |
fa8ec7c1 |
88 | my @ary = (1,-100,127,128,32767,987.654321098 / 100.0,12345,123456,"abcdef"); |
89 | my $foo = pack($format,@ary); |
90 | my @ary2 = unpack($format,$foo); |
a687059c |
91 | |
b23b8711 |
92 | ok($#ary == $#ary2); |
a687059c |
93 | |
fa8ec7c1 |
94 | my $out1=join(':',@ary); |
95 | my $out2=join(':',@ary2); |
ae165b0c |
96 | # Using long double NVs may introduce greater accuracy than wanted. |
658bbd66 |
97 | $out1 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; |
c4ab3e64 |
98 | $out2 =~ s/:9\.87654321097999\d*:/:9.87654321098:/; |
b23b8711 |
99 | ok($out1 eq $out2); |
a687059c |
100 | |
b23b8711 |
101 | ok($foo =~ /def/); |
fa8ec7c1 |
102 | } |
79072805 |
103 | # How about counting bits? |
104 | |
fa8ec7c1 |
105 | { |
106 | my $x; |
b23b8711 |
107 | ok( ($x = unpack("%32B*", "\001\002\004\010\020\040\100\200\377")) == 16 ); |
79072805 |
108 | |
b23b8711 |
109 | ok( ($x = unpack("%32b69", "\001\002\004\010\020\040\100\200\017")) == 12 ); |
79072805 |
110 | |
b23b8711 |
111 | ok( ($x = unpack("%32B69", "\001\002\004\010\020\040\100\200\017")) == 9 ); |
fa8ec7c1 |
112 | } |
79072805 |
113 | |
fa8ec7c1 |
114 | { |
9d116dd7 |
115 | my $sum = 129; # ASCII |
b23b8711 |
116 | $sum = 103 if $Is_EBCDIC; |
9d116dd7 |
117 | |
fa8ec7c1 |
118 | my $x; |
b23b8711 |
119 | ok( ($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum ); |
79072805 |
120 | |
fa8ec7c1 |
121 | my $foo; |
95e8664e |
122 | open(BIN, "./perl") || open(BIN, "./perl.exe") || open(BIN, $^X) |
b8440792 |
123 | || die "Can't open ../perl or ../perl.exe: $!\n"; |
79072805 |
124 | sysread BIN, $foo, 8192; |
125 | close BIN; |
126 | |
127 | $sum = unpack("%32b*", $foo); |
fa8ec7c1 |
128 | my $longway = unpack("b*", $foo); |
b23b8711 |
129 | ok( $sum == $longway =~ tr/1/1/ ); |
fa8ec7c1 |
130 | } |
73a1c01a |
131 | |
fa8ec7c1 |
132 | { |
133 | my $x; |
134 | ok( ($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF ); |
135 | } |
def98dd4 |
136 | |
fa8ec7c1 |
137 | { |
def98dd4 |
138 | # check 'w' |
2e821511 |
139 | my @x = (5,130,256,560,32000,3097152,268435455,1073741844, 2**33, |
55497cff |
140 | '4503599627365785','23728385234614992549757750638446'); |
def98dd4 |
141 | my $x = pack('w*', @x); |
2e821511 |
142 | my $y = pack 'H*', '0581028200843081fa0081bd8440ffffff7f8480808014A08080800087ffffffffffdb19caefe8e1eeeea0c2e1e3e8ede1ee6e'; |
def98dd4 |
143 | |
fa8ec7c1 |
144 | ok ($x eq $y, unpack 'H*', $x); |
145 | my @y = unpack('w*', $y); |
55497cff |
146 | my $a; |
147 | while ($a = pop @x) { |
148 | my $b = pop @y; |
fa8ec7c1 |
149 | ok ($a eq $b, "\$a='$a' \$b='$b'"); |
55497cff |
150 | } |
def98dd4 |
151 | |
152 | @y = unpack('w2', $x); |
153 | |
fa8ec7c1 |
154 | ok (scalar(@y) == 2); |
155 | ok ($y[1] == 130, $y[1]); |
156 | } |
def98dd4 |
157 | |
fa8ec7c1 |
158 | { |
159 | # test exeptions |
160 | my $x; |
161 | eval { $x = unpack 'w', pack 'C*', 0xff, 0xff}; |
162 | ok ($@ =~ /^Unterminated compressed integer/, undef, $@); |
def98dd4 |
163 | |
fa8ec7c1 |
164 | eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff}; |
165 | ok ($@ =~ /^Unterminated compressed integer/, undef, $@); |
def98dd4 |
166 | |
fa8ec7c1 |
167 | eval { $x = unpack 'w', pack 'C*', 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff}; |
168 | ok ($@ =~ /^Unterminated compressed integer/, undef, $@); |
169 | } |
def98dd4 |
170 | |
84902520 |
171 | # |
172 | # test the "p" template |
173 | |
174 | # literals |
fa8ec7c1 |
175 | ok(unpack("p",pack("p","foo")) eq "foo"); |
84902520 |
176 | |
177 | # scalars |
fa8ec7c1 |
178 | ok(unpack("p",pack("p",$test)) == $test); |
84902520 |
179 | |
180 | # temps |
181 | sub foo { my $a = "a"; return $a . $a++ . $a++ } |
182 | { |
9f1b1f2d |
183 | use warnings; |
84902520 |
184 | my $last = $test; |
185 | local $SIG{__WARN__} = sub { |
186 | print "ok ",$test++,"\n" if $_[0] =~ /temporary val/ |
187 | }; |
188 | my $junk = pack("p", &foo); |
189 | print "not ok ", $test++, "\n" if $last == $test; |
190 | } |
191 | |
192 | # undef should give null pointer |
fa8ec7c1 |
193 | ok (pack("p", undef) =~ /^\0+/); |
84902520 |
194 | |
20408e3c |
195 | # Check for optimizer bug (e.g. Digital Unix GEM cc with -O4 on DU V4.0B gives |
196 | # 4294967295 instead of -1) |
197 | # see #ifdef __osf__ in pp.c pp_unpack |
198 | # Test 30: |
fa8ec7c1 |
199 | ok((unpack("i",pack("i",-1))) == -1, "__osf__ like bug seems to exist"); |
20408e3c |
200 | |
d4217c7e |
201 | # 31..36: test the pack lengths of s S i I l L |
d4217c7e |
202 | # 37..40: test the pack lengths of n N v V |
fa8ec7c1 |
203 | my @lengths = qw(s 2 S 2 i -4 I -4 l 4 L 4 n 2 N 4 v 2 V 4); |
204 | while (my ($format, $expect) = splice @lengths, 0, 2) { |
205 | my $len = length(pack($format, 0)); |
206 | if ($expect > 0) { |
207 | ok ($expect == $len, "format '$format' has length $len, expected $expect"); |
208 | } else { |
209 | $expect = -$expect; |
210 | ok ($len >= $expect, |
211 | "format '$format' has length $len, expected >= $expect"); |
212 | } |
213 | } |
d4217c7e |
214 | |
215 | # 41..56: test unpack-pack lengths |
216 | |
217 | my @templates = qw(c C i I s S l L n N v V f d); |
218 | |
219 | # quads not supported everywhere: if not, retest floats/doubles |
220 | # to preserve the test count... |
221 | eval { my $q = pack("q",0) }; |
222 | push @templates, $@ !~ /Invalid type in pack/ ? qw(q Q) : qw(f d); |
223 | |
224 | foreach my $t (@templates) { |
225 | my @t = unpack("$t*", pack("$t*", 12, 34)); |
fa8ec7c1 |
226 | ok ((@t == 2 and (($t[0] == 12 and $t[1] == 34) or ($t =~ /[nv]/i))), |
227 | "unpack-pack length for '$t' failed; \@t=@t"); |
d4217c7e |
228 | } |
9d116dd7 |
229 | |
fa8ec7c1 |
230 | { |
eddc390b |
231 | # 57..60: uuencode/decode |
9d116dd7 |
232 | |
ef54e1a4 |
233 | # Note that first uuencoding known 'text' data and then checking the |
234 | # binary values of the uuencoded version would not be portable between |
235 | # character sets. Uuencoding is meant for encoding binary data, not |
236 | # text data. |
c4d5f83a |
237 | |
fa8ec7c1 |
238 | my $in = pack 'C*', 0 .. 255; |
ba1ac976 |
239 | |
240 | # just to be anal, we do some random tr/`/ / |
fa8ec7c1 |
241 | my $uu = <<'EOUU'; |
ba1ac976 |
242 | M` $"`P0%!@<("0H+# T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL |
9d116dd7 |
243 | M+2XO,#$R,S0U-C<X.3H[/#T^/T!!0D-$149'2$E*2TQ-3D]045)35%565UA9 |
244 | M6EM<75Y?8&%B8V1E9F=H:6IK;&UN;W!Q<G-T=79W>'EZ>WQ]?G^`@8*#A(6& |
245 | MAXB)BHN,C8Z/D)&2DY25EI>8F9J;G)V>GZ"AHJ.DI::GJ*FJJZRMKJ^PL;*S |
246 | MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R<K+S,W.S]#1TM/4U=;7V-G:V]S=WM_@ |
ba1ac976 |
247 | ?X>+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P ` |
9d116dd7 |
248 | EOUU |
249 | |
ba1ac976 |
250 | $_ = $uu; |
251 | tr/ /`/; |
9d116dd7 |
252 | |
fa8ec7c1 |
253 | ok (pack('u', $in) eq $_); |
254 | |
255 | ok (unpack('u', $uu) eq $in); |
9d116dd7 |
256 | |
eddc390b |
257 | $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"; |
258 | $uu = <<'EOUU'; |
259 | M'XL("%C<Q#4"`TI!4%4`\RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>("`&1F |
260 | &8%P:```` |
261 | EOUU |
262 | |
fa8ec7c1 |
263 | ok unless unpack('u', $uu); |
eddc390b |
264 | |
265 | # 60 identical to 59 except that backquotes have been changed to spaces |
266 | |
267 | $uu = <<'EOUU'; |
268 | M'XL("%C<Q#4" TI!4%4 \RHM+E%(S,LOR4@M4@A(+<I1*"U-SD])+>(" &1F |
c4d5f83a |
269 | &8%P: |
eddc390b |
270 | EOUU |
271 | |
fa8ec7c1 |
272 | # ' # Grr |
273 | ok (unpack('u', $uu) eq $in); |
ef54e1a4 |
274 | |
d99ad34e |
275 | } |
726ea183 |
276 | |
fa8ec7c1 |
277 | # 61..73: test the ascii template types (A, a, Z) |
726ea183 |
278 | |
fa8ec7c1 |
279 | foreach ( |
280 | ['p', 'A*', "foo\0bar\0 ", "foo\0bar\0 "], |
281 | ['p', 'A11', "foo\0bar\0 ", "foo\0bar\0 "], |
282 | ['u', 'A*', "foo\0bar \0", "foo\0bar"], |
283 | ['u', 'A8', "foo\0bar \0", "foo\0bar"], |
284 | ['p', 'a*', "foo\0bar\0 ", "foo\0bar\0 "], |
285 | ['p', 'a11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], |
286 | ['u', 'a*', "foo\0bar \0", "foo\0bar \0"], |
287 | ['u', 'a8', "foo\0bar \0", "foo\0bar "], |
288 | ['p', 'Z*', "foo\0bar\0 ", "foo\0bar\0 \0"], |
289 | ['p', 'Z11', "foo\0bar\0 ", "foo\0bar\0 \0\0"], |
290 | ['p', 'Z3', "foo", "fo\0"], |
291 | ['u', 'Z*', "foo\0bar \0", "foo"], |
292 | ['u', 'Z8', "foo\0bar \0", "foo"], |
293 | ) { |
294 | my ($what, $template, $in, $out) = @$_; |
295 | my $got = $what eq 'u' ? (unpack $template, $in) : (pack $template, $in); |
296 | unless (ok ($got eq $out)) { |
297 | ($in, $out, $got) = encode ($in, $out, $got); |
298 | my $un = $what eq 'u' ? 'un' : ''; |
299 | print "# ${un}pack ('$template', \"$in\") gave $out not $got\n"; |
300 | } |
d99ad34e |
301 | } |
726ea183 |
302 | |
fa8ec7c1 |
303 | # 74..79: packing native shorts/ints/longs |
726ea183 |
304 | |
fa8ec7c1 |
305 | ok (length(pack("s!", 0)) == $Config{shortsize}); |
306 | ok (length(pack("i!", 0)) == $Config{intsize}); |
307 | ok (length(pack("l!", 0)) == $Config{longsize}); |
308 | ok (length(pack("s!", 0)) <= length(pack("i!", 0))); |
309 | ok (length(pack("i!", 0)) <= length(pack("l!", 0))); |
310 | ok (length(pack("i!", 0)) == length(pack("i", 0))); |
726ea183 |
311 | |
fa8ec7c1 |
312 | sub numbers { |
313 | my $format = shift; |
314 | return numbers_with_total ($format, undef, @_); |
d99ad34e |
315 | } |
726ea183 |
316 | |
fa8ec7c1 |
317 | sub numbers_with_total { |
318 | my $format = shift; |
319 | my $total = shift; |
320 | if (!defined $total) { |
321 | foreach (@_) { |
322 | $total += $_; |
323 | } |
324 | } |
325 | foreach (@_) { |
326 | my $out = eval {unpack($format, pack($format, $_))}; |
327 | if ($@ =~ /Invalid type in pack: '$format'/) { |
328 | print "ok $test # skip cannot pack '$format' on this perl\n"; |
329 | } elsif ($out == $_) { |
330 | print "ok $test\n"; |
331 | } else { |
332 | print "not ok $test # unpack '$format', pack '$format', $_ gives $out\n"; |
333 | print "# \$\@='$@'\n" if $@; |
334 | } |
335 | $test++; |
336 | } |
726ea183 |
337 | |
fa8ec7c1 |
338 | my $skip_if_longer_than = ~0; # "Infinity" |
339 | if (~0 - 1 == ~0) { |
340 | # If we're running with -DNO_PERLPRESERVE_IVUV and NVs don't preserve all |
341 | # UVs (in which case ~0 is NV, ~0-1 will be the same NV) then we can't |
342 | # correctly in perl calculate UV totals for long checksums, as pp_unpack |
343 | # is using UV maths, and we've only got NVs. |
344 | $skip_if_longer_than = $Config{d_nv_preserves_uv_bits}; |
345 | } |
726ea183 |
346 | |
fa8ec7c1 |
347 | foreach ('', 1, 2, 3, 15, 16, 17, 31, 32, 33, 53, 54, 63, 64, 65) { |
348 | my $sum = eval {unpack "%$_$format*", pack "$format*", @_}; |
349 | if (!defined $sum) { |
350 | if ($@ =~ /Invalid type in pack: '$format'/) { |
351 | print "ok $test # skip cannot pack '$format' on this perl\n"; |
352 | } else { |
353 | print "not ok $test # \$\@='$@'\n" if $@; |
354 | } |
355 | next; |
356 | } |
357 | my $len = $_; # Copy, so that we can reassign '' |
358 | $len = 16 unless length $len; |
43192e07 |
359 | |
fa8ec7c1 |
360 | if ($len > $skip_if_longer_than) { |
361 | print "ok $test # skip cannot test checksums over $skip_if_longer_than " |
362 | ."bits for this perl (compiled with -DNO_PERLPRESERVE_IVUV)\n"; |
363 | next; |
364 | } |
43192e07 |
365 | |
fa8ec7c1 |
366 | # Our problem with testing this portably is that the checksum code in |
367 | # pp_unpack is able to cast signed to unsigned, and do modulo 2**n |
368 | # arithmetic in unsigned ints, which perl has no operators to do. |
369 | # (use integer; does signed ints, which won't wrap on UTS, which is just |
370 | # fine with ANSI, but not with most people's assumptions. |
371 | # This is why we need to supply the totals for 'Q' as there's no way in |
372 | # perl to calculate them, short of unpack '%0Q' (is that documented?) |
373 | # ** returns NVs; make sure it's IV. |
374 | my $max = 1 + 2 * (int (2 ** ($len-1))-1); # The maximum possible checksum |
375 | my $max_p1 = $max + 1; |
376 | my ($max_is_integer, $max_p1_is_integer); |
377 | $max_p1_is_integer = 1 unless $max_p1 + 1 == $max_p1; |
378 | $max_is_integer = 1 if $max - 1 < ~0; |
379 | |
380 | my $calc_sum; |
800e6488 |
381 | if (ref $total) { |
382 | $calc_sum = &$total($len); |
fa8ec7c1 |
383 | } else { |
384 | $calc_sum = $total; |
385 | # Shift into range by some multiple of the total |
386 | my $mult = int ($total / $max_p1); |
387 | # Need this to make sure that -1 + (~0+1) is ~0 (ie still integer) |
388 | $calc_sum = $total - $mult; |
389 | $calc_sum -= $mult * $max; |
390 | if ($calc_sum < 0) { |
391 | $calc_sum += 1; |
392 | $calc_sum += $max; |
393 | } |
394 | } |
395 | if ($calc_sum == $calc_sum - 1 && $calc_sum == $max_p1) { |
396 | # we're into floating point (either by getting out of the range of |
397 | # UV arithmetic, or because we're doing a floating point checksum) and |
398 | # our calculation of the checksum has become rounded up to |
399 | # max_checksum + 1 |
400 | $calc_sum = 0; |
401 | } |
2e821511 |
402 | |
fa8ec7c1 |
403 | if ($calc_sum == $sum) { |
404 | print "ok $test # unpack '%$_$format' gave $sum\n"; |
2e821511 |
405 | } else { |
fa8ec7c1 |
406 | my $delta = 1.000001; |
407 | if ($format =~ tr /dDfF// |
408 | && ($calc_sum <= $sum * $delta && $calc_sum >= $sum / $delta)) { |
409 | print "ok $test # unpack '%$_$format' gave $sum," |
410 | . " expected $calc_sum\n"; |
411 | } else { |
412 | print "not ok $test # For list (" . join (", ", @_) . ") (total $total)" |
413 | . " packed with $format unpack '%$_$format' gave $sum," |
414 | . " expected $calc_sum\n"; |
415 | } |
2e821511 |
416 | } |
fa8ec7c1 |
417 | } continue { |
418 | $test++; |
2e821511 |
419 | } |
420 | } |
421 | |
fa8ec7c1 |
422 | numbers ('c', -128, -1, 0, 1, 127); |
423 | numbers ('C', 0, 1, 127, 128, 255); |
424 | numbers ('s', -32768, -1, 0, 1, 32767); |
425 | numbers ('S', 0, 1, 32767, 32768, 65535); |
426 | numbers ('i', -2147483648, -1, 0, 1, 2147483647); |
427 | numbers ('I', 0, 1, 2147483647, 2147483648, 4294967295); |
428 | numbers ('l', -2147483648, -1, 0, 1, 2147483647); |
429 | numbers ('L', 0, 1, 2147483647, 2147483648, 4294967295); |
430 | numbers ('s!', -32768, -1, 0, 1, 32767); |
431 | numbers ('S!', 0, 1, 32767, 32768, 65535); |
432 | numbers ('i!', -2147483648, -1, 0, 1, 2147483647); |
433 | numbers ('I!', 0, 1, 2147483647, 2147483648, 4294967295); |
434 | numbers ('l!', -2147483648, -1, 0, 1, 2147483647); |
435 | numbers ('L!', 0, 1, 2147483647, 2147483648, 4294967295); |
436 | numbers ('n', 0, 1, 32767, 32768, 65535); |
437 | numbers ('v', 0, 1, 32767, 32768, 65535); |
438 | numbers ('N', 0, 1, 2147483647, 2147483648, 4294967295); |
439 | numbers ('V', 0, 1, 2147483647, 2147483648, 4294967295); |
440 | # All these should have exact binary representations: |
441 | numbers ('f', -1, 0, 0.5, 42, 2**34); |
b85d93de |
442 | numbers ('d', -(2**34), -1, 0, 1, 2**34); |
443 | ## These don't, but 'd' is NV. XXX wrong, it's double |
444 | #numbers ('d', -1, 0, 1, 1-exp(-1), -exp(1)); |
fa8ec7c1 |
445 | |
446 | numbers_with_total ('q', -1, |
447 | -9223372036854775808, -1, 0, 1,9223372036854775807); |
800e6488 |
448 | # This total is icky, but the true total is 2**65-1, and need a way to generate |
449 | # the epxected checksum on any system including those where NVs can preserve |
450 | # 65 bits. (long double is 128 bits on sparc, so they certainly can) |
451 | # or where rounding is down not up on binary conversion (crays) |
452 | numbers_with_total ('Q', sub { |
453 | my $len = shift; |
454 | $len = 65 if $len > 65; # unmasked total is 2**65-1 here |
455 | my $total = 1 + 2 * (int (2**($len - 1)) - 1); |
456 | return 0 if $total == $total - 1; # Overflowed integers |
457 | return $total; # NVs still accurate to nearest integer |
458 | }, |
fa8ec7c1 |
459 | 0, 1,9223372036854775807, 9223372036854775808, |
460 | 18446744073709551615); |
461 | |
462 | # pack nvNV byteorders |
463 | |
464 | ok (pack("n", 0xdead) eq "\xde\xad"); |
465 | ok (pack("v", 0xdead) eq "\xad\xde"); |
466 | ok (pack("N", 0xdeadbeef) eq "\xde\xad\xbe\xef"); |
467 | ok (pack("V", 0xdeadbeef) eq "\xef\xbe\xad\xde"); |
43192e07 |
468 | |
fa8ec7c1 |
469 | { |
470 | # / |
471 | |
472 | my ($x, $y, $z); |
473 | eval { ($x) = unpack '/a*','hello' }; |
474 | ok ($@ =~ m!/ must follow a numeric type!, undef, $@); |
475 | eval { ($z,$x,$y) = unpack 'a3/A C/a* C/Z', "003ok \003yes\004z\000abc" }; |
476 | ok ($z eq 'ok'); |
477 | ok ($x eq 'yes'); |
478 | ok ($y eq 'z'); |
479 | ok ($@ eq '', undef, $@); |
480 | |
481 | eval { ($x) = pack '/a*','hello' }; |
482 | ok ($@ =~ m!Invalid type in pack: '/'!, undef, $@); |
483 | |
484 | $z = pack 'n/a* N/Z* w/A*','string','hi there ','etc'; |
485 | my $expect = "\000\006string\0\0\0\012hi there \000\003etc"; |
486 | unless (ok ($z eq $expect)) { |
487 | printf "# got '%s'\n", encode $z; |
488 | } |
4b5b2118 |
489 | |
b85d93de |
490 | $expect = 'hello world'; |
491 | eval { ($x) = unpack ("w/a", chr (11) . "hello world!")}; |
492 | ok ($x eq $expect); |
493 | ok ($@ eq '', undef, $@); |
494 | # Doing this in scalar context used to fail. |
495 | eval { $x = unpack ("w/a", chr (11) . "hello world!")}; |
496 | unless (ok ($x eq $expect, undef, $@)) { |
497 | printf "# expected '$expect' got '%s'\n", encode $x; |
498 | } |
499 | ok ($@ eq '', undef, $@); |
500 | |
fa8ec7c1 |
501 | foreach ( |
502 | ['a/a*/a*', '212ab345678901234567','ab3456789012'], |
503 | ['a/a*/a*', '3012ab345678901234567', 'ab3456789012'], |
504 | ['a/a*/b*', '212ab', $Is_EBCDIC ? '100000010100' : '100001100100'], |
505 | ) { |
506 | my ($pat, $in, $expect) = @$_; |
507 | eval { ($x) = unpack $pat, $in }; |
b85d93de |
508 | ok ($@ eq '' && $x eq $expect, undef, $@) |
509 | or printf "# list unpack ('$pat', '$in') gave %s, expected '$expect'\n", |
510 | encode_list ($x); |
511 | eval { $x = unpack $pat, $in }; |
512 | ok ($@ eq '' && $x eq $expect, undef, $@) |
513 | or printf "# scalar unpack ('$pat', '$in') gave %s, expected '$expect'\n", |
514 | encode_list ($x); |
fa8ec7c1 |
515 | } |
4b5b2118 |
516 | |
fa8ec7c1 |
517 | # / with # |
17f4a12d |
518 | |
519 | eval { ($z,$x,$y) = unpack <<EOU, "003ok \003yes\004z\000abc" }; |
520 | a3/A # Count in ASCII |
521 | C/a* # Count in a C char |
522 | C/Z # Count in a C char but skip after \0 |
523 | EOU |
fa8ec7c1 |
524 | ok ($z eq 'ok'); |
525 | ok ($x eq 'yes'); |
526 | ok ($y eq 'z'); |
527 | ok ($@ eq '', undef, $@); |
17f4a12d |
528 | |
529 | $z = pack <<EOP,'string','etc'; |
530 | n/a* # Count as network short |
531 | w/A* # Count a BER integer |
532 | EOP |
fa8ec7c1 |
533 | $expect = "\000\006string\003etc"; |
534 | unless (ok ($z eq $expect)) { |
535 | $z = encode $z; |
536 | print "# got '$z', expected '$expect'\n"; |
537 | } |
538 | } |
539 | |
540 | ok ("1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000)); |
541 | ok ("1.20.300.4000" eq sprintf "%vd", pack(" U*",1,20,300,4000)); |
542 | ok (v1.20.300.4000 ne sprintf "%vd", pack("C0U*",1,20,300,4000)); |
543 | |
544 | ok (join(" ", unpack("C*", chr(0x1e2))) eq ((ord("A") == 193) ? "156 67" |
545 | : "199 162")); |
546 | |
547 | # does pack U create Unicode? |
548 | ok (ord(pack('U', 300)) == 300); |
549 | |
550 | # does unpack U deref Unicode? |
551 | ok ((unpack('U', chr(300)))[0] == 300); |
552 | |
553 | # is unpack U the reverse of pack U for Unicode string? |
554 | ok ("@{[unpack('U*', pack('U*', 100, 200, 300))]}" eq "100 200 300"); |
555 | |
556 | # is unpack U the reverse of pack U for byte string? |
557 | ok ("@{[unpack('U*', pack('U*', 100, 200))]}" eq "100 200"); |
558 | |
2dcec3fe |
559 | if (ord('A') == 193) { |
560 | ok(1, undef, "skipped") for 1..4; # EBCDIC |
561 | } else { |
7eed2ccc |
562 | # does unpack C unravel pack U? |
563 | ok ("@{[unpack('C*', pack('U*', 100, 200))]}" eq "100 195 136"); |
fa8ec7c1 |
564 | |
7eed2ccc |
565 | # does pack U0C create Unicode? |
566 | ok ("@{[pack('U0C*', 100, 195, 136)]}" eq v100.v200); |
fa8ec7c1 |
567 | |
7eed2ccc |
568 | # does pack C0U create characters? |
569 | ok ("@{[pack('C0U*', 100, 200)]}" eq pack("C*", 100, 195, 136)); |
fa8ec7c1 |
570 | |
2dcec3fe |
571 | # does unpack U0U on byte data warn? |
572 | { |
573 | local $SIG{__WARN__} = sub { $@ = "@_" }; |
574 | my @null = unpack('U0U', chr(255)); |
575 | ok ($@ =~ /^Malformed UTF-8 character /, undef, $@); |
576 | } |
35bcd338 |
577 | } |
578 | |
fa8ec7c1 |
579 | { |
580 | my $p = pack 'i*', -2147483648, ~0, 0, 1, 2147483647; |
581 | my (@a); |
582 | # bug - % had to be at the start of the pattern, no leading whitespace or |
583 | # comments. %i! didn't work at all. |
584 | foreach my $pat ('%32i*', ' %32i*', "# Muhahahaha\n%32i*", '%32i* ', |
585 | '%32i!*', ' %32i!*', "\n#\n#\n\r \t\f%32i!*", '%32i!*#') { |
586 | @a = unpack $pat, $p; |
587 | ok ($a[0] == 0xFFFFFFFF, "$pat failed"); |
588 | @a = scalar unpack $pat, $p; |
589 | ok ($a[0] == 0xFFFFFFFF, "$pat failed in scalar context"); |
590 | } |
591 | |
592 | |
593 | $p = pack 'I*', 42, 12; |
594 | # Multiline patterns in scalar context failed. |
595 | foreach my $pat ('I', <<EOPOEMSNIPPET, 'I#I', 'I # I', 'I # !!!') { |
596 | # On the Ning Nang Nong |
597 | # Where the Cows go Bong! |
598 | # And the Monkeys all say Boo! |
599 | I |
600 | EOPOEMSNIPPET |
601 | @a = unpack $pat, $p; |
602 | ok (@a == 1 && $a[0] == 42); |
603 | @a = scalar unpack $pat, $p; |
604 | ok (@a == 1 && $a[0] == 42); |
605 | } |
606 | |
607 | # shorts (of all flavours) didn't calculate checksums > 32 bits with floating |
608 | # point, so a pathologically long pattern would wrap at 32 bits. |
609 | my $pat = "\xff\xff"x65538; # Start with it long, to save any copying. |
610 | foreach (4,3,2,1,0) { |
611 | my $len = 65534 + $_; |
612 | ok (unpack ("%33n$len", $pat) == 65535 * $len); |
613 | } |
614 | } |
b85d93de |
615 | |
616 | |
617 | # pack x X @ |
618 | foreach ( |
619 | ['x', "N", "\0"], |
620 | ['x4', "N", "\0"x4], |
621 | ['xX', "N", ""], |
622 | ['xXa*', "Nick", "Nick"], |
623 | ['a5Xa5', "cameL", "llama", "camellama"], |
624 | ['@4', 'N', "\0"x4], |
625 | ['a*@8a*', 'Camel', 'Dromedary', "Camel\0\0\0Dromedary"], |
626 | ['a*@4a', 'Perl rules', '!', 'Perl!'], |
627 | ) { |
628 | my ($template, @in) = @$_; |
629 | my $out = pop @in; |
630 | my $got = eval {pack $template, @in}; |
631 | ok ($@ eq '' and $out eq $got, '', $@) |
632 | or printf "# pack ('$template', %s) gave %s expected %s\n", |
633 | encode_list (@in), encode_list ($got), encode_list ($out); |
634 | } |
635 | |
636 | # unpack x X @ |
637 | foreach ( |
638 | ['x', "N"], |
639 | ['xX', "N"], |
640 | ['xXa*', "Nick", "Nick"], |
641 | ['a5Xa5', "camellama", "camel", "llama"], |
642 | ['@3', "ice"], |
643 | ['@2a2', "water", "te"], |
644 | ['a*@1a3', "steam", "steam", "tea"], |
645 | ) { |
646 | my ($template, $in, @out) = @$_; |
647 | my @got = eval {unpack $template, $in}; |
648 | ok (($@ eq '' and list_eq (\@got, \@out)), undef, $@) |
649 | or printf "# list unpack ('$template', \"%s\") gave %s expected %s\n", |
650 | encode ($in), encode_list (@got), encode_list (@out); |
651 | |
652 | my $got = eval {unpack $template, $in}; |
653 | ok (($@ eq '' and @out ? $got eq $out[0] # 1 or more items; should get first |
654 | : !defined $got) # 0 items; should get undef |
655 | , "", $@) |
656 | or printf "# scalar unpack ('$template', \"%s\") gave %s expected %s\n", |
657 | encode ($in), encode_list ($got), encode_list ($out[0]); |
658 | } |
d50dd4e4 |
659 | |
660 | { |
661 | # 611 |
662 | my $t = 'Z*Z*'; |
663 | my ($u, $v) = qw(foo xyzzy); |
664 | my $p = pack($t, $u, $v); |
665 | my @u = unpack($t, $p); |
01af4f20 |
666 | ok(@u == 2 && $u[0] eq $u && $u[1] eq $v); |
d50dd4e4 |
667 | } |
bf80f5a2 |
668 | |
669 | { |
670 | # 612 |
671 | |
672 | ok((unpack("w/a*", "\x02abc"))[0] eq "ab"); |
673 | |
674 | # 613: "w/a*" should be seen as one unit |
675 | |
676 | ok(scalar unpack("w/a*", "\x02abc") eq "ab"); |
677 | } |