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