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