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
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
#!/usr/bin/perl
# $Id: meth.t 2404 2005-12-17 03:40:23Z theory $
##############################################################################
# Set up the tests.
##############################################################################
use strict;
use Test::More tests => 54;
##############################################################################
# Create a simple class.
##############################################################################
package Class::Meta::TestPerson;
use strict;
# Make sure we can load Class::Meta.
BEGIN { main::use_ok( 'Class::Meta' ) }
BEGIN {
# Import Test::More functions into this package.
Test::More->import;
# Create a new Class::Meta object.
ok( my $c = Class::Meta->new(key => 'person',
package => __PACKAGE__),
"Create CM object" );
isa_ok($c, 'Class::Meta');
# Create a new method with all of the parameters set.
sub foo_meth { 'foo' }
ok( my $meth = $c->add_method(
name => 'foo_meth',
desc => 'The foo method',
label => 'Foo method',
context => Class::Meta::CLASS,
view => Class::Meta::PUBLIC
), 'Create foo_meth' );
isa_ok($meth, 'Class::Meta::Method');
# Test its accessors.
is( $meth->name, "foo_meth", "Check foo_meth name" );
is( $meth->desc, "The foo method", "Check foo_meth desc" );
is( $meth->label, "Foo method", "Check foo_meth label" );
ok( $meth->view == Class::Meta::PUBLIC, "Check foo_meth view" );
ok( $meth->context == Class::Meta::CLASS, "Check foo_meth context" );
is ($meth->call(__PACKAGE__), 'foo', 'Call the foo_meth method' );
# Okay, now test to make sure that an attempt to create a method directly
# fails.
eval { my $meth = Class::Meta::Method->new };
ok( my $err = $@, "Get method construction exception");
like( $err, qr/Package 'Class::Meta::TestPerson' cannot create/,
"Caught proper exception");
# Now try it without a name.
eval{ $c->add_method() };
ok( $err = $@, "Caught no name exception");
like( $err, qr/Parameter 'name' is required in call to new/,
"Caught proper no name exception");
# Try a duplicately-named method.
eval{ $c->add_method(name => 'foo_meth') };
ok( $err = $@, "Caught dupe name exception");
like( $err, qr/Method 'foo_meth' already exists in class/,
"Caught proper dupe name exception");
# Try a of bogus visibility.
eval { $c->add_method( name => 'new_meth',
view => 10) };
ok( $err = $@, "Caught another bogus view exception");
like( $err, qr/Not a valid view parameter: '10'/,
"Caught another proper bogus view exception");
# Try a of bogus context.
eval { $c->add_method( name => 'new_meth',
context => 10) };
ok( $err = $@, "Caught another bogus context exception");
like( $err, qr/Not a valid context parameter: '10'/,
"Caught another proper bogus context exception");
# Try a bogus caller.
eval { $c->add_method( name => 'new_meth',
caller => 'foo' ) };
ok( $err = $@, "Caught bogus caller exception");
like( $err, qr/Parameter caller must be a code reference/,
"Caught proper bogus caller exception");
# Now test all of the defaults.
sub new_meth { 22 }
ok( $meth = $c->add_method( name => 'new_meth' ), "Create 'new_meth'" );
isa_ok($meth, 'Class::Meta::Method');
# Test its accessors.
is( $meth->name, "new_meth", "Check new_meth name" );
ok( ! defined $meth->desc, "Check new_meth desc" );
ok( ! defined $meth->label, "Check new_meth label" );
ok( $meth->view == Class::Meta::PUBLIC, "Check new_meth view" );
ok( $meth->context == Class::Meta::OBJECT, "Check new_meth context" );
is( $meth->call(__PACKAGE__), '22', 'Call the new_meth method' );
# Now install a method.
ok( $meth = $c->add_method(
name => 'implicit',
code => sub { return 'implicitly' },
), 'Define a method');
isa_ok($meth, 'Class::Meta::Method');
ok( $c->build, 'Build the class' );
can_ok( __PACKAGE__, 'implicit' );
is( __PACKAGE__->implicit, 'implicitly',
'It should be the method we installed' );
is( $meth->call(__PACKAGE__), 'implicitly',
'and we should be able to call it indirectly' );
}
# Now try subclassing Class::Meta.
package Class::Meta::SubClass;
use base 'Class::Meta';
sub add_method {
Class::Meta::Method->new( shift->SUPER::class, @_);
}
package Class::Meta::AnotherTest;
use strict;
BEGIN {
# Import Test::More functions into this package.
Test::More->import;
# Create a new Class::Meta object.
ok( my $c = Class::Meta::SubClass->new(
key => 'another',
package => __PACKAGE__
), "Create subclassed CM object" );
isa_ok($c, 'Class::Meta');
isa_ok($c, 'Class::Meta::SubClass');
sub foo_meth { 100 }
ok( my $meth = $c->add_method( name => 'foo_meth'),
'Create subclassed foo_meth' );
isa_ok($meth, 'Class::Meta::Method');
# Test its accessors.
is( $meth->name, "foo_meth", "Check new foo_meth name" );
ok( ! defined $meth->desc, "Check new foo_meth desc" );
ok( ! defined $meth->label, "Check new foo_meth label" );
ok( $meth->view == Class::Meta::PUBLIC, "Check new foo_meth view" );
ok( $meth->context == Class::Meta::OBJECT, "Check new foo_meth context" );
is( $meth->call(__PACKAGE__), '100', 'Call the new foo_meth method' );
}
##############################################################################
# Now try subclassing Class::Meta::Method.
package Class::Meta::Method::Sub;
use base 'Class::Meta::Method';
# Make sure we can override new and build.
sub new { shift->SUPER::new(@_) }
sub build { shift->SUPER::build(@_) }
sub foo { shift->{foo} }
package main;
ok( my $cm = Class::Meta->new( method_class => 'Class::Meta::Method::Sub'),
"Create Class" );
ok( my $meth = $cm->add_method(name => 'foo', foo => 'bar'),
"Add foo method" );
isa_ok($meth, 'Class::Meta::Method::Sub');
isa_ok($meth, 'Class::Meta::Method');
is( $meth->name, 'foo', "Check an attibute");
is( $meth->foo, 'bar', "Check added attibute");
|
