Commit | Line | Data |
---|---|---|
fafebdf5 A |
1 | #!./perl -- -*- mode: cperl; cperl-indent-level: 4 -*- |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
78cd8b71 | 6 | require Config; |
98641f60 | 7 | if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){ |
78cd8b71 NC |
8 | print "1..0 # Skip -- Perl configured without List::Util module\n"; |
9 | exit 0; | |
10 | } | |
fafebdf5 A |
11 | } |
12 | ||
13 | use strict; | |
14 | ||
15 | $|=1; | |
96b31d9e JH |
16 | |
17 | my @prgs; | |
18 | { | |
19 | local $/; | |
20 | @prgs = split "########\n", <DATA>; | |
21 | close DATA; | |
22 | } | |
23 | ||
24 | use Test::More; | |
25 | ||
26 | plan tests => scalar @prgs; | |
27 | ||
fafebdf5 A |
28 | require "dumpvar.pl"; |
29 | ||
f97a9a4b JH |
30 | sub unctrl { print dumpvar::unctrl($_[0]), "\n" } |
31 | sub uniescape { print dumpvar::uniescape($_[0]), "\n" } | |
32 | sub stringify { print dumpvar::stringify($_[0]), "\n" } | |
9bcb75ad | 33 | sub dumpvalue { |
2c227d66 | 34 | # Call main::dumpValue exactly as the perl5db.pl calls it. |
9bcb75ad JM |
35 | local $\ = ''; |
36 | local $, = ''; | |
37 | local $" = ' '; | |
38 | my @params = @_; | |
2c227d66 | 39 | &main::dumpValue(\@params,-1); |
9bcb75ad | 40 | } |
f97a9a4b JH |
41 | |
42 | package Foo; | |
43 | ||
44 | sub new { my $class = shift; bless [ @_ ], $class } | |
45 | ||
46 | package Bar; | |
47 | ||
48 | sub new { my $class = shift; bless [ @_ ], $class } | |
49 | ||
50 | use overload '""' => sub { "Bar<@{$_[0]}>" }; | |
51 | ||
6cee328e FC |
52 | package Tyre; |
53 | ||
54 | sub TIESCALAR{bless[]} | |
55 | # other methods intentionally omitted | |
56 | ||
f97a9a4b JH |
57 | package main; |
58 | ||
59 | my $foo = Foo->new(1..5); | |
60 | my $bar = Bar->new(1..5); | |
61 | ||
96b31d9e JH |
62 | for (@prgs) { |
63 | my($prog, $expected) = split(/\nEXPECT\n?/, $_); | |
f97a9a4b JH |
64 | # TODO: dumpvar::stringify() is controlled by a pile of package |
65 | # dumpvar variables: $printUndef, $unctrl, $quoteHighBit, $bareStringify, | |
66 | # and so forth. We need to test with various settings of those. | |
1d8663a3 | 67 | my $out = tie *STDOUT, 'TieOut'; |
fafebdf5 | 68 | eval $prog; |
96b31d9e | 69 | my $ERR = $@; |
1d8663a3 | 70 | untie $out; |
96b31d9e JH |
71 | if ($ERR) { |
72 | ok(0, "$prog - $ERR"); | |
73 | } else { | |
f97a9a4b | 74 | if ($expected =~ m:^/:) { |
1d8663a3 | 75 | like($$out, $expected, $prog); |
f97a9a4b | 76 | } else { |
1d8663a3 | 77 | is($$out, $expected, $prog); |
f97a9a4b | 78 | } |
96b31d9e | 79 | } |
fafebdf5 A |
80 | } |
81 | ||
1d8663a3 JH |
82 | package TieOut; |
83 | ||
84 | sub TIEHANDLE { | |
85 | bless( \(my $self), $_[0] ); | |
86 | } | |
87 | ||
88 | sub PRINT { | |
89 | my $self = shift; | |
90 | $$self .= join('', @_); | |
91 | } | |
92 | ||
93 | sub read { | |
94 | my $self = shift; | |
95 | substr( $$self, 0, length($$self), '' ); | |
96 | } | |
97 | ||
fafebdf5 | 98 | __END__ |
f97a9a4b JH |
99 | unctrl("A"); |
100 | EXPECT | |
101 | A | |
102 | ######## | |
103 | unctrl("\cA"); | |
104 | EXPECT | |
105 | ^A | |
106 | ######## | |
107 | uniescape("A"); | |
108 | EXPECT | |
109 | A | |
110 | ######## | |
111 | uniescape("\x{100}"); | |
112 | EXPECT | |
113 | \x{0100} | |
114 | ######## | |
115 | stringify(undef); | |
116 | EXPECT | |
117 | undef | |
118 | ######## | |
119 | stringify("foo"); | |
120 | EXPECT | |
121 | 'foo' | |
122 | ######## | |
123 | stringify("\cA"); | |
124 | EXPECT | |
125 | "\cA" | |
126 | ######## | |
127 | stringify(*a); | |
128 | EXPECT | |
129 | *main::a | |
130 | ######## | |
131 | stringify(\undef); | |
132 | EXPECT | |
133 | /^'SCALAR\(0x[0-9a-f]+\)'$/i | |
134 | ######## | |
135 | stringify([]); | |
136 | EXPECT | |
137 | /^'ARRAY\(0x[0-9a-f]+\)'$/i | |
138 | ######## | |
139 | stringify({}); | |
140 | EXPECT | |
141 | /^'HASH\(0x[0-9a-f]+\)'$/i | |
142 | ######## | |
143 | stringify(sub{}); | |
144 | EXPECT | |
145 | /^'CODE\(0x[0-9a-f]+\)'$/i | |
146 | ######## | |
147 | stringify(\*a); | |
148 | EXPECT | |
149 | /^'GLOB\(0x[0-9a-f]+\)'$/i | |
150 | ######## | |
151 | stringify($foo); | |
152 | EXPECT | |
153 | /^'Foo=ARRAY\(0x[0-9a-f]+\)'$/i | |
154 | ######## | |
155 | stringify($bar); | |
156 | EXPECT | |
157 | /^'Bar=ARRAY\(0x[0-9a-f]+\)'$/i | |
158 | ######## | |
159 | dumpValue(undef); | |
160 | EXPECT | |
161 | undef | |
162 | ######## | |
fafebdf5 A |
163 | dumpValue(1); |
164 | EXPECT | |
165 | 1 | |
166 | ######## | |
f97a9a4b JH |
167 | dumpValue("\cA"); |
168 | EXPECT | |
169 | "\cA" | |
170 | ######## | |
171 | dumpValue("\x{100}"); | |
172 | EXPECT | |
173 | '\x{0100}' | |
174 | ######## | |
fafebdf5 A |
175 | dumpValue("1\n2\n3"); |
176 | EXPECT | |
177 | '1 | |
178 | 2 | |
179 | 3' | |
180 | ######## | |
181 | dumpValue([1..3],1); | |
182 | EXPECT | |
183 | 0 1 | |
184 | 1 2 | |
185 | 2 3 | |
186 | ######## | |
2c227d66 JH |
187 | dumpValue([1..3]); |
188 | EXPECT | |
189 | 0 1 | |
190 | 1 2 | |
191 | 2 3 | |
192 | ######## | |
fafebdf5 A |
193 | dumpValue({1..4},1); |
194 | EXPECT | |
195 | 1 => 2 | |
196 | 3 => 4 | |
197 | ######## | |
2c227d66 JH |
198 | dumpValue({1..4}); |
199 | EXPECT | |
200 | 1 => 2 | |
201 | 3 => 4 | |
202 | ######## | |
f97a9a4b JH |
203 | dumpValue($foo,1); |
204 | EXPECT | |
205 | 0 1 | |
206 | 1 2 | |
207 | 2 3 | |
208 | 3 4 | |
209 | 4 5 | |
210 | ######## | |
2c227d66 JH |
211 | dumpValue($foo); |
212 | EXPECT | |
213 | 0 1 | |
214 | 1 2 | |
215 | 2 3 | |
216 | 3 4 | |
217 | 4 5 | |
218 | ######## | |
f97a9a4b JH |
219 | dumpValue($bar,1); |
220 | EXPECT | |
221 | 0 1 | |
222 | 1 2 | |
223 | 2 3 | |
224 | 3 4 | |
225 | 4 5 | |
226 | ######## | |
2c227d66 JH |
227 | dumpValue($bar); |
228 | EXPECT | |
229 | 0 1 | |
230 | 1 2 | |
231 | 2 3 | |
232 | 3 4 | |
233 | 4 5 | |
234 | ######## | |
9bcb75ad JM |
235 | dumpvalue("a"); |
236 | EXPECT | |
237 | 0 'a' | |
238 | ######## | |
239 | dumpvalue("\cA"); | |
240 | EXPECT | |
241 | 0 "\cA" | |
242 | ######## | |
243 | dumpvalue("\x{100}"); | |
244 | EXPECT | |
245 | 0 '\x{0100}' | |
246 | ######## | |
247 | dumpvalue(undef); | |
248 | EXPECT | |
249 | 0 undef | |
250 | ######## | |
251 | dumpvalue("foo"); | |
252 | EXPECT | |
253 | 0 'foo' | |
254 | ######## | |
255 | dumpvalue(\undef); | |
256 | EXPECT | |
257 | /0 SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i | |
258 | ######## | |
259 | dumpvalue(\\undef); | |
260 | EXPECT | |
261 | /0 REF\(0x[0-9a-f]+\)\n -> SCALAR\(0x[0-9a-f]+\)\n -> undef\n/i | |
262 | ######## | |
263 | dumpvalue([]); | |
264 | EXPECT | |
265 | /0 ARRAY\(0x[0-9a-f]+\)\n empty array/i | |
266 | ######## | |
267 | dumpvalue({}); | |
268 | EXPECT | |
269 | /0 HASH\(0x[0-9a-f]+\)\n\s+empty hash/i | |
270 | ######## | |
271 | dumpvalue(sub{}); | |
272 | EXPECT | |
273 | /0 CODE\(0x[0-9a-f]+\)\n -> &CODE\(0x[0-9a-f]+\) in /i | |
274 | ######## | |
275 | dumpvalue(\*a); | |
276 | EXPECT | |
277 | /0 GLOB\(0x[0-9a-f]+\)\n -> \*main::a\n/i | |
278 | ######## | |
279 | dumpvalue($foo); | |
280 | EXPECT | |
281 | /0 Foo=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i | |
282 | ######## | |
283 | dumpvalue($bar); | |
284 | EXPECT | |
285 | /0 Bar=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n 4 5\n/i | |
286 | ######## | |
287 | dumpvalue("1\n2\n3") | |
288 | EXPECT | |
289 | /0 '1\n2\n3'\n/i | |
290 | ######## | |
291 | dumpvalue([1..4]); | |
292 | EXPECT | |
293 | /0 ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i | |
294 | ######## | |
295 | dumpvalue({1..4}); | |
296 | EXPECT | |
297 | /0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i | |
298 | ######## | |
299 | dumpvalue({1=>2,3=>4}); | |
300 | EXPECT | |
301 | /0 HASH\(0x[0-9a-f]+\)\n 1 => 2\n 3 => 4\n/i | |
302 | ######## | |
303 | dumpvalue({a=>1,b=>2}); | |
304 | EXPECT | |
305 | /0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i | |
306 | ######## | |
307 | dumpvalue([{a=>[1,2,3],b=>{c=>1,d=>2}},{e=>{f=>1,g=>2},h=>[qw(i j k)]}]); | |
308 | EXPECT | |
309 | /0 ARRAY\(0x[0-9a-f]+\)\n 0 HASH\(0x[0-9a-f]+\)\n 'a' => ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 'b' => HASH\(0x[0-9a-f]+\)\n 'c' => 1\n 'd' => 2\n 1 HASH\(0x[0-9a-f]+\)\n 'e' => HASH\(0x[0-9a-f]+\)\n 'f' => 1\n 'g' => 2\n 'h' => ARRAY\(0x[0-9a-f]+\)\n 0 'i'\n 1 'j'\n 2 'k'/i | |
310 | ######## | |
311 | dumpvalue({reverse map {$_=>1} sort qw(the quick brown fox)}) | |
312 | EXPECT | |
313 | /0 HASH\(0x[0-9a-f]+\)\n 1 => 'brown'\n/i | |
314 | ######## | |
315 | my @x=qw(a b c); dumpvalue(\@x); | |
316 | EXPECT | |
317 | /0 ARRAY\(0x[0-9a-f]+\)\n 0 'a'\n 1 'b'\n 2 'c'\n/i | |
318 | ######## | |
319 | my %x=(a=>1, b=>2); dumpvalue(\%x); | |
320 | EXPECT | |
321 | /0 HASH\(0x[0-9a-f]+\)\n 'a' => 1\n 'b' => 2\n/i | |
d5dd42fa FC |
322 | ######## |
323 | dumpvalue(bless[1,2,3,4],"a=b=c"); | |
324 | EXPECT | |
325 | /0 a=b=c=ARRAY\(0x[0-9a-f]+\)\n 0 1\n 1 2\n 2 3\n 3 4\n/i | |
6cee328e FC |
326 | ######## |
327 | local *_; tie $_, 'Tyre'; stringify(''); | |
328 | EXPECT | |
329 | '' | |
330 | ######## | |
331 | local *_; tie $_, 'Tyre'; unctrl('abc'); | |
332 | EXPECT | |
333 | abc |