File Coverage

blib/lib/Test/Deep/Set.pm
Criterion Covered Total %
statement 88 88 100.0
branch 42 46 91.3
condition 15 15 100.0
subroutine 9 9 100.0
pod 0 6 0.0
total 154 164 93.9


line stmt bran cond sub pod time code
1 4     4   27 use strict;
  4         11  
  4         122  
2 4     4   20 use warnings;
  4         8  
  4         148  
3              
4             package Test::Deep::Set 1.204;
5              
6 4     4   926 use Test::Deep::Cmp;
  4         10  
  4         18  
7              
8             sub init
9             {
10 85     85 0 139 my $self = shift;
11              
12 85         268 $self->{IgnoreDupes} = shift;
13 85         133 $self->{SubSup} = shift;
14              
15 85         154 $self->{val} = [];
16              
17 85         187 $self->add(@_);
18             }
19              
20             sub descend
21             {
22 93     93 0 151 my $self = shift;
23 93         131 my $d1 = shift;
24              
25 93         165 my $d2 = $self->{val};
26              
27 93         127 my $IgnoreDupes = $self->{IgnoreDupes};
28              
29 93         230 my $data = $self->data;
30              
31 93         156 my $SubSup = $self->{SubSup};
32              
33 93 100       174 my $type = $IgnoreDupes ? "Set" : "Bag";
34              
35 93         124 my $diag;
36              
37 93 100       216 if (ref $d1 ne 'ARRAY')
38             {
39 25         51 my $got = Test::Deep::render_val($d1);
40 25         63 $diag = <
41             got : $got
42             expect : An array to use as a $type
43             EOM
44             }
45              
46 93 100       178 if (not $diag)
47             {
48 68         176 my @got = @$d1;
49 68         113 my @found;
50             my @missing;
51 68         117 foreach my $expect (@$d2)
52             {
53 187         259 my $found = 0;
54              
55 187         501 for (my $i = $#got; $i >= 0; $i--)
56             {
57 430 100       927 if (Test::Deep::eq_deeply_cache($got[$i], $expect))
58             {
59 144         247 $found = 1;
60 144         252 push(@found, $expect);
61 144         225 splice(@got, $i, 1);
62              
63 144 100       345 last unless $IgnoreDupes;
64             }
65             }
66              
67 187 100       463 push(@missing, $expect) unless $found;
68             }
69              
70 68         90 my @diags;
71 68 100 100     224 if (@missing and $SubSup ne "sub" && $SubSup ne "none")
      100        
72             {
73 23         65 push(@diags, "Missing: ".nice_list(\@missing));
74             }
75              
76 68 100 100     261 if (@got and $SubSup ne "sup" && $SubSup ne "none")
      100        
77             {
78 27         91 my $got = __PACKAGE__->new($IgnoreDupes, "", @got);
79 27         64 push(@diags, "Extra: ".nice_list($got->{val}));
80             }
81              
82 68 100 100     239 if (@found and $SubSup eq "none")
83             {
84 2         9 my $found = __PACKAGE__->new($IgnoreDupes, "", @found);
85 2         8 push(@diags, "Extra: ".nice_list($found->{val}));
86             }
87              
88 68         239 $diag = join("\n", @diags);
89             }
90              
91 93 100       188 if ($diag)
92             {
93 59         138 $data->{diag} = $diag;
94              
95 59         157 return 0;
96             }
97             else
98             {
99 34         103 return 1;
100             }
101             }
102              
103             sub diagnostics
104             {
105 23     23 0 36 my $self = shift;
106 23         45 my ($where, $last) = @_;
107              
108 23 100       60 my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
109 23 100       59 $type = "Sub$type" if $self->{SubSup} eq "sub";
110 23 100       53 $type = "Super$type" if $self->{SubSup} eq "sup";
111 23 100       46 $type = "NoneOf" if $self->{SubSup} eq "none";
112              
113 23         32 my $error = $last->{diag};
114 23         74 my $diag = <
115             Comparing $where as a $type
116             $error
117             EOM
118              
119 23         54 return $diag;
120             }
121              
122             sub add
123             {
124             # this takes an array.
125              
126             # For each element A of the array, it looks for an element, B, already in
127             # the set which are deeply equal to A. If no matching B is found then A is
128             # added to the set. If a B is found and IgnoreDupes is true, then A will
129             # be discarded, if IgnoreDupes is false, then B will be added to the set
130             # again.
131            
132 91     91 0 5847 my $self = shift;
133              
134 91         231 my @array = @_;
135              
136 91         149 my $IgnoreDupes = $self->{IgnoreDupes};
137              
138 91         125 my $already = $self->{val};
139              
140 91         141 local $Test::Deep::Expects = 1;
141 91         154 foreach my $new_elem (@array)
142             {
143 232         324 my $want_push = 1;
144 232         302 my $push_this = $new_elem;
145 232         356 foreach my $old_elem (@$already)
146             {
147 232 100       481 if (Test::Deep::eq_deeply($new_elem, $old_elem))
148             {
149 56         84 $push_this = $old_elem;
150 56         83 $want_push = ! $IgnoreDupes;
151 56         85 last;
152             }
153             }
154 232 100       616 push(@$already, $push_this) if $want_push;
155             }
156              
157             # so we can compare 2 Test::Deep::Set objects using array comparison
158              
159 91 100       330 @$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already;
  188 50       678  
160             }
161              
162             sub nice_list
163             {
164 52     52 0 81 my $list = shift;
165              
166 52         160 my @scalars = grep ! ref $_, @$list;
167 52         103 my $refs = grep ref $_, @$list;
168              
169 52 100       125 my @ref_string = "$refs reference" if $refs;
170 52 100       106 $ref_string[0] .= "s" if $refs > 1;
171              
172             # sort them so we can predict the diagnostic output
173              
174             return join(", ",
175 52 50       123 (map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars),
  86 50       189  
  51         126  
176             @ref_string
177             );
178             }
179              
180             sub compare
181             {
182 14     14 0 26 my $self = shift;
183              
184 14         21 my $other = shift;
185              
186 14 50       38 return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes};
187              
188             # this works (kind of) because the arrays are sorted
189              
190 14         35 return Test::Deep::descend($self->{val}, $other->{val});
191             }
192              
193             1;
194              
195             __END__