aboutsummaryrefslogtreecommitdiff
path: root/t
diff options
context:
space:
mode:
authordakkar <dakkar@thenautilus.net>2016-06-10 14:16:08 +0100
committerdakkar <dakkar@thenautilus.net>2016-06-10 14:16:08 +0100
commit8fd1099cd8b9451fd259e73c590bb0f149a33520 (patch)
tree3a4572bd3f29c2e236114ec2e13159fb6d8c510c /t
parentpasses its first test! (diff)
downloadSietima-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.pm109
-rw-r--r--t/lib/Test2/Tools/MoreCompare.pm55
-rw-r--r--t/tests/compare-bag.t146
-rw-r--r--t/tests/morecompare.t74
-rw-r--r--t/tests/sietima.t23
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,