more tests!

also, some test library

2 files changed, 164 insertions, 0 deletions

diff --git a/t/lib/Test2/Compare/Bag.pm b/t/lib/Test2/Compare/Bag.pm
new file mode 100644
index 0000000..e4dc224
--- /dev/null
+++ b/t/lib/Test2/Compare/Bag.pm
@@ -0,0 +1,109 @@
+package Test2::Compare::Bag;
+use strict;
+use warnings;
+
+use base 'Test2::Compare::Base';
+
+our $VERSION = '0.000030';
+
+use Test2::Util::HashBase qw/ending items/;
+
+use Carp qw/croak confess/;
+use Scalar::Util qw/reftype looks_like_number/;
+
+sub init {
+    my $self = shift;
+
+    $self->{+ITEMS} ||= [];
+
+    $self->SUPER::init();
+}
+
+sub name { '<BAG>' }
+
+sub verify {
+    my $self = shift;
+    my %params = @_;
+
+    return 0 unless $params{exists};
+    my $got = $params{got} || return 0;
+    return 0 unless ref($got);
+    return 0 unless reftype($got) eq 'ARRAY';
+    return 1;
+}
+
+sub add_item {
+    my $self = shift;
+    my $check = pop;
+    my ($idx) = @_;
+
+    push @{$self->{+ITEMS}}, $check;
+}
+
+sub deltas {
+    my $self = shift;
+    my %params = @_;
+    my ($got, $convert, $seen) = @params{qw/got convert seen/};
+
+    my @deltas;
+    my $state = 0;
+    my @items = @{$self->{+ITEMS}};
+
+    # Make a copy that we can munge as needed.
+    my @list = @$got;
+    my %unmatched = map { $_ => $list[$_] } 0..$#list;
+
+    while (@items) {
+        my $item = shift @items;
+
+        my $check = $convert->($item);
+
+        my @item_deltas;
+        for my $idx (0..$#list) {
+            my $val = $list[$idx];
+            my @this_deltas = $check->run(
+                id      => [ARRAY => $idx],
+                convert => $convert,
+                seen    => $seen,
+                exists  => 1,
+                got     => $val,
+            );
+            if (@this_deltas) {
+                push @item_deltas,@this_deltas;
+            }
+            else {
+                @item_deltas = ();
+                delete $unmatched{$idx};
+                last;
+            }
+        }
+        if (@item_deltas) {
+            push @deltas, $self->delta_class->new(
+                dne      => 'got',
+                verified => 1,
+                id       => [ARRAY => '*'],
+                got      => undef,
+                check    => $check,
+                children => \@item_deltas,
+            );
+        }
+    }
+
+    # if elements are left over, and ending is true, we have a problem!
+    if($self->{+ENDING} && keys %unmatched) {
+        for my $idx (sort keys %unmatched) {
+            my $elem = $list[$idx];
+            push @deltas => $self->delta_class->new(
+                dne      => 'check',
+                verified => undef,
+                id       => [ARRAY => $idx],
+                got      => $elem,
+                check    => undef,
+            );
+        }
+    }
+
+    return @deltas;
+}
+
+1;
diff --git a/t/lib/Test2/Tools/MoreCompare.pm b/t/lib/Test2/Tools/MoreCompare.pm
new file mode 100644
index 0000000..7ff16ab
--- /dev/null
+++ b/t/lib/Test2/Tools/MoreCompare.pm
@@ -0,0 +1,55 @@
+package Test2::Tools::MoreCompare;
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+use Scalar::Util qw/reftype/;
+
+use Test2::API qw/context/;
+use Test2::Util::Ref qw/rtype/;
+
+use Test2::Compare qw{
+    compare
+    get_build push_build pop_build build
+    strict_convert relaxed_convert
+};
+
+use Test2::Compare::Bag();
+
+%Carp::Internal = (
+    %Carp::Internal,
+    'Test2::Tools::MoreCompare' => 1,
+    'Test2::Compare::Bag'       => 1,
+);
+
+our @EXPORT_OK = qw{
+    bag call_list
+};
+use base 'Exporter';
+
+sub bag(&)  { build('Test2::Compare::Bag', @_) }
+
+sub call_list($$) {
+    my ($name, $expect) = @_;
+    my $build = get_build() or croak "No current build!";
+
+    croak "'$build' does not support method calls"
+        unless $build->can('add_call');
+
+    croak "'call_list' should only ever be called in void context"
+        if defined wantarray;
+
+    my @caller = caller;
+    $build->add_call(
+        sub { [ shift->$name ] },
+        Test2::Compare::Wildcard->new(
+            expect => $expect,
+            file   => $caller[1],
+            lines  => [$caller[2]],
+        ),
+        $name,
+    );
+
+}
+
+1;