Commit | Line | Data |
a687059c |
1 | #!./perl |
2 | |
a1a0e61e |
3 | BEGIN { |
4 | chdir 't' if -d 't'; |
93430cb4 |
5 | unshift @INC, '../lib' if -d '../lib'; |
a1a0e61e |
6 | require Config; import Config; |
7 | } |
8 | |
ef54e1a4 |
9 | print "1..78\n"; |
a687059c |
10 | |
bbdab043 |
11 | $format = "c2 x5 C C x s d i l a6"; |
450a55e4 |
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 |
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 |
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 |
39 | |
40 | print +($x = unpack("%32B*", "Now is the time for all good blurfl")) == $sum |
79072805 |
41 | ? "ok 7\n" : "not ok 7 $x\n"; |
42 | |
b8440792 |
43 | open(BIN, "./perl") || open(BIN, "./perl.exe") |
44 | || die "Can't open ../perl or ../perl.exe: $!\n"; |
79072805 |
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 |
51 | |
52 | print +($x = unpack("I",pack("I", 0xFFFFFFFF))) == 0xFFFFFFFF |
53 | ? "ok 9\n" : "not ok 9 $x\n"; |
def98dd4 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
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 |
182 | EOUU |
183 | |
ba1ac976 |
184 | $_ = $uu; |
185 | tr/ /`/; |
186 | print "not " unless pack('u', $in) eq $_; |
9d116dd7 |
187 | print "ok ", $test++, "\n"; |
188 | |
189 | print "not " unless unpack('u', $uu) eq $in; |
190 | print "ok ", $test++, "\n"; |
191 | |
eddc390b |
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 |
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 | |
ef54e1a4 |
249 | # 73..77: packing native shorts/ints/longs |
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 | |