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
|
#!perl
use strict;
use warnings;
use lib 't/lib';
use Test::More tests => 16;
use Test::SmallWarn;
# must happen here to register warnings category
BEGIN { use_ok( 'UNIVERSAL::can' ) };
{
package Logger;
use Scalar::Util 'blessed';
use vars '$AUTOLOAD';
sub new
{
my ($class, $object) = @_;
bless { object => $object, calls => [] }, $class;
}
sub object
{
my $self = shift;
return $self->{object} if blessed( $self );
return $self;
}
sub calls
{
my $self = shift;
return $self->{calls};
}
sub can
{
my ($self, $name) = @_;
my $object = $self->object();
return $self->SUPER::can( $name ) if $object->isa( __PACKAGE__ );
my $wrapped_method = $self->object->can( $name );
}
sub DESTROY {}
sub AUTOLOAD
{
my $self = shift;
my ($method) = $AUTOLOAD =~ /::(\w+)$/;
return unless my $coderef = $self->object->can( $method );
push @{ $self->calls() }, $method;
$self->object->$coderef( @_ );
}
package Logged;
sub new
{
my $class = shift;
bless \$class, $class;
}
sub foo
{
my $self = shift;
return 'foo'; }
package Liar;
use vars '$AUTOLOAD';
sub can
{
my $self = shift;
return Logger->can( shift );
}
sub DESTROY {}
sub AUTOLOAD
{
my $self = shift;
my ($method) = $AUTOLOAD =~ /::(\w+)$/;
return Logger->$method( @_ );
}
}
my $logger = Logger->new( 'Logged' );
my $can_new = $logger->can( 'new' );
my $can_foo = $logger->can( 'foo' );
ok( defined $can_new, 'can() should return true for defined class methods' );
ok( defined &$can_new, '... returning a code reference' );
is( $can_foo, \&Logged::foo, '... the correct code reference' );
my $uncan_foo;
warning_like { $uncan_foo = UNIVERSAL::can( $logger, 'foo' ) }
qr/Called UNIVERSAL::can\(\) as a function, not a method at t.class.t/,
'calling UNIVERSAL::can() as function on invocant should warn';
ok( defined $uncan_foo, 'UNIVERSAL::can() should return true then too' );
ok( defined &$uncan_foo, '... returning a code reference' );
is( $uncan_foo, \&Logged::foo, '... the correct code reference' );
my $can_calls = Logger->can( 'calls' );
ok( defined $can_calls,
'can() should return true for methods called as class methods' );
my $can_falls = Logger->can( 'falls' );
ok( ! defined $can_falls,
'... and false for nonexistant methods' );
my $uncan_liar;
warning_like { $uncan_liar = UNIVERSAL::can( 'Liar', 'new' ) }
qr/Called UNIVERSAL::can\(\) as a function, not a method at t.class.t/,
'calling UNIVERSAL::can() as function on class name invocant should warn';
{
no warnings;
warnings_are { $uncan_liar = UNIVERSAL::can( 'Liar', 'new' ) }
[], '... but only with warnings enabled';
}
{
no warnings 'UNIVERSAL::can';
warnings_are { $uncan_liar = UNIVERSAL::can( 'Liar', 'new' ) }
[], '... and not with warnings diabled for UNIVERSAL::can';
}
ok( defined $uncan_liar, 'can() should return true for class can() method' );
ok( defined &$uncan_liar, '... returning a code reference' );
is( $uncan_liar, \&Logger::new, '... the correct code reference' );
|
