more tests!

also, some test library

5 files changed, 402 insertions, 5 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;
diff --git a/t/tests/compare-bag.t b/t/tests/compare-bag.t
new file mode 100644
index 0000000..7c71639
--- /dev/null
+++ b/t/tests/compare-bag.t
@@ -0,0 +1,146 @@
+#!perl
+use strict;
+use warnings;
+use 5.020;
+use Test2::Bundle::Extended -target => 'Test2::Compare::Bag';
+
+isa_ok($CLASS, 'Test2::Compare::Base');
+is($CLASS->name, '<BAG>', "got name");
+
+subtest construction => sub {
+    my $one = $CLASS->new();
+    isa_ok($one, $CLASS);
+    is($one->items, [], "created items as an array");
+};
+
+subtest verify => sub {
+    my $one = $CLASS->new;
+
+    is($one->verify(exists => 0), 0, "did not get anything");
+    is($one->verify(exists => 1, got => undef), 0, "undef is not an array");
+    is($one->verify(exists => 1, got => 0), 0, "0 is not an array");
+    is($one->verify(exists => 1, got => 1), 0, "1 is not an array");
+    is($one->verify(exists => 1, got => 'string'), 0, "'string' is not an array");
+    is($one->verify(exists => 1, got => {}), 0, "a hash is not an array");
+    is($one->verify(exists => 1, got => []), 1, "an array is an array");
+};
+
+subtest add_item => sub {
+    my $one = $CLASS->new();
+
+    $one->add_item('a');
+    $one->add_item(1 => 'b');
+    $one->add_item(3 => 'd');
+
+    ok(
+        lives { $one->add_item(2 => 'c') },
+        "Indexes are ignored",
+    );
+
+    $one->add_item(8 => 'x');
+    $one->add_item('y');
+
+    is(
+        $one->items,
+        [ 'a', 'b', 'd', 'c', 'x', 'y' ],
+        "Expected items",
+    );
+};
+
+subtest deltas => sub {
+    my $conv = Test2::Compare->can('strict_convert');
+
+    my %params = (exists => 1, convert => $conv, seen => {});
+
+    my $items = ['a', 'b'];
+    my $one = $CLASS->new(items => $items);
+
+    like(
+        [$one->deltas(%params, got => ['a', 'b'])],
+        [],
+        "No delta, no diff"
+    );
+
+    like(
+        [$one->deltas(%params, got => ['b', 'a'])],
+        [],
+        "No delta, no diff, order is ignored"
+    );
+
+    like(
+        [$one->deltas(%params, got => ['a'])],
+        [
+            {
+                dne => 'got',
+                id  => [ARRAY => '*'],
+                got => undef,,
+                chk => {input => 'b'},
+                children => [
+                    {
+                        dne => DNE,
+                        id => [ARRAY => 0],
+                        got => 'a',
+                        chk => {input => 'b'},
+                    },
+                ],
+            }
+        ],
+        "Got the delta for the missing value"
+    );
+
+    like(
+        [$one->deltas(%params, got => ['a', 'a'])],
+        [
+            {
+                dne => 'got',
+                id  => [ARRAY => '*'],
+                got => undef,
+                chk => {input => 'b'},
+                children => [
+                    {
+                        dne => DNE,
+                        id => [ARRAY => 0],
+                        got => 'a',
+                        chk => {input => 'b'},
+                    },
+                    {
+                        dne => DNE,
+                        id => [ARRAY => 1],
+                        got => 'a',
+                        chk => {input => 'b'},
+                    },
+                ],
+            }
+        ],
+        "Got the delta for the incorrect value"
+    );
+
+    like(
+        [$one->deltas(%params, got => ['a', 'b', 'a', 'a'])],
+        [],
+        "No delta, not checking ending"
+    );
+
+    $one->set_ending(1);
+    like(
+        [$one->deltas(%params, got => ['a', 'b', 'a', 'x'])],
+        array {
+            item 0 => {
+                dne   => 'check',
+                id    => [ARRAY => 2],
+                got   => 'a',
+                check => DNE,
+            };
+            item 1 => {
+                dne   => 'check',
+                id    => [ARRAY => 3],
+                got   => 'x',
+                check => DNE,
+            };
+            end(),
+        },
+        "Got 2 deltas for extra items"
+    );
+};
+
+done_testing;
diff --git a/t/tests/morecompare.t b/t/tests/morecompare.t
new file mode 100644
index 0000000..1755fa9
--- /dev/null
+++ b/t/tests/morecompare.t
@@ -0,0 +1,74 @@
+#!perl
+use strict;
+use warnings;
+use 5.020;
+use Test2::Bundle::Extended;
+use Test2::Tools::MoreCompare qw(bag call_list);
+use Test2::API qw(intercept);
+
+subtest simple => sub {
+    imported_ok qw{bag call_list};
+};
+
+subtest bag => sub {
+    my $empty = bag { };
+
+    my $simple = bag {
+        item 'a';
+        item 'b';
+        item 'c';
+    };
+
+    my $closed = array {
+        item 0 => 'a';
+        item 1 => 'b';
+        item 2 => 'c';
+        end;
+    };
+
+    is([], $empty, "empty array");
+    is(['a'], $empty, "any array matches empty");
+
+    is([qw/a b c/], $simple, "simple exact match");
+    is([qw/b c a/], $simple, "simple out of order");
+    is([qw/a b c d e/], $simple, "simple with extra");
+    is([qw/b a d e c/], $simple, "simple with extra, out of order");
+
+    is([qw/a b c/], $closed, "closed array");
+
+    my $events = intercept {
+        is({}, $empty);
+        is(undef, $empty);
+        is(1, $empty);
+        is('ARRAY', $empty);
+
+        is([qw/x y z/], $simple);
+        is([qw/a b x/], $simple);
+        is([qw/x b c/], $simple);
+
+        is([qw/a b c d/], $closed);
+    };
+
+    @$events = grep {$_->isa('Test2::Event::Ok')} @$events;
+    is(@$events, 8, "8 events");
+    is($_->pass, 0, "event failed") for @$events;
+};
+
+subtest call_list => sub {
+    my $obj = mock 'My::Class' => (
+        add => [
+            many => sub { return (1,2,3) },
+            one => sub { 4 },
+        ],
+    );
+
+    my $calls = object {
+        call one => 4;
+        call_list many => [1,2,3];
+        call_list one => [4];
+    };
+
+    is(bless({},'My::Class'), $calls, 'call_list matches');
+};
+
+done_testing;
diff --git a/t/tests/sietima.t b/t/tests/sietima.t
index b0367b6..ab6e129 100644
--- a/t/tests/sietima.t
+++ b/t/tests/sietima.t
@@ -2,7 +2,9 @@
 use strict;
 use warnings;
 use 5.020;
+use lib 't/lib';
 use Test2::Bundle::Extended;
+use Test2::Tools::MoreCompare qw(bag);
 use Test2::Plugin::DieOnFail;
 use Email::Stuffer;
 use Email::Sender::Transport::Test;
@@ -51,11 +53,12 @@ subtest 'no subscribers' => sub {
 };
 
 subtest 'with subscribers' => sub {
+    my @subscriber_addresses = (
+        'one@users.example.com',
+        'two@users.example.com',
+    );
     my $s = make_sietima(
-        subscribers => [
-            'one@users.example.com',
-            'two@users.example.com',
-        ],
+        subscribers => [@subscriber_addresses],
     );
     my $m = make_mail();
 
@@ -69,7 +72,17 @@ subtest 'with subscribers' => sub {
     is(
         \@deliveries,
         array {
-            # we'd need a 'bag' comparison check here!
+            item hash {
+                field envelope => hash {
+                    field from => $return_path;
+                    field to => bag {
+                        for (@subscriber_addresses) {
+                            item object { call address => $_ };
+                        }
+                    };
+                };
+            };
+            end();
         },
         'there should be two deliveries',
         np @deliveries,