Commit | Line | Data |
9a641848 |
1 | package Test::Moose; |
2 | |
9a641848 |
3 | use strict; |
4 | use warnings; |
5 | |
7125b244 |
6 | use Sub::Exporter; |
7 | use Test::Builder; |
6532ca5a |
8 | use Moose::Util 'does_role', 'find_meta'; |
9a641848 |
9 | |
7125b244 |
10 | our $VERSION = '0.01'; |
11 | our $AUTHORITY = 'cpan:STEVAN'; |
9a641848 |
12 | |
7125b244 |
13 | my @exports = qw[ |
14 | meta_ok |
15 | does_ok |
16 | has_attribute_ok |
17 | ]; |
9a641848 |
18 | |
7125b244 |
19 | Sub::Exporter::setup_exporter({ |
20 | exports => \@exports, |
21 | groups => { default => \@exports } |
22 | }); |
9a641848 |
23 | |
6532ca5a |
24 | ## the test builder instance ... |
9a641848 |
25 | |
6532ca5a |
26 | my $Test = Test::Builder->new; |
9a641848 |
27 | |
7125b244 |
28 | ## exported functions |
9a641848 |
29 | |
7125b244 |
30 | sub meta_ok ($;$) { |
31 | my ($class_or_obj, $message) = @_; |
32 | |
33 | $message ||= "The object has a meta"; |
34 | |
6532ca5a |
35 | if (find_meta($class_or_obj)) { |
7125b244 |
36 | return $Test->ok(1, $message) |
37 | } |
38 | else { |
39 | return $Test->ok(0, $message); |
40 | } |
9a641848 |
41 | } |
42 | |
43 | sub does_ok ($$;$) { |
7125b244 |
44 | my ($class_or_obj, $does, $message) = @_; |
45 | |
46 | $message ||= "The object does $does"; |
47 | |
6532ca5a |
48 | if (does_role($class_or_obj, $does)) { |
7125b244 |
49 | return $Test->ok(1, $message) |
50 | } |
51 | else { |
52 | return $Test->ok(0, $message); |
53 | } |
54 | } |
9a641848 |
55 | |
7125b244 |
56 | sub has_attribute_ok ($$;$) { |
57 | my ($class_or_obj, $attr_name, $message) = @_; |
58 | |
59 | $message ||= "The object does has an attribute named $attr_name"; |
60 | |
6532ca5a |
61 | my $meta = find_meta($class_or_obj); |
7125b244 |
62 | |
63 | if ($meta->find_attribute_by_name($attr_name)) { |
64 | return $Test->ok(1, $message) |
65 | } |
66 | else { |
67 | return $Test->ok(0, $message); |
68 | } |
9a641848 |
69 | } |
70 | |
71 | 1; |
72 | |
73 | __END__ |
74 | |
75 | =pod |
76 | |
77 | =head1 NAME |
78 | |
79 | Test::Moose - Test functions for Moose specific features |
80 | |
81 | =head1 SYNOPSIS |
82 | |
7125b244 |
83 | use Test::More plan => 1; |
84 | use Test::Moose; |
9a641848 |
85 | |
7125b244 |
86 | meta_ok($class_or_obj, "... Foo has a ->meta"); |
87 | does_ok($class_or_obj, $role, "... Foo does the Baz role"); |
88 | has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute"); |
9a641848 |
89 | |
7125b244 |
90 | =head1 DESCRIPTION |
91 | |
92 | This module provides some useful test functions for Moose based classes. It |
93 | is an experimental first release, so comments and suggestions are very welcome. |
94 | |
95 | =head1 EXPORTED FUNCTIONS |
9a641848 |
96 | |
97 | =over 4 |
98 | |
7125b244 |
99 | =item B<meta_ok ($class_or_object)> |
100 | |
101 | Tests if a class or object has a metaclass. |
102 | |
103 | =item B<does_ok ($class_or_object, $role, ?$message)> |
9a641848 |
104 | |
7125b244 |
105 | Tests if a class or object does a certain role, similar to what C<isa_ok> |
106 | does for the C<isa> method. |
9a641848 |
107 | |
7125b244 |
108 | =item B<has_attribute_ok($class_or_object, $attr_name, ?$message)> |
109 | |
110 | Tests if a class or object has a certain attribute, similar to what C<can_ok> |
111 | does for the methods. |
112 | |
113 | =back |
114 | |
115 | =head1 TODO |
116 | |
117 | =over 4 |
118 | |
119 | =item Convert the Moose test suite to use this module. |
120 | |
121 | =item Here is a list of possible functions to write |
122 | |
123 | =over 4 |
124 | |
125 | =item immutability predicates |
126 | |
127 | =item anon-class predicates |
128 | |
129 | =item discovering original method from modified method |
130 | |
131 | =item attribute metaclass predicates (attribute_isa?) |
132 | |
133 | =back |
9a641848 |
134 | |
135 | =back |
136 | |
137 | =head1 SEE ALSO |
138 | |
139 | =over 4 |
140 | |
141 | =item L<Test::More> |
142 | |
143 | =back |
144 | |
145 | =head1 BUGS |
146 | |
147 | All complex software has bugs lurking in it, and this module is no |
148 | exception. If you find a bug please either email me, or add the bug |
149 | to cpan-RT. |
150 | |
151 | =head1 AUTHOR |
152 | |
153 | Anders Nor Berle E<lt>debolaz@gmail.comE<gt> |
154 | |
7125b244 |
155 | Stevan Little E<lt>stevan@iinteractive.comE<gt> |
156 | |
9a641848 |
157 | =head1 COPYRIGHT AND LICENSE |
158 | |
159 | Copyright 2007 by Infinity Interactive, Inc. |
160 | |
161 | L<http://www.iinteractive.com> |
162 | |
163 | This library is free software; you can redistribute it and/or modify |
164 | it under the same terms as Perl itself. |
165 | |
166 | =cut |
167 | |