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
|
#!/usr/bin/perl
use strict;
BEGIN
{
$| = 1;
$^W = 1;
$ENV{PERL_PARAMS_UTIL_PP} ||= 1;
}
use Test::More tests => 91;
use File::Spec::Functions ':ALL';
BEGIN
{
ok(!defined &_CLASSISA, '_CLASSISA does not exist');
ok(!defined &_SUBCLASS, '_SUBCLASS does not exist');
ok(!defined &_DRIVER, '_DRIVER does not exist');
use_ok('Params::Util', qw(_CLASSISA _SUBCLASS _DRIVER));
ok(defined &_CLASSISA, '_CLASSISA imported ok');
ok(defined &_SUBCLASS, '_SUBCLASS imported ok');
ok(defined &_DRIVER, '_DRIVER imported ok');
}
# Import refaddr to make certain we have it
use Scalar::Util 'refaddr';
#####################################################################
# Preparing
my $A = catfile('t', 'driver', 'A.pm');
ok(-f $A, 'A exists');
my $B = catfile('t', 'driver', 'My_B.pm');
ok(-f $B, 'My_B exists');
my $C = catfile('t', 'driver', 'C.pm');
ok(!-f $C, 'C does not exist');
my $D = catfile('t', 'driver', 'D.pm');
ok(-f $D, 'D does not exist');
my $E = catfile('t', 'driver', 'E.pm');
ok(-f $E, 'E does not exist');
my $F = catfile('t', 'driver', 'F.pm');
ok(-f $F, 'F does not exist');
unshift @INC, catdir('t', 'driver');
#####################################################################
# Things that are not file handles
foreach (undef, '', ' ', 'foo bar', 1, 0, -1, 1.23, [], {}, \'', bless({}, "foo"))
{
is(_CLASSISA($_, 'A'), undef, 'Non-classisa returns undef');
is(_SUBCLASS($_, 'A'), undef, 'Non-subclass returns undef');
is(_DRIVER($_, 'A'), undef, 'Non-driver returns undef');
}
#####################################################################
# Sample Classes
# classisa should not load classes
is(_CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef');
is(_CLASSISA('My_B', 'A'), undef, 'B: Good driver returns ok');
is(_CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base');
is(_CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef');
is(_CLASSISA('D', 'A'), undef, 'D: Broken driver is undef');
is(_CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef');
is(_CLASSISA('F', 'A'), undef, 'F: Faked isa returns ok');
# classisa should not load classes
is(_SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef');
is(_SUBCLASS('My_B', 'A'), undef, 'B: Good driver returns ok');
is(_SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base');
is(_SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef');
is(_SUBCLASS('D', 'A'), undef, 'D: Broken driver is undef');
is(_SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef');
is(_SUBCLASS('F', 'A'), undef, 'F: Faked isa returns ok');
# The base class itself is not a driver
is(_DRIVER('A', 'A'), undef, 'A: Driver base class is undef');
ok($A::VERSION, 'A: Class is loaded ok');
is(_DRIVER('My_B', 'A'), 'My_B', 'B: Good driver returns ok');
is(_DRIVER('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base');
ok($My_B::VERSION, 'B: Class is loaded ok');
is(_DRIVER('C', 'A'), undef, 'C: Non-existant driver is undef');
is(_DRIVER('D', 'A'), undef, 'D: Broken driver is undef');
is(_DRIVER('E', 'A'), undef, 'E: Not a driver returns undef');
is(_DRIVER('F', 'A'), 'F', 'F: Faked isa returns ok');
# Repeat for classisa
is(_CLASSISA('A', 'A'), 'A', 'A: Driver base class is undef');
is(_CLASSISA('My_B', 'A'), 'My_B', 'B: Good driver returns ok');
is(_CLASSISA('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base');
is(_CLASSISA('C', 'A'), undef, 'C: Non-existant driver is undef');
is(_CLASSISA('D', 'A'), 'D', 'D: Broken driver is undef');
is(_CLASSISA('E', 'A'), undef, 'E: Not a driver returns undef');
is(_CLASSISA('F', 'A'), 'F', 'F: Faked isa returns ok');
# Repeat for subclasses
is(_SUBCLASS('A', 'A'), undef, 'A: Driver base class is undef');
is(_SUBCLASS('My_B', 'A'), 'My_B', 'B: Good driver returns ok');
is(_SUBCLASS('My_B', 'H'), undef, 'B: Good driver return undef for incorrect base');
is(_SUBCLASS('C', 'A'), undef, 'C: Non-existant driver is undef');
is(_SUBCLASS('D', 'A'), 'D', 'D: Broken driver is undef');
is(_SUBCLASS('E', 'A'), undef, 'E: Not a driver returns undef');
is(_SUBCLASS('F', 'A'), 'F', 'F: Faked isa returns ok');
SKIP:
{
use_ok('Params::Util', qw(_CLASSDOES));
skip "DOES tests do not make sense on perls before 5.10", 4
unless $] >= 5.010;
is(_CLASSDOES('A', 'A'), 'A', 'A: DOES A');
is(_CLASSDOES('My_B', 'A'), 'My_B', 'My_B: DOES A');
is(_CLASSDOES('E', 'A'), undef, 'E: DOES not A');
is(_CLASSDOES('F', 'A'), 'F', 'F: DOES A');
}
|
