feature: Add prop role to meta checking

lib/Test2/Compare/Meta.pm

@@ -4,6 +4,7 @@ use warnings;
 
 use Test2::Compare::Delta();
 use Test2::Compare::Isa();
+use Test2::Compare::Role();
 
 use base 'Test2::Compare::Base';
 
@@ -54,6 +55,19 @@ sub add_prop {
             $check = Test2::Compare::Isa->new(input => $check);
         }
     }
+    if ($name eq 'role') {    #
+        if (blessed($check) && $check->isa('Test2::Compare::Wildcard')) {
+            # Carry forward file and lines that are set in Test2::Tools::Compare::prop.
+            $check = Test2::Compare::Role->new(
+                input => $check->expect,
+                file  => $check->file,
+                lines => $check->lines,
+            );
+        }
+        else {
+            $check = Test2::Compare::Role->new(input => $check);
+        }
+    }
 
     push @{$self->{+ITEMS}} => [$meth, $check, $name];
 }
@@ -103,6 +117,8 @@ sub get_prop_size {
     return undef;
 }
 
+sub get_prop_role { $_[1] }
+
 1;
 
 __END__
@@ -148,6 +164,11 @@ Lets you check the size of the item. For an arrayref this is the number of
 elements. For a hashref this is the number of keys. For everything else this is
 undef.
 
+=item role
+
+Lets you check if the item has the expected role composed. It uses
+L<Role::Tiny/"does_role"> to achieve this.
+
 =back
 
 =head1 SOURCE

lib/Test2/Compare/Role.pm

@@ -0,0 +1,100 @@
+package Test2::Compare::Role;
+use strict;
+use warnings;
+
+use Carp qw/confess/;
+use Scalar::Util qw/blessed/;
+
+use base 'Test2::Compare::Base';
+
+our $VERSION = '1.302220';
+
+use Test2::Util::HashBase qw/input/;
+
+# Overloads '!' for us.
+use Test2::Compare::Negatable;
+
+sub init {
+    my $self = shift;
+    confess "input must be defined for 'Role' check" unless defined $self->{+INPUT};
+
+    $self->SUPER::init(@_);
+}
+
+sub name {
+    my $self = shift;
+    my $in   = $self->{+INPUT};
+    return "$in";
+}
+
+sub operator {
+    my $self = shift;
+    return '!role' if $self->{+NEGATE};
+    return 'role';
+}
+
+sub verify {
+    my $self   = shift;
+    my %params = @_;
+    my ($got, $exists) = @params{qw/got exists/};
+
+    return 0 unless $exists;
+    return 0 unless eval { require Role::Tiny; 1 };
+
+    my $input  = $self->{+INPUT};
+    my $negate = $self->{+NEGATE};
+    my $role   = Role::Tiny::does_role($got, $input);
+
+    return !$role if $negate;
+    return $role;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Compare::Role - Check if the value does the role.
+
+=head1 DESCRIPTION
+
+This is used to check if the got value does the expected role.
+
+=head1 SOURCE
+
+The source code repository for Test2-Suite can be found at
+F<https://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=item TOYAMA Nao E<lt>nanto@moon.email.ne.jpE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut

lib/Test2/Tools/Compare.pm

@@ -1545,6 +1545,7 @@ B<Note: None of these are exported by default. You need to request them.>
         prop isa     => 'My::Base';   # Ensure value is an instance of our class
         prop size    => 4;            # Check the number of hash keys
         prop this    => ...;          # Check the item itself
+        prop role    => 'My::Role';   # Ensure value does the role (if using Role::Tiny)
     };
 
 =over 4
@@ -1588,6 +1589,11 @@ The thing itself.
 For array references this returns the number of elements. For hashes this
 returns the number of keys. For everything else this returns undef.
 
+=item 'role'
+
+Check if the item has the expected role composed. It uses
+L<Role::Tiny/"does_role"> to achieve this.
+
 =back
 
 =back
@@ -1734,6 +1740,11 @@ The thing itself.
 For array references this returns the number of elements. For hashes this
 returns the number of keys. For everything else this returns undef.
 
+=item 'role'
+
+Check if the item has the expected role composed. It uses
+L<Role::Tiny/"does_role"> to achieve this.
+
 =back
 
 =item DNE()

t/modules/Compare/Meta.t

@@ -87,4 +87,38 @@ subtest deltas => sub {
     );
 };
 
+{
+
+    package Foo::Role {
+        use Role::Tiny;
+    };
+
+    package Foo::Quux {
+        use Role::Tiny::With;
+        with 'Foo::Role';
+    };
+}
+
+subtest role => sub {
+    my $one = $CLASS->new();
+    $one->add_prop('reftype' => 'HASH');
+    $one->add_prop('role'    => 'Foo::Role');
+    my $foo_quux = bless {}, 'Foo::Quux';
+    my $foo      = bless {}, 'Foo';
+    is([$one->deltas(got => $foo_quux, convert => \&convert, seen => {})], [], 'does have the role');
+    like(
+        [
+            $one->deltas(
+                got     => $foo,
+                convert => \&convert,
+                seen    => {}
+            )
+        ],
+        [
+            {verified => F(), got => $foo, children => [], id => ['META' => 'role']},
+        ],
+        "does not have the role"
+    );
+};
+
 done_testing;

t/modules/Compare/Role.t

@@ -0,0 +1,81 @@
+use Test2::Bundle::Extended -target => 'Test2::Compare::Role';
+
+plan skip_all => 'Role::Tiny is required for Role checks' unless eval { require Role::Tiny; 1 };
+
+{
+
+    package Foo { };
+
+    package Foo::Role {
+        use Role::Tiny;
+    };
+
+    package Foo::Role::Over {
+        use Role::Tiny;
+    };
+
+    package Foo::Bar {
+        use Role::Tiny::With;
+        with 'Foo::Role';
+    };
+
+    package Foo::Quux {
+        use Role::Tiny::With;
+        with 'Foo::Role', 'Foo::Role::Over';
+    };
+
+    package Baz { };
+}
+
+my $role_foo      = $CLASS->new(input => 'Foo::Role');
+my $role_foo_over = $CLASS->new(input => 'Foo::Role::Over');
+my $not_role_foo  = $CLASS->new(input => 'Foo::Role', negate => 1);
+
+isa_ok($_, $CLASS, 'Test2::Compare::Base') for $role_foo, $role_foo_over, $not_role_foo;
+
+subtest name => sub {
+    is($role_foo->name,      'Foo::Role',       "got expected name");
+    is($role_foo_over->name, 'Foo::Role::Over', "got expected name");
+    is($not_role_foo->name,  'Foo::Role',       "got expected name");
+};
+
+subtest operator => sub {
+    is($role_foo->operator,      'role',  "got expected operator");
+    is($role_foo_over->operator, 'role',  "got expected operator");
+    is($not_role_foo->operator,  '!role', "got expected operator");
+};
+
+subtest verify => sub {
+    my $foo      = bless {}, 'Foo';
+    my $foo_bar  = bless {}, 'Foo::Bar';
+    my $foo_quux = bless {}, 'Foo::Quux';
+    my $baz      = bless {}, 'Baz';
+
+    ok(!$role_foo->verify(exists => 0, got => undef),     'does not verify against DNE');
+    ok(!$role_foo->verify(exists => 1, got => undef),     'undef has no role Foo::Role');
+    ok(!$role_foo->verify(exists => 1, got => 42),        '42 has no role Foo::Role');
+    ok(!$role_foo->verify(exists => 1, got => $foo),      '$foo has no role Foo::Role');
+    ok($role_foo->verify(exists  => 1, got => $foo_bar),  '$foo_bar has role Foo::Role');
+    ok($role_foo->verify(exists  => 1, got => $foo_quux), '$foo_quux has role Foo::Role');
+    ok(!$role_foo->verify(exists => 1, got => $baz),      '$baz has no role Foo::Role');
+
+    ok(!$role_foo_over->verify(exists => 0, got => undef),     'does not verify against DNE');
+    ok(!$role_foo_over->verify(exists => 1, got => undef),     'undef has no role Foo::Role::Over');
+    ok(!$role_foo_over->verify(exists => 1, got => 42),        '42 has no role Foo::Role::Over');
+    ok(!$role_foo_over->verify(exists => 1, got => $foo),      '$foo has no role Foo::Role::Over');
+    ok(!$role_foo_over->verify(exists => 1, got => $foo_bar),  '$foo_bar has no role Foo::Role::Over');
+    ok($role_foo_over->verify(exists  => 1, got => $foo_quux), '$foo_quux has role Foo::Role::Over');
+    ok(!$role_foo_over->verify(exists => 1, got => $baz),      '$baz has no role Foo::Role::Over');
+
+    ok(!$not_role_foo->verify(exists => 0, got => undef),     'does not verify against DNE');
+    ok($not_role_foo->verify(exists  => 1, got => undef),     'undef has no role Foo::Role');
+    ok($not_role_foo->verify(exists  => 1, got => 42),        '42 has no role Foo::Role');
+    ok($not_role_foo->verify(exists  => 1, got => $foo),      '$foo has no role Foo::Role');
+    ok(!$not_role_foo->verify(exists => 1, got => $foo_bar),  '$foo_bar has role Foo::Role');
+    ok(!$not_role_foo->verify(exists => 1, got => $foo_quux), '$foo_quux has role Foo::Role');
+    ok($not_role_foo->verify(exists  => 1, got => $baz),      '$baz has no role Foo::Role');
+};
+
+like(dies { $CLASS->new() }, qr/input must be defined for 'Role' check/, "Cannot use undef as a class name");
+
+done_testing;