summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Test/Deep/Set.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Test/Deep/Set.pm')
-rwxr-xr-xMaster/tlpkg/tlperl/lib/Test/Deep/Set.pm185
1 files changed, 185 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Test/Deep/Set.pm b/Master/tlpkg/tlperl/lib/Test/Deep/Set.pm
new file mode 100755
index 00000000000..b90f1d2da75
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Test/Deep/Set.pm
@@ -0,0 +1,185 @@
+use strict;
+use warnings;
+
+package Test::Deep::Set;
+
+use Test::Deep::Cmp;
+
+sub init
+{
+ my $self = shift;
+
+ $self->{IgnoreDupes} = shift;
+ $self->{SubSup} = shift;
+
+ $self->{val} = [];
+
+ $self->add(@_);
+}
+
+sub descend
+{
+ my $self = shift;
+ my $d1 = shift;
+
+ my $d2 = $self->{val};
+
+ my $IgnoreDupes = $self->{IgnoreDupes};
+
+ my $data = $self->data;
+
+ my $SubSup = $self->{SubSup};
+
+ my $type = $IgnoreDupes ? "Set" : "Bag";
+
+ my $diag;
+
+ if (ref $d1 ne 'ARRAY')
+ {
+ my $got = Test::Deep::render_val($d1);
+ $diag = <<EOM;
+got : $got
+expect : An array to use as a $type
+EOM
+ }
+
+ if (not $diag)
+ {
+ my @got = @$d1;
+ my @missing;
+ foreach my $expect (@$d2)
+ {
+ my $found = 0;
+
+ for (my $i = $#got; $i >= 0; $i--)
+ {
+ if (Test::Deep::eq_deeply_cache($got[$i], $expect))
+ {
+ $found = 1;
+ splice(@got, $i, 1);
+
+ last unless $IgnoreDupes;
+ }
+ }
+
+ push(@missing, $expect) unless $found;
+ }
+
+
+ my @diags;
+ if (@missing and $SubSup ne "sub")
+ {
+ push(@diags, "Missing: ".nice_list(\@missing));
+ }
+
+ if (@got and $SubSup ne "sup")
+ {
+ my $got = __PACKAGE__->new($IgnoreDupes, "", @got);
+ push(@diags, "Extra: ".nice_list($got->{val}));
+ }
+
+ $diag = join("\n", @diags);
+ }
+
+ if ($diag)
+ {
+ $data->{diag} = $diag;
+
+ return 0;
+ }
+ else
+ {
+ return 1;
+ }
+}
+
+sub diagnostics
+{
+ my $self = shift;
+ my ($where, $last) = @_;
+
+ my $type = $self->{IgnoreDupes} ? "Set" : "Bag";
+ $type = "Sub$type" if $self->{SubSup} eq "sub";
+ $type = "Super$type" if $self->{SubSup} eq "sup";
+
+ my $error = $last->{diag};
+ my $diag = <<EOM;
+Comparing $where as a $type
+$error
+EOM
+
+ return $diag;
+}
+
+sub add
+{
+ # this takes an array.
+
+ # For each element A of the array, it looks for an element, B, already in
+ # the set which are deeply equal to A. If no matching B is found then A is
+ # added to the set. If a B is found and IgnoreDupes is true, then A will
+ # be discarded, if IgnoreDupes is false, then B will be added to the set
+ # again.
+
+ my $self = shift;
+
+ my @array = @_;
+
+ my $IgnoreDupes = $self->{IgnoreDupes};
+
+ my $already = $self->{val};
+
+ local $Test::Deep::Expects = 1;
+ foreach my $new_elem (@array)
+ {
+ my $want_push = 1;
+ my $push_this = $new_elem;
+ foreach my $old_elem (@$already)
+ {
+ if (Test::Deep::eq_deeply($new_elem, $old_elem))
+ {
+ $push_this = $old_elem;
+ $want_push = ! $IgnoreDupes;
+ last;
+ }
+ }
+ push(@$already, $push_this) if $want_push;
+ }
+
+ # so we can compare 2 Test::Deep::Set objects using array comparison
+
+ @$already = sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @$already;
+}
+
+sub nice_list
+{
+ my $list = shift;
+
+ my @scalars = grep ! ref $_, @$list;
+ my $refs = grep ref $_, @$list;
+
+ my @ref_string = "$refs reference" if $refs;
+ $ref_string[0] .= "s" if $refs > 1;
+
+ # sort them so we can predict the diagnostic output
+
+ return join(", ",
+ (map {Test::Deep::render_val($_)} sort {(defined $a ? $a : "") cmp (defined $b ? $b : "")} @scalars),
+ @ref_string
+ );
+}
+
+sub compare
+{
+ my $self = shift;
+
+ my $other = shift;
+
+ return 0 if $self->{IgnoreDupes} != $other->{IgnoreDupes};
+
+ # this works (kind of) because the the arrays are sorted
+
+ return Test::Deep::descend($self->{val}, $other->{val});
+}
+
+1;