diff options
author | dakkar <dakkar@thenautilus.net> | 2016-06-10 14:16:08 +0100 |
---|---|---|
committer | dakkar <dakkar@thenautilus.net> | 2016-06-10 14:16:08 +0100 |
commit | 8fd1099cd8b9451fd259e73c590bb0f149a33520 (patch) | |
tree | 3a4572bd3f29c2e236114ec2e13159fb6d8c510c /t | |
parent | passes its first test! (diff) | |
download | Sietima-8fd1099cd8b9451fd259e73c590bb0f149a33520.tar.gz Sietima-8fd1099cd8b9451fd259e73c590bb0f149a33520.tar.bz2 Sietima-8fd1099cd8b9451fd259e73c590bb0f149a33520.zip |
more tests!
also, some test library
Diffstat (limited to 't')
-rw-r--r-- | t/lib/Test2/Compare/Bag.pm | 109 | ||||
-rw-r--r-- | t/lib/Test2/Tools/MoreCompare.pm | 55 | ||||
-rw-r--r-- | t/tests/compare-bag.t | 146 | ||||
-rw-r--r-- | t/tests/morecompare.t | 74 | ||||
-rw-r--r-- | t/tests/sietima.t | 23 |
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, |