[perl #64772] allow for sync on read only handles
[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 main;
58
59 my $foo = Foo->new(1..5);
60 my $bar = Bar->new(1..5);
61
62 for (@prgs) {
63     my($prog, $expected) = split(/\nEXPECT\n?/, $_);
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.
67     my $out = tie *STDOUT, 'TieOut';
68     eval $prog;
69     my $ERR = $@;
70     untie $out;
71     if ($ERR) {
72         ok(0, "$prog - $ERR");
73     } else {
74         if ($expected =~ m:^/:) {
75             like($$out, $expected, $prog);
76         } else {
77             is($$out, $expected, $prog);
78         }
79     }
80 }
81
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
98 __END__
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 ########
163 dumpValue(1);
164 EXPECT
165 1
166 ########
167 dumpValue("\cA");
168 EXPECT
169 "\cA"
170 ########
171 dumpValue("\x{100}");
172 EXPECT
173 '\x{0100}'
174 ########
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 ########
187 dumpValue([1..3]);
188 EXPECT
189 0  1
190 1  2
191 2  3
192 ########
193 dumpValue({1..4},1);
194 EXPECT
195 1 => 2
196 3 => 4
197 ########
198 dumpValue({1..4});
199 EXPECT
200 1 => 2
201 3 => 4
202 ########
203 dumpValue($foo,1);
204 EXPECT
205 0  1
206 1  2
207 2  3
208 3  4
209 4  5
210 ########
211 dumpValue($foo);
212 EXPECT
213 0  1
214 1  2
215 2  3
216 3  4
217 4  5
218 ########
219 dumpValue($bar,1);
220 EXPECT
221 0  1
222 1  2
223 2  3
224 3  4
225 4  5
226 ########
227 dumpValue($bar);
228 EXPECT
229 0  1
230 1  2
231 2  3
232 3  4
233 4  5
234 ########
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
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
326 ########
327 local *_; tie $_, 'Tyre'; stringify('');
328 EXPECT
329 ''
330 ########
331 local *_; tie $_, 'Tyre'; unctrl('abc');
332 EXPECT
333 abc