← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/libclass-meta-perl/jaunty

« back to all changes in this revision

Viewing changes to t/meth.t

  • Committer: Bazaar Package Importer
  • Author(s): Krzysztof Krzyzaniak (eloy)
  • Date: 2006-01-03 17:29:20 UTC
  • Revision ID: james.westby@ubuntu.com-20060103172920-h94p8qrrav90bzq0
Tags: upstream-0.52
Import upstream version 0.52

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/meth.t
 
1
#!/usr/bin/perl
 
2
 
 
3
# $Id: meth.t 2404 2005-12-17 03:40:23Z theory $
 
4
 
 
5
##############################################################################
 
6
# Set up the tests.
 
7
##############################################################################
 
8
 
 
9
use strict;
 
10
use Test::More tests => 54;
 
11
 
 
12
##############################################################################
 
13
# Create a simple class.
 
14
##############################################################################
 
15
 
 
16
package Class::Meta::TestPerson;
 
17
use strict;
 
18
 
 
19
# Make sure we can load Class::Meta.
 
20
BEGIN { main::use_ok( 'Class::Meta' ) }
 
21
 
 
22
BEGIN {
 
23
    # Import Test::More functions into this package.
 
24
    Test::More->import;
 
25
 
 
26
    # Create a new Class::Meta object.
 
27
    ok( my $c = Class::Meta->new(key     => 'person',
 
28
                                 package => __PACKAGE__),
 
29
        "Create CM object" );
 
30
 
 
31
    isa_ok($c, 'Class::Meta');
 
32
 
 
33
    # Create a new method with all of the parameters set.
 
34
    sub foo_meth { 'foo' }
 
35
    ok( my $meth = $c->add_method(
 
36
        name    => 'foo_meth',
 
37
        desc    => 'The foo method',
 
38
        label   => 'Foo method',
 
39
        context => Class::Meta::CLASS,
 
40
        view    => Class::Meta::PUBLIC
 
41
    ), 'Create foo_meth' );
 
42
 
 
43
    isa_ok($meth, 'Class::Meta::Method');
 
44
 
 
45
    # Test its accessors.
 
46
    is( $meth->name, "foo_meth", "Check foo_meth name" );
 
47
    is( $meth->desc, "The foo method", "Check foo_meth desc" );
 
48
    is( $meth->label, "Foo method", "Check foo_meth label" );
 
49
    ok( $meth->view == Class::Meta::PUBLIC, "Check foo_meth view" );
 
50
    ok( $meth->context == Class::Meta::CLASS, "Check foo_meth context" );
 
51
    is ($meth->call(__PACKAGE__), 'foo', 'Call the foo_meth method' );
 
52
 
 
53
    # Okay, now test to make sure that an attempt to create a method directly
 
54
    # fails.
 
55
    eval { my $meth = Class::Meta::Method->new };
 
56
    ok( my $err = $@, "Get method construction exception");
 
57
    like( $err, qr/Package 'Class::Meta::TestPerson' cannot create/,
 
58
        "Caught proper exception");
 
59
 
 
60
    # Now try it without a name.
 
61
    eval{ $c->add_method() };
 
62
    ok( $err = $@, "Caught no name exception");
 
63
    like( $err, qr/Parameter 'name' is required in call to new/,
 
64
        "Caught proper no name exception");
 
65
 
 
66
    # Try a duplicately-named method.
 
67
    eval{ $c->add_method(name => 'foo_meth') };
 
68
    ok( $err = $@, "Caught dupe name exception");
 
69
    like( $err, qr/Method 'foo_meth' already exists in class/,
 
70
        "Caught proper dupe name exception");
 
71
 
 
72
    # Try a of bogus visibility.
 
73
    eval { $c->add_method( name => 'new_meth',
 
74
                         view  => 10) };
 
75
    ok( $err = $@, "Caught another bogus view exception");
 
76
    like( $err, qr/Not a valid view parameter: '10'/,
 
77
        "Caught another proper bogus view exception");
 
78
 
 
79
    # Try a of bogus context.
 
80
    eval { $c->add_method( name => 'new_meth',
 
81
                         context  => 10) };
 
82
    ok( $err = $@, "Caught another bogus context exception");
 
83
    like( $err, qr/Not a valid context parameter: '10'/,
 
84
        "Caught another proper bogus context exception");
 
85
 
 
86
    # Try a bogus caller.
 
87
    eval { $c->add_method( name => 'new_meth',
 
88
                         caller => 'foo' ) };
 
89
    ok( $err = $@, "Caught bogus caller exception");
 
90
    like( $err, qr/Parameter caller must be a code reference/,
 
91
        "Caught proper bogus caller exception");
 
92
 
 
93
    # Now test all of the defaults.
 
94
    sub new_meth { 22 }
 
95
    ok( $meth = $c->add_method( name => 'new_meth' ), "Create 'new_meth'" );
 
96
    isa_ok($meth, 'Class::Meta::Method');
 
97
 
 
98
    # Test its accessors.
 
99
    is( $meth->name, "new_meth", "Check new_meth name" );
 
100
    ok( ! defined $meth->desc, "Check new_meth desc" );
 
101
    ok( ! defined $meth->label, "Check new_meth label" );
 
102
    ok( $meth->view == Class::Meta::PUBLIC, "Check new_meth view" );
 
103
    ok( $meth->context == Class::Meta::OBJECT, "Check new_meth context" );
 
104
    is( $meth->call(__PACKAGE__), '22', 'Call the new_meth method' );
 
105
 
 
106
    # Now install a method.
 
107
    ok( $meth = $c->add_method(
 
108
        name => 'implicit',
 
109
        code => sub { return 'implicitly' },
 
110
    ), 'Define a method');
 
111
    isa_ok($meth, 'Class::Meta::Method');
 
112
 
 
113
    ok( $c->build, 'Build the class' );
 
114
    can_ok( __PACKAGE__, 'implicit' );
 
115
    is( __PACKAGE__->implicit, 'implicitly',
 
116
        'It should be the method we installed' );
 
117
    is( $meth->call(__PACKAGE__), 'implicitly',
 
118
        'and we should be able to call it indirectly' );
 
119
}
 
120
 
 
121
# Now try subclassing Class::Meta.
 
122
 
 
123
package Class::Meta::SubClass;
 
124
use base 'Class::Meta';
 
125
sub add_method {
 
126
    Class::Meta::Method->new( shift->SUPER::class, @_);
 
127
}
 
128
 
 
129
package Class::Meta::AnotherTest;
 
130
use strict;
 
131
 
 
132
BEGIN {
 
133
    # Import Test::More functions into this package.
 
134
    Test::More->import;
 
135
 
 
136
    # Create a new Class::Meta object.
 
137
    ok( my $c = Class::Meta::SubClass->new(
 
138
        key     => 'another',
 
139
        package => __PACKAGE__
 
140
    ), "Create subclassed CM object" );
 
141
 
 
142
    isa_ok($c, 'Class::Meta');
 
143
    isa_ok($c, 'Class::Meta::SubClass');
 
144
    sub foo_meth { 100 }
 
145
    ok( my $meth = $c->add_method( name => 'foo_meth'),
 
146
        'Create subclassed foo_meth' );
 
147
 
 
148
    isa_ok($meth, 'Class::Meta::Method');
 
149
 
 
150
    # Test its accessors.
 
151
    is( $meth->name, "foo_meth", "Check new foo_meth name" );
 
152
    ok( ! defined $meth->desc, "Check new foo_meth desc" );
 
153
    ok( ! defined $meth->label, "Check new foo_meth label" );
 
154
    ok( $meth->view == Class::Meta::PUBLIC, "Check new foo_meth view" );
 
155
    ok( $meth->context == Class::Meta::OBJECT, "Check new foo_meth context" );
 
156
    is( $meth->call(__PACKAGE__), '100', 'Call the new foo_meth method' );
 
157
}
 
158
 
 
159
##############################################################################
 
160
# Now try subclassing Class::Meta::Method.
 
161
package Class::Meta::Method::Sub;
 
162
use base 'Class::Meta::Method';
 
163
 
 
164
# Make sure we can override new and build.
 
165
sub new { shift->SUPER::new(@_) }
 
166
sub build { shift->SUPER::build(@_) }
 
167
 
 
168
sub foo { shift->{foo} }
 
169
 
 
170
package main;
 
171
ok( my $cm = Class::Meta->new( method_class => 'Class::Meta::Method::Sub'),
 
172
    "Create Class" );
 
173
ok( my $meth = $cm->add_method(name => 'foo', foo => 'bar'),
 
174
    "Add foo method" );
 
175
isa_ok($meth, 'Class::Meta::Method::Sub');
 
176
isa_ok($meth, 'Class::Meta::Method');
 
177
is( $meth->name, 'foo', "Check an attibute");
 
178
is( $meth->foo, 'bar', "Check added attibute");
 
179