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
|
#!/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' );
}
|
