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