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
|
#!/usr/bin/perl
use strict;
BEGIN {
$| = 1;
$^W = 1;
$ENV{PERL_PARAMS_UTIL_PP} ||= 1;
}
sub _CODELIKE($);
use Test::More;
use File::Spec::Functions ':ALL';
use Scalar::Util qw(
blessed
reftype
refaddr
);
use overload;
sub c_ok { is(
refaddr(_CODELIKE($_[0])),
refaddr($_[0]),
"callable: $_[1]",
) }
sub nc_ok {
my $left = shift;
$left = _CODELIKE($left);
is( $left, undef, "not callable: $_[0]" );
}
my @callables = (
"callable itself" => \&_CODELIKE,
"a boring plain code ref" => sub {},
'an object with overloaded &{}' => C::O->new,
'a object build from a coderef' => C::C->new,
'an object with inherited overloaded &{}' => C::O::S->new,
'a coderef blessed into CODE' => (bless sub {} => 'CODE'),
);
my @uncallables = (
"undef" => undef,
"a string" => "a string",
"a number" => 19780720,
"a ref to a ref to code" => \(sub {}),
"a boring plain hash ref" => {},
'a class that builds from coderefs' => "C::C",
'a class with overloaded &{}' => "C::O",
'a class with inherited overloaded &{}' => "C::O::S",
'a plain boring hash-based object' => UC->new,
'a non-coderef blessed into CODE' => (bless {} => 'CODE'),
);
my $tests = (@callables + @uncallables) / 2 + 2;
if ( $] > 5.006 ) {
push @uncallables, 'a regular expression', qr/foo/;
$tests += 1;
}
plan tests => $tests;
# Import the function
use_ok( 'Params::Util', '_CODELIKE' );
ok( defined *_CODELIKE{CODE}, '_CODELIKE imported ok' );
while ( @callables ) {
my $name = shift @callables;
my $object = shift @callables;
c_ok( $object, $name );
}
while ( @uncallables ) {
my $name = shift @uncallables;
my $object = shift @uncallables;
nc_ok( $object, $name );
}
######################################################################
# callable: is a blessed code ref
package C::C;
sub new {
bless sub {} => shift;
}
######################################################################
# callable: overloads &{}
# but only objects are callable, not class
package C::O;
sub new {
bless {} => shift;
}
use overload '&{}' => sub { sub {} };
use overload 'bool' => sub () { 1 };
######################################################################
# callable: subclasses C::O
package C::O::S;
use vars qw{@ISA};
BEGIN {
@ISA = 'C::O';
}
######################################################################
# uncallable: some boring object with no codey magic
package UC;
sub new {
bless {} => shift;
}
|
