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
# Formal testing for Class::Inspector
# Do all the tests on ourself, since we know we will be loaded.
use strict;
BEGIN {
$| = 1;
$^W = 1;
}
use Class::Handle;
use Test::More tests => 36;
# Set up any needed globals
use vars qw{$ch $bad};
BEGIN {
# To make maintaining this a little faster,
# $CI is defined as Class::Inspector, and
# $bad for a class we know doesn't exist.
$ch = 'Class::Handle';
$bad = 'Class::Handle::Nonexistant';
}
# Check the good/bad class name code
ok( $ch->new( $ch ), 'Constructor allows known valid' );
ok( $ch->new( $bad ), 'Constructor allows correctly formatted, but not installed' );
ok( $ch->new( 'A::B::C::D::E' ), 'Constructor allows long classes' );
ok( $ch->new( '::' ), 'Constructor allows main' );
ok( $ch->new( '::Blah' ), 'Constructor allows main aliased' );
ok( ! $ch->new(), 'Constructor fails for missing class' );
ok( ! $ch->new( '4teen' ), 'Constructor fails for number starting class' );
ok( ! $ch->new( 'Blah::%f' ), 'Constructor catches bad characters' );
# Create a dummy class for the remainder of the test
{
package Class::Handle::Dummy;
use strict;
use base 'Class::Handle';
use vars qw{$VERSION};
BEGIN {
$VERSION = '12.34';
}
sub dummy1 { 1; }
sub dummy2 { 2; }
sub dummy3 { 3; }
}
# Check a newly returned object
my $DUMMY = $ch->new( 'Class::Handle::Dummy' );
ok( UNIVERSAL::isa( $DUMMY, 'HASH' ), 'New object is a hash reference' );
isa_ok( $DUMMY, 'Class::Handle' );
ok( (scalar keys %$DUMMY == 1), 'Object contains only one key' );
ok( exists $DUMMY->{name}, "The key is named correctly" );
ok( $DUMMY->{name} eq 'Class::Handle::Dummy', "The contents of the key is correct" );
ok( $DUMMY->name eq 'Class::Handle::Dummy', "->name returns class name" );
# Check the UNIVERSAL related methods
is( $ch->VERSION, $Class::Handle::VERSION, '->VERSION in static context returns Class::Handle version' );
ok( $DUMMY->VERSION eq '12.34', '->VERSION in object context returns handle classes version' );
ok( $ch->isa( 'UNIVERSAL' ), 'Static ->isa works' );
ok( $DUMMY->isa( 'Class::Handle::Dummy' ), 'Object ->isa works' );
ok( $ch->can( 'new' ), 'Static ->can works' );
ok( $DUMMY->can( 'dummy1' ), 'Object ->can works' );
# Check the Class::Inspector related methods
my $CI = Class::Handle->new( 'Class::Inspector' );
my $bad = Class::Handle->new( 'Class::Handle::Nonexistant' );
ok( $CI->loaded, "->loaded detects loaded" );
ok( ! $bad->loaded, "->loaded detects not loaded" );
my $filename = $CI->filename;
is( $filename, File::Spec->catfile( 'Class', 'Inspector.pm' ), "->filename works correctly" );
ok( -f $CI->loaded_filename,
"->loaded_filename works" );
ok( -f $CI->resolved_filename,
"->resolved_filename works" );
ok( $CI->installed, "->installed detects installed" );
ok( ! $bad->installed, "->installed detects not installed" );
my $functions = $CI->functions;
ok( (ref($functions) eq 'ARRAY'
and $functions->[0] eq '_class'
and scalar @$functions >= 14),
"->functions works correctly" );
ok( ! $bad->functions, "->functions fails correctly" );
$functions = $CI->function_refs;
ok( (ref($functions) eq 'ARRAY'
and ref $functions->[0]
and ref($functions->[0]) eq 'CODE'
and scalar @$functions >= 14),
"->function_refs works correctly" );
ok( ! $bad->function_refs, "->function_refs fails correctly" );
ok( $CI->function_exists( 'installed' ),
"->function_exists detects function that exists" );
ok( ! $CI->function_exists('nsfladf' ),
"->function_exists fails for bad function" );
ok( ! $CI->function_exists,
"->function_exists fails for missing function" );
my $CH = $ch->new( $ch );
isa_ok( $CH, $ch );
my $subclasses = $CH->subclasses;
is_deeply( $subclasses, [ 'Class::Handle::Dummy' ],
'->subclasses returns as expected' );
# Tests for Class::ISA related methods
# missing, ugh
|
