1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
|
=head1 PURPOSE
Test various scalars and roles to check we get expected results.
=head1 AUTHOR
Toby Inkster E<lt>tobyink@cpan.orgE<gt>.
=head1 COPYRIGHT AND LICENCE
This software is copyright (c) 2012-2014 by Toby Inkster.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
use strict;
use warnings;
use Test::More;
use Scalar::Does;
{
package Local::Does::Array;
use overload '@{}' => 'array';
sub new { bless +{ array=>[] }, pop };
sub array { return shift->{array} };
sub DOES { return 1 if $_[1] eq 'Monkey'; shift->SUPER::DOES(@_) }
}
{
package Local::Does::Not;
sub new { bless +{ array=>[] }, pop };
sub can { return if $_[1] eq 'DOES'; shift->SUPER::can(@_) }
sub DOES { +die }
}
{
package Cruddy::Role;
sub new { bless +{ array=>[] }, pop };
}
{
package Permissive::Role;
sub new { bless +{ array=>[] }, pop };
sub check { 1 }
}
my %tests = (
undef => [
undef,
does => [qw( 0+ "" bool )],
doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL )],
],
ARRAY => [
[],
does => [qw( ARRAY @{} )],
doesnt => [qw( HASH %{} )],
],
HASH => [
+{},
does => [qw( HASH %{} )],
doesnt => [qw( ARRAY @{} )],
],
SCALAR => [
\"Hello World",
does => [qw( SCALAR ${} )],
doesnt => [qw( ARRAY HASH @{} %{} CODE Regexp Foo::Bar UNIVERSAL )],
],
CODE => [
sub { 1 },
does => [qw( CODE &{} )],
doesnt => [qw( SCALAR @{} UNIVERSAL )],
],
Blessed_CODE => [
bless(sub { 1 } => 'Foo::Bar'),
does => [qw( CODE &{} Foo::Bar UNIVERSAL )],
doesnt => [qw( SCALAR @{} Regexp )],
],
Overloaded_Object => [
Local::Does::Array->new,
does => [qw( ARRAY @{} HASH %{} Local::Does::Array UNIVERSAL Monkey )],
doesnt => [qw( CODE bool "" Gorilla )],
],
Overloaded_Class => [
'Local::Does::Array',
does => [qw( bool "" Local::Does::Array UNIVERSAL Monkey )],
doesnt => [qw( CODE Gorilla HASH %{} ARRAY @{} )],
],
STDOUT => [
\*STDOUT,
does => [qw( IO <> GLOB *{} )],
doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL )],
],
Lvalue => [
\(substr($INC[0], 0, 1)),
does => [qw( LVALUE )],
doesnt => [qw( SCALAR @{} Regexp CODE &{} Foo::Bar UNIVERSAL IO GLOB )],
],
Object_without_DOES_method => [
Local::Does::Not->new,
does => [qw( HASH )],
doesnt => [qw( Local::Does::Not )],
],
Class_without_DOES_method => [
'Local::Does::Not',
does => [qw( )],
doesnt => [qw( Local::Does::Not HASH )],
],
);
my @uncheck = (
Cruddy::Role->new,
[],
'FlibbleSocks',
);
my @check = (
Permissive::Role->new,
);
foreach my $name (sort keys %tests)
{
my ($value, %cases) = @{ $tests{$name} };
foreach my $tc (@{ $cases{does} }) {
ok(does($value, $tc), "$name does $tc");
}
foreach my $tc (@{ $cases{doesnt} }) {
ok(!does($value, $tc), "$name doesn't $tc");
}
ok( does($value, $_), "$name does $_") for @check;
ok(!does($value, $_), "$name doesn't do uncheckable role $_") for @uncheck;
}
done_testing();
|
