1#!./perl -w
2# t/dumpperl.t - test all branches of, and modes of triggering, Dumpperl()
3
4use strict;
5use warnings;
6
7use Carp;
8use Data::Dumper;
9use Test::More tests => 31;
10use lib qw( ./t/lib );
11use Testing qw( _dumptostr );
12
13$Data::Dumper::Indent=1;
14
15{
16    local $Data::Dumper::Useperl=1;
17    local $Data::Dumper::Useqq=0;
18    local $Data::Dumper::Deparse=0;
19    note('$Data::Dumper::Useperl => 1');
20    run_tests_for_pure_perl_implementations();
21}
22
23{
24    local $Data::Dumper::Useperl=0;
25    local $Data::Dumper::Useqq=1;
26    local $Data::Dumper::Deparse=0;
27    note('$Data::Dumper::Useqq => 1');
28    run_tests_for_pure_perl_implementations();
29}
30
31{
32    local $Data::Dumper::Useperl=0;
33    local $Data::Dumper::Useqq=0;
34    local $Data::Dumper::Deparse=1;
35    note('$Data::Dumper::Deparse => 1');
36    run_tests_for_pure_perl_implementations();
37}
38
39
40
41sub run_tests_for_pure_perl_implementations {
42
43    my ($a, $b, $obj);
44    my (@names);
45    my (@newnames, $objagain, %newnames);
46    my $dumpstr;
47    $a = 'alpha';
48    $b = 'beta';
49    my @c = ( qw| eta theta | );
50    my %d = ( iota => 'kappa' );
51
52    note('names not provided');
53    $obj = Data::Dumper->new([$a, $b]);
54    $dumpstr = _dumptostr($obj);
55    like($dumpstr,
56        qr/\$VAR1.+alpha.+\$VAR2.+beta/s,
57        "Dump: two strings"
58    );
59
60    $obj = Data::Dumper->new([$a, \@c]);
61    $dumpstr = _dumptostr($obj);
62    like($dumpstr,
63        qr/\$VAR1.+alpha.+\$VAR2.+\[.+eta.+theta.+\]/s,
64        "Dump: one string, one array ref"
65    );
66
67    $obj = Data::Dumper->new([$a, \%d]);
68    $dumpstr = _dumptostr($obj);
69    like($dumpstr,
70        qr/\$VAR1.+alpha.+\$VAR2.+\{.+iota.+kappa.+\}/s,
71        "Dump: one string, one hash ref"
72    );
73
74    $obj = Data::Dumper->new([$a, undef]);
75    $dumpstr = _dumptostr($obj);
76    like($dumpstr,
77        qr/\$VAR1.+alpha.+\$VAR2.+undef/s,
78        "Dump: one string, one undef"
79    );
80
81    note('names provided');
82
83    $obj = Data::Dumper->new([$a, $b], [ qw( a b ) ]);
84    $dumpstr = _dumptostr($obj);
85    like($dumpstr,
86        qr/\$a.+alpha.+\$b.+beta/s,
87        "Dump: names: two strings"
88    );
89
90    $obj = Data::Dumper->new([$a, \@c], [ qw( a *c ) ]);
91    $dumpstr = _dumptostr($obj);
92    like($dumpstr,
93        qr/\$a.+alpha.+\@c.+eta.+theta/s,
94        "Dump: names: one string, one array ref"
95    );
96
97    $obj = Data::Dumper->new([$a, \%d], [ qw( a *d ) ]);
98    $dumpstr = _dumptostr($obj);
99    like($dumpstr,
100        qr/\$a.+alpha.+\%d.+iota.+kappa/s,
101        "Dump: names: one string, one hash ref"
102    );
103
104    $obj = Data::Dumper->new([$a,undef], [qw(a *c)]);
105    $dumpstr = _dumptostr($obj);
106    like($dumpstr,
107        qr/\$a.+alpha.+\$c.+undef/s,
108        "Dump: names: one string, one undef"
109    );
110
111    $obj = Data::Dumper->new([$a, $b], [ 'a', '']);
112    $dumpstr = _dumptostr($obj);
113    like($dumpstr,
114        qr/\$a.+alpha.+\$.+beta/s,
115        "Dump: names: two strings: one name empty"
116    );
117
118    $obj = Data::Dumper->new([$a, $b], [ 'a', '$foo']);
119    $dumpstr = _dumptostr($obj);
120    no warnings 'uninitialized';
121    like($dumpstr,
122        qr/\$a.+alpha.+\$foo.+beta/s,
123        "Dump: names: two strings: one name start with '\$'"
124    );
125    use warnings;
126}
127
128{
129    my ($obj, $dumpstr, $realtype);
130    $obj = Data::Dumper->new([ {IO => *{$::{STDERR}}{IO}} ]);
131    $obj->Useperl(1);
132    eval { $dumpstr = _dumptostr($obj); };
133    $realtype = 'IO';
134    like($@, qr/Can't handle '$realtype' type/,
135        "Got expected error: pure-perl: Data-Dumper does not handle $realtype");
136}
137