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