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