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
141
142
143
144
145
146
147
148
149
150
151
152
|
use Test2::Bundle::Extended -target => 'Test2::Tools::Class';
{
package Temp;
use Test2::Tools::Class;
main::imported_ok(qw/can_ok isa_ok DOES_ok/);
}
{
package X;
sub can {
my $thing = pop;
return 1 if $thing =~ m/x/;
return 1 if $thing eq 'DOES';
}
sub isa {
my $thing = pop;
return 1 if $thing =~ m/x/;
}
sub DOES {
my $thing = pop;
return 1 if $thing =~ m/x/;
}
}
{
package XYZ;
use Carp qw/croak/;
sub isa { croak 'oops' };
sub can { croak 'oops' };
sub DOES { croak 'oops' };
}
{
package My::String;
use overload '""' => sub { "xxx\nyyy" };
sub DOES { 0 }
}
like(
intercept {
my $str = bless {}, 'My::String';
isa_ok('X', qw/axe box fox/);
can_ok('X', qw/axe box fox/);
DOES_ok('X', qw/axe box fox/);
isa_ok($str, 'My::String');
isa_ok('X', qw/foo bar axe box/);
can_ok('X', qw/foo bar axe box/);
DOES_ok('X', qw/foo bar axe box/);
isa_ok($str, 'X');
can_ok($str, 'X');
DOES_ok($str, 'X');
isa_ok(undef, 'X');
isa_ok('', 'X');
isa_ok({}, 'X');
isa_ok('X', [qw/axe box fox/], 'alt name');
can_ok('X', [qw/axe box fox/], 'alt name');
DOES_ok('X', [qw/axe box fox/], 'alt name');
isa_ok('X', [qw/foo bar axe box/], 'alt name');
can_ok('X', [qw/foo bar axe box/], 'alt name');
DOES_ok('X', [qw/foo bar axe box/], 'alt name');
},
array {
event Ok => { pass => 1, name => 'X->isa(...)' };
event Ok => { pass => 1, name => 'X->can(...)' };
event Ok => { pass => 1, name => 'X->DOES(...)' };
event Ok => { pass => 1, name => qr/My::String=.*->isa\('My::String'\)/ };
fail_events Ok => sub { call pass => 0 };
event Diag => {message => "Failed: X->isa('foo')"};
event Diag => {message => "Failed: X->isa('bar')"};
fail_events Ok => sub { call pass => 0 };
event Diag => { message => "Failed: X->can('foo')" };
event Diag => { message => "Failed: X->can('bar')" };
fail_events Ok => sub { call pass => 0 };
event Diag => { message => "Failed: X->DOES('foo')" };
event Diag => { message => "Failed: X->DOES('bar')" };
fail_events Ok => sub { call pass => 0 };
event Diag => { message => qr/Failed: My::String=HASH->isa\('X'\)/ };
fail_events Ok => sub { call pass => 0 };
event Diag => { message => qr/Failed: My::String=HASH->can\('X'\)/ };
fail_events Ok => sub { call pass => 0 };
event Diag => { message => qr/Failed: My::String=HASH->DOES\('X'\)/ };
fail_events Ok => sub { call pass => 0 };
event Diag => { message => qr/<undef> is neither a blessed reference or a package name/ };
fail_events Ok => sub { call pass => 0 };
event Diag => { message => qr/'' is neither a blessed reference or a package name/ };
fail_events Ok => sub { call pass => 0 };
event Diag => { message => qr/HASH is neither a blessed reference or a package name/ };
event Ok => { pass => 1, name => 'alt name' };
event Ok => { pass => 1, name => 'alt name' };
event Ok => { pass => 1, name => 'alt name' };
fail_events Ok => sub { call pass => 0; call name => 'alt name' };
event Diag => {message => "Failed: X->isa('foo')"};
event Diag => {message => "Failed: X->isa('bar')"};
fail_events Ok => sub { call pass => 0; call name => 'alt name' };
event Diag => {message => "Failed: X->can('foo')"};
event Diag => {message => "Failed: X->can('bar')"};
fail_events Ok => sub { call pass => 0; call name => 'alt name' };
event Diag => {message => "Failed: X->DOES('foo')"};
event Diag => {message => "Failed: X->DOES('bar')"};
end;
},
"'can/isa/DOES_ok' events"
);
my $override = UNIVERSAL->can('DOES') ? 1 : 0;
note "Will override UNIVERSAL::can to hide 'DOES'" if $override;
my $events = intercept {
my $can = \&UNIVERSAL::can;
# If the platform does support 'DOES' lets pretend it doesn't.
no warnings 'redefine';
local *UNIVERSAL::can = sub {
my ($thing, $sub) = @_;
return undef if $sub eq 'DOES';
$thing->$can($sub);
} if $override;
DOES_ok('A::Fake::Package', 'xxx');
};
like(
$events,
array {
event Skip => {
pass => 1,
name => "A::Fake::Package->DOES('xxx')",
reason => "'DOES' is not supported on this platform",
};
},
"Test us skipped when platform does not support 'DOES'"
);
done_testing;
|
