1BEGIN {
2    require Config;
3    if (($Config::Config{'extensions'} !~ m!\bList/Util\b!) ){
4        print "1..0 # Skip -- Perl configured without List::Util module\n";
5        exit 0;
6    }
7
8    # `make test` in the CPAN version of this module runs us with -w, but
9    # Dumpvalue.pm relies on all sorts of things that can cause warnings. I
10    # don't think that's worth fixing, so we just turn off all warnings
11    # during testing.
12    $^W = 0;
13}
14
15use strict;
16use warnings;
17use lib ("./t/lib");
18use TieOut;
19use Test::More qw(no_plan); # tests => 17;
20use List::Util qw( sum );
21use File::Temp qw( tempfile tempdir );
22use File::Spec;
23
24use_ok( 'Dumpvalue' );
25
26my $out = tie *OUT, 'TieOut';
27select(OUT);
28
29{
30    my $d = Dumpvalue->new( dumpReused => 1 );
31    ok( $d, 'create a new Dumpvalue object' );
32    is( $d->get('globPrint'), 0, 'get a single (default) option correctly' );
33    my @attributes = (qw|globPrint printUndef tick unctrl|);
34    my @rv = $d->get(@attributes);
35    my $expected = [ 0, 1, "auto", 'quote' ];
36    is_deeply( \@rv, $expected, "get multiple (default) options correctly" );
37}
38
39{
40    my $d;
41    ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
42    my @foobar = ('foo', 'bar');
43    my @bazlow = ('baz', 'low');
44    {
45        local $@;
46        eval { $d->dumpValue([@foobar], [@bazlow]); };
47        like $@, qr/^usage: \$dumper->dumpValue\(value\)/,
48            "dumpValue() takes only 1 argument";
49    }
50}
51
52{
53    my $d;
54    ok( $d = Dumpvalue->new(), 'create a new Dumpvalue object' );
55    #is( $d->stringify(), 'undef', 'stringify handles undef okay' );
56    # Need to create a "stringify-overloaded object", then test with
57    # non-default value 'bareStringify = 0'.
58}
59
60
61{
62    my (@x, @y);
63
64    my $d = Dumpvalue->new( dumpReused => 1, quoteHighBit => '', unctrl => 'quote' );
65    ok( $d, 'create a new Dumpvalue object: quoteHighBit explicitly off' );
66    $x[0] = $d->stringify("\N{U+266}");
67    is ($x[0], "'\N{U+266}'" , 'quoteHighBit off' );
68
69    my $e = Dumpvalue->new( dumpReused => 1, quoteHighBit => 1, unctrl => 'quote' );
70    ok( $e, 'create a new Dumpvalue object: quoteHighBit on' );
71    $y[0] = $e->stringify("\N{U+266}");
72    is( $y[0], q|'\1146'|, "quoteHighBit on");
73
74    my $f = Dumpvalue->new( dumpReused => 1, quoteHighBit => '', unctrl => 'unctrl' );
75    ok( $f, 'create a new Dumpvalue object: quoteHighBit explicitly off, unctrl' );
76    $x[1] = $f->stringify("\N{U+266}");
77    is ($x[1], "'\N{U+266}'" , 'quoteHighBit off' );
78
79    my $g = Dumpvalue->new( dumpReused => 1, quoteHighBit => '', unctrl => 'unctrl' );
80    ok( $g, 'create a new Dumpvalue object: quoteHighBit explicitly off, unctrl' );
81    $y[1] = $g->stringify("\N{U+266}");
82    is ($y[1], "'\N{U+266}'" , 'quoteHighBit off' );
83
84    my $h = Dumpvalue->new( dumpReused => 1, quoteHighBit => '', tick => '"' );
85    ok( $h, 'create a new Dumpvalue object: quoteHighBit explicitly off, tick quote' );
86    $x[2] = $h->stringify("\N{U+266}");
87    is ($x[2], q|"| . "\N{U+266}" . q|"| , 'quoteHighBit off' );
88
89    my $i = Dumpvalue->new( dumpReused => 1, quoteHighBit => 1, tick => '"' );
90    ok( $i, 'create a new Dumpvalue object: quoteHighBit on, tick quote' );
91    $y[2] = $i->stringify("\N{U+266}");
92    is( $y[2], q|"\1146"|, "quoteHighBit on");
93
94    my $j = Dumpvalue->new( dumpReused => 1, quoteHighBit => 1, unctrl => 'quote' );
95    ok( $j, 'create a new Dumpvalue object: quoteHighBit on' );
96    $x[3] = $j->stringify("abc");
97    is( $x[3], q|'abc'|, "quoteHighBit on, unctrl quote, asciii-only text");
98
99    my $k = Dumpvalue->new( dumpReused => 1, quoteHighBit => 1, unctrl => 'unctrl' );
100    ok( $k, 'create a new Dumpvalue object: quoteHighBit on' );
101    $y[3] = $k->stringify("\N{U+266}abc");
102    is( $y[3], q|'\1146abc'|, "quoteHighBit on, unctrl unctrl, mixed text");
103
104    my $l = Dumpvalue->new( dumpReused => 1, quoteHighBit => '', unctrl => 'quote' );
105    ok( $l, 'create a new Dumpvalue object: quoteHighBit off' );
106    $x[4] = $l->stringify("abc");
107    is( $x[4], q|'abc'|, "quoteHighBit off, unctrl quote, asciii-only text");
108
109    my $m = Dumpvalue->new( dumpReused => 1, quoteHighBit => '', unctrl => 'unctrl' );
110    ok( $m, 'create a new Dumpvalue object: quoteHighBit off' );
111    $y[4] = $m->stringify("\N{U+266}abc");
112    #is( $y[4], q|'\1146abc'|, "quoteHighBit off, unctrl unctrl, mixed text");
113    is( $y[4], qq|'\N{U+266}abc'|, "quoteHighBit off, unctrl unctrl, mixed text");
114
115}
116
117{
118    my (@x, @y);
119
120    my $d = Dumpvalue->new( dumpReused => 1, veryCompact => '' );
121    ok( $d, 'create a new Dumpvalue object: veryCompact explicitly off' );
122    $d->DumpElem([1, 2, 3]);
123    $x[0] = $out->read;
124    like( $x[0], qr/^ARRAY\([^)]+\)\n0\s+1\n1\s+2\n2\s+3/,
125        "DumpElem worked as expected with veryCompact explicitly off");
126
127    my $e = Dumpvalue->new( dumpReused => 1, veryCompact => 1 );
128    ok( $e, 'create a new Dumpvalue object: veryCompact on' );
129    $e->DumpElem([1, 2, 3]);
130    $y[0] = $out->read;
131    like( $y[0], qr/^0\.\.2\s+1 2 3/,
132        "DumpElem worked as expected with veryCompact on");
133
134    my $f = Dumpvalue->new( dumpReused => 1, veryCompact => '' );
135    $f->DumpElem({ a => 1, b => 2, c => 3 });
136    $x[1] = $out->read;
137    like( $x[1], qr/^HASH\([^)]+\)\n'a'\s=>\s1\n'b'\s=>\s2\n'c'\s=>\s3/,
138        "DumpElem worked as expected with veryCompact explicitly off: hashref");
139
140    my $g = Dumpvalue->new( dumpReused => 1, veryCompact => 1 );
141    ok( $g, 'create a new Dumpvalue object: veryCompact on' );
142    $g->DumpElem({ a => 1, b => 2, c => 3 });
143    $y[1] = $out->read;
144    like( $y[1], qr/^'a'\s=>\s1,\s'b'\s=>\s2,\s'c'\s=>\s3/,
145        "DumpElem worked as expected with veryCompact on: hashref");
146
147    my $h = Dumpvalue->new( dumpReused => 1, veryCompact => '' );
148    ok( $h, 'create a new Dumpvalue object: veryCompact explicitly off' );
149    $h->DumpElem([1, 2, ['a']]);
150    $x[2] = $out->read;
151    like( $x[2], qr/^ARRAY\([^)]+\)\n0\s+1\n1\s+2\n2\s+ARRAY\([^)]+\)\n\s+0\s+'a'/,
152        "DumpElem worked as expected with veryCompact explicitly off:  array contains ref");
153
154    my $i = Dumpvalue->new( dumpReused => 1, veryCompact => 1 );
155    ok( $i, 'create a new Dumpvalue object: veryCompact on' );
156    $i->DumpElem([1, 2, ['a']]);
157    $y[2] = $out->read;
158    like( $y[2], qr/^ARRAY\([^)]+\)\n0\s+1\n1\s+2\n2\s+0\.\.0\s+'a'/,
159        "DumpElem worked as expected with veryCompact on: array contains ref");
160
161    my $j = Dumpvalue->new( dumpReused => 1, veryCompact => '' );
162    ok( $j, 'create a new Dumpvalue object: veryCompact explicitly off' );
163    $j->DumpElem({ a => 1, b => 2, c => ['a'] });
164    $x[3] = $out->read;
165    like( $x[3], qr/^HASH\([^)]+\)\n'a'\s=>\s1\n'b'\s=>\s2\n'c'\s=>\sARRAY\([^)]+\)\n\s+0\s+'a'/,
166        "DumpElem worked as expected with veryCompact explicitly off:  hash contains ref");
167
168    my $k = Dumpvalue->new( dumpReused => 1, veryCompact => 1 );
169    ok( $k, 'create a new Dumpvalue object: veryCompact on' );
170    $k->DumpElem({ a => 1, b => 2, c => ['a'] });
171    $y[3] = $out->read;
172    like( $y[3], qr/^HASH\([^)]+\)\n'a'\s=>\s1\n'b'\s=>\s2\n'c'\s=>\s0\.\.0\s+'a'/,
173        "DumpElem worked as expected with veryCompact on:  hash contains ref");
174
175    my $l = Dumpvalue->new( dumpReused => 1, veryCompact => '', hashDepth => 2 );
176    $l->DumpElem({ a => 1, b => 2, c => 3 });
177    $x[4] = $out->read;
178    like( $x[4], qr/^HASH\([^)]+\)\n'a'\s=>\s1\n'b'\s=>\s2\n\.{4}/,
179        "DumpElem worked as expected with veryCompact explicitly off: hashref hashdepth");
180
181    my $m = Dumpvalue->new( dumpReused => 1, veryCompact => 1, hashDepth => 2 );
182    ok( $m, 'create a new Dumpvalue object: veryCompact on' );
183    $m->DumpElem({ a => 1, b => 2, c => 3 });
184    $y[4] = $out->read;
185    like( $y[4], qr/^'a'\s=>\s1,\s'b'\s=>\s2\s\.+/,
186        "DumpElem worked as expected with veryCompact on: hashref hashdepth");
187
188    my $n = Dumpvalue->new( dumpReused => 1, veryCompact => '', hashDepth => 4 );
189    ok( $n, 'create a new Dumpvalue object: veryCompact off' );
190    $n->DumpElem({ a => 1, b => 2, c => 3 });
191    $x[5] = $out->read;
192    like( $x[5], qr/^HASH\([^)]+\)\n'a'\s=>\s1\n'b'\s=>\s2\n'c'\s+=>\s+3/,
193        "DumpElem worked as expected with veryCompact explicitly off: hashref hashdepth");
194
195    my $o = Dumpvalue->new( dumpReused => 1, veryCompact => 1, hashDepth => 4 );
196    ok( $o, 'create a new Dumpvalue object: veryCompact on' );
197    $o->DumpElem({ a => 1, b => 2, c => 3 });
198    $y[5] = $out->read;
199    like( $y[5], qr/^'a'\s=>\s1,\s+'b'\s=>\s2,\s+'c'\s+=>\s+3/,
200        "DumpElem worked as expected with veryCompact on: hashref hashdepth");
201}
202
203{
204    my (@x, @y);
205
206    my $five = '12345';
207    my $six = '123456';
208    my $alt = '78901';
209    my @arr = ($six, $alt);
210    my %two = (first => $six, notthefirst => $alt);
211
212    my $d = Dumpvalue->new( dumpReused => 1, usageOnly => '' );
213    ok( $d, 'create a new Dumpvalue object: usageOnly explicitly off' );
214    $x[0] = $d->scalarUsage($five);
215    is( $x[0], length($five), 'scalarUsage reports length correctly' );
216
217    my $e = Dumpvalue->new( dumpReused => 1, usageOnly => 1 );
218    ok( $e, 'create a new Dumpvalue object: usageOnly on' );
219    $y[0] = $e->scalarUsage($five);
220    is( $y[0], length($five), 'scalarUsage reports length correctly' );
221
222    my $f = Dumpvalue->new( dumpReused => 1, usageOnly => '' );
223    ok( $f, 'create a new Dumpvalue object: usageOnly explicitly off' );
224    $x[1] = $f->scalarUsage($six, '7890');
225    is ($x[1], length($six), 'scalarUsage reports length of first element correctly' );
226
227    my $g = Dumpvalue->new( dumpReused => 1, usageOnly => 1 );
228    ok( $g, 'create a new Dumpvalue object: usageOnly on' );
229    $y[1] = $g->scalarUsage($six, '7890');
230    is ($y[1], length($six), 'scalarUsage reports length of first element correctly' );
231
232    my $h = Dumpvalue->new( dumpReused => 1, usageOnly => '' );
233    ok( $h, 'create a new Dumpvalue object: usageOnly explicitly off' );
234    $x[2] = $h->scalarUsage( [ @arr ] );
235    is ($x[2], sum( map { length($_) } @arr ),
236        'scalarUsage reports sum of length of array elements correctly' );
237
238    my $i = Dumpvalue->new( dumpReused => 1, usageOnly => 1 );
239    ok( $i, 'create a new Dumpvalue object: usageOnly on' );
240    $y[2] = $i->scalarUsage( [ @arr ] );
241    is ($y[2], sum( map { length($_) } @arr ),
242        'scalarUsage reports length of first element correctly' );
243
244    my $j = Dumpvalue->new( dumpReused => 1, usageOnly => '' );
245    ok( $j, 'create a new Dumpvalue object: usageOnly explicitly off' );
246    $x[3] = $j->scalarUsage( { %two } );
247    is ($x[3], sum( ( map { length($_) } keys %two ), ( map { length($_) } values %two ), ),
248        'scalarUsage reports sum of length of hash keys and values correctly' );
249
250    my $k = Dumpvalue->new( dumpReused => 1, usageOnly => 1 );
251    ok( $k, 'create a new Dumpvalue object: usageOnly on' );
252    $y[3] = $k->scalarUsage( { %two } );
253    is ($y[3], sum( ( map { length($_) } keys %two ), ( map { length($_) } values %two ), ),
254        'scalarUsage reports sum of length of hash keys and values correctly' );
255}
256
257{
258    my (@x, @y);
259
260    my $d = Dumpvalue->new( dumpReused => 1, usageOnly => 1 );
261    ok( $d, 'create a new Dumpvalue object, usageOnly on' );
262    $d->dumpvars( 'Fake', 'veryfake' );
263    like( $out->read, qr/^String space:/, 'printed usage message fine' );
264
265    my $e = Dumpvalue->new( dumpReused => 1, usageOnly => '' );
266    ok( $e, 'create a new Dumpvalue object, usageOnly explicitly off' );
267    $e->dumpvars( 'Fake', 'veryfake' );
268    is( $out->read, '', 'printed usage message fine' );
269
270    my $f = Dumpvalue->new( dumpReused => 1, usageOnly => 1 );
271    ok( $f, 'create a new Dumpvalue object, usageOnly on' );
272    $f->dumpvars( 'main', 'INC' );
273    like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
274
275    my $g = Dumpvalue->new( dumpReused => 1, usageOnly => '' );
276    ok( $g, 'create a new Dumpvalue object, usageOnly explicitly off' );
277    $g->dumpvars( 'main', 'INC' );
278    like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
279
280    # return if $DB::signal and $self->{stopDbSignal};
281
282    {
283        note("DB::signal off");
284        local $DB::signal = 0;
285
286        my $h = Dumpvalue->new( dumpReused => 1, stopDbSignal => '' );
287        ok( $h, 'create a new Dumpvalue object, stopDbSignal explicitly off' );
288        $h->dumpvars( 'main', 'INC' );
289        like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
290
291        my $i = Dumpvalue->new( dumpReused => 1, stopDbSignal => 1 );
292        ok( $i, 'create a new Dumpvalue object, stopDbSignal on' );
293        $i->dumpvars( 'main', 'INC' );
294        like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
295    }
296
297    {
298        note("DB::signal on");
299        local $DB::signal = 1;
300
301        my $j = Dumpvalue->new( dumpReused => 1, stopDbSignal => '' );
302        ok( $j, 'create a new Dumpvalue object, stopDbSignal explicitly off' );
303        $j->dumpvars( 'main', 'INC' );
304        like( $out->read, qr/\@INC =/, 'dumped variables from a package' );
305
306        my $k = Dumpvalue->new( dumpReused => 1, stopDbSignal => 1 );
307        ok( $k, 'create a new Dumpvalue object, stopDbSignal on' );
308        $k->dumpvars( 'main', 'INC' );
309        is( $out->read, '', 'return false' );
310
311        my $l = Dumpvalue->new( dumpReused => 1, stopDbSignal => 1 );
312        ok( $l, 'create a new Dumpvalue object, stopDbSignal on' );
313        $l->dumpvars( 'main::', 'INC' );
314        is( $out->read, '', 'XXX: return false' );
315    }
316}
317
318{
319    my (@x, @y);
320
321    my $d = Dumpvalue->new( dumpReused => 1, compactDump => 1 );
322    ok( $d, 'create a new Dumpvalue object, compactDump' );
323    $d->unwrap([]);
324    $x[0] = $out->read;
325    like( $x[0], qr/\s*empty array\n/, "unwrap() reported empty array");
326
327    my $e = Dumpvalue->new( dumpReused => 1, compactDump => 0 );
328    ok( $e, 'create a new Dumpvalue object, compactDump explicitly off' );
329    $e->unwrap([ qw| alpha beta gamma | ]);
330    $y[0] = $out->read;
331    like( $y[0], qr/0\s+'alpha'\n1\s+'beta'\n2\s+'gamma'/,
332        "unwrap() with compactDump explicitly off");
333
334    my $f = Dumpvalue->new( dumpReused => 1 );
335    ok( $f, 'create a new Dumpvalue object' );
336    $f->veryCompact(0);
337    $f->unwrap([ qw| alpha beta gamma | ]);
338    $x[1] = $out->read;
339    like( $x[1], qr/0\s+'alpha'\n1\s+'beta'\n2\s+'gamma'/,
340        "unwrap() after veryCompact method call with arg 0");
341
342    my $g = Dumpvalue->new( dumpReused => 1 );
343    ok( $g, 'create a new Dumpvalue object' );
344    $g->veryCompact();
345    $g->unwrap([ qw| alpha beta gamma | ]);
346    $y[1] = $out->read;
347    like( $y[1], qr/0\s+'alpha'\n1\s+'beta'\n2\s+'gamma'/,
348        "unwrap() after veryCompact method call with explicitly off");
349
350    my $h = Dumpvalue->new( dumpReused => 1 );
351    ok( $h, 'create a new Dumpvalue object' );
352    $h->compactDump(1);
353    $h->veryCompact(0);
354    $h->unwrap([ qw| alpha beta gamma | ]);
355    $x[2] = $out->read;
356    like( $x[2], qr/0\.\.2\s+'alpha'\s+'beta'\s+'gamma'/,
357        "unwrap() after compactDump(1) and veryCompact(0) method calls");
358
359    my $i = Dumpvalue->new( dumpReused => 1 );
360    ok( $i, 'create a new Dumpvalue object' );
361    $i->compactDump(0);
362    $i->unwrap([ qw| alpha beta gamma | ]);
363    $y[2] = $out->read;
364    like( $y[1], qr/0\s+'alpha'\n1\s+'beta'\n2\s+'gamma'/,
365        "unwrap() after compactDump(0) method call");
366
367}
368
369{
370    no warnings 'once';
371
372    my (@x, @y);
373
374    my $d = Dumpvalue->new( dumpReused => 1 );
375    ok( $d, 'create a new Dumpvalue object' );
376    $d->unwrap(\*BAR);
377    $x[0] = $out->read;
378    is( $x[0], "-> *main::BAR\n", "unwrap reported ref to typeglob");
379
380    my $e = Dumpvalue->new( dumpReused => 1, globPrint => 1 );
381    ok( $e, 'create a new Dumpvalue object, globPrint' );
382    $e->unwrap(\*RQP);
383    $y[0] = $out->read;
384    is( $y[0], "-> *main::RQP\n", "unwrap reported ref to typeglob");
385
386    my $tdir = tempdir( CLEANUP => 1 );
387    my $tempfile = File::Spec->catfile($tdir, 'foo.txt');
388    open FH, '>', $tempfile or die "Unable to open tempfile for writing";
389    print FH "\n";
390    my $f = Dumpvalue->new( dumpReused => 1 );
391    ok( $f, 'create a new Dumpvalue object' );
392    $f->unwrap(\*FH);
393    $x[1] = $out->read;
394    like( $x[1],
395        qr/->\s\*main::FH\n\s*FileHandle\(\{\*main::FH\}\)\s+=>\s+fileno\(\d+\)\n/,
396        "unwrap reported ref to typeglob");
397    close FH or die "Unable to close tempfile after writing";
398}
399
400{
401    my (@x, @y);
402
403    my $d = Dumpvalue->new( dumpReused => 1, quoteHighBit => '' );
404    ok( $d, 'create a new Dumpvalue object' );
405    $d->set_unctrl('unctrl');
406    $d->unwrap([ "bo\007nd", qw| alpha beta gamma | ]);
407    $x[0] = $out->read;
408    like( $x[0], qr/0\s+"bo\^.nd"\n1\s+'alpha'\n2\s+'beta'\n3\s+'gamma'/,
409        "unwrap() with set_unctrl('unctrl') method call" );
410
411    my $e = Dumpvalue->new( dumpReused => 1, quoteHighBit => 1 );
412    ok( $e, 'create a new Dumpvalue object' );
413    $e->set_unctrl('unctrl');
414    $e->unwrap([ "bo\007nd", qw| alpha beta gamma | ]);
415    $x[1] = $out->read;
416    like( $x[1], qr/0\s+"bo\^.nd"\n1\s+'alpha'\n2\s+'beta'\n3\s+'gamma'/,
417        "unwrap() with set_unctrl('unctrl') method call" );
418}
419
420{
421    my (@x, @y);
422
423    my $d = Dumpvalue->new( dumpReused => 1 );
424    ok( $d, 'create a new Dumpvalue object' );
425    $x[0] = $d->dumpsub( '', 'TieOut::read' );
426    like( $x[0], qr/&TieOut::read in/, 'dumpsub found sub fine' );
427
428    my $e = Dumpvalue->new( dumpReused => 1 );
429    ok( $e, 'create a new Dumpvalue object' );
430    $y[0] = $e->dumpsub( 5, 'TieOut::read' );
431    like( $y[0], qr/\s{5}&TieOut::read in/, 'dumpsub found sub fine, leading whitespace' );
432
433    my $f = Dumpvalue->new( dumpReused => 1 );
434    ok( $f, 'create a new Dumpvalue object' );
435    $x[1] = $f->dumpsub( '', "{*ABC}" );
436    like( $x[1], qr/&ABC in \?{3}/, 'dumpsub found sub (ref) fine' );
437
438}
439
440__END__
441    print STDERR "AAA: $x[0]\n";
442    print STDERR "AAA: $y[0]\n";
443
444