Commit | Line | Data |
73e9153a |
1 | package Test::Mouse; |
2 | |
3 | use Mouse::Exporter; |
4 | use Mouse::Util qw(does_role find_meta); |
5 | |
6 | use Test::Builder; |
7 | |
8 | Mouse::Exporter->setup_import_methods( |
9 | as_is => [qw( |
10 | meta_ok |
11 | does_ok |
12 | has_attribute_ok |
b6f6340b |
13 | with_immutable |
73e9153a |
14 | )], |
15 | ); |
16 | |
17 | ## the test builder instance ... |
18 | |
19 | my $Test = Test::Builder->new; |
20 | |
21 | ## exported functions |
22 | |
23 | sub meta_ok ($;$) { |
24 | my ($class_or_obj, $message) = @_; |
25 | |
26 | $message ||= "The object has a meta"; |
27 | |
28 | if (find_meta($class_or_obj)) { |
29 | return $Test->ok(1, $message) |
30 | } |
31 | else { |
32 | return $Test->ok(0, $message); |
33 | } |
34 | } |
35 | |
36 | sub does_ok ($$;$) { |
37 | my ($class_or_obj, $does, $message) = @_; |
38 | |
39 | $message ||= "The object does $does"; |
40 | |
41 | if (does_role($class_or_obj, $does)) { |
42 | return $Test->ok(1, $message) |
43 | } |
44 | else { |
45 | return $Test->ok(0, $message); |
46 | } |
47 | } |
48 | |
49 | sub has_attribute_ok ($$;$) { |
50 | my ($class_or_obj, $attr_name, $message) = @_; |
51 | |
52 | $message ||= "The object does has an attribute named $attr_name"; |
53 | |
54 | my $meta = find_meta($class_or_obj); |
55 | |
56 | if ($meta->find_attribute_by_name($attr_name)) { |
57 | return $Test->ok(1, $message) |
58 | } |
59 | else { |
60 | return $Test->ok(0, $message); |
61 | } |
62 | } |
63 | |
b6f6340b |
64 | sub with_immutable (&@) { |
65 | my $block = shift; |
66 | |
67 | my $before = $Test->current_test; |
68 | |
69 | $block->(); |
70 | $_->meta->make_immutable for @_; |
71 | $block->(); |
72 | |
73 | my $num_tests = $Test->current_test - $before; |
74 | |
75 | return !grep{ !$_ } ($Test->summary)[-$num_tests .. -1]; |
76 | } |
77 | |
73e9153a |
78 | 1; |
79 | __END__ |
80 | |
81 | =head1 NAME |
82 | |
83 | Test::Mouse - Test functions for Mouse specific features |
84 | |
85 | =head1 SYNOPSIS |
86 | |
87 | use Test::More plan => 1; |
88 | use Test::Mouse; |
89 | |
90 | meta_ok($class_or_obj, "... Foo has a ->meta"); |
91 | does_ok($class_or_obj, $role, "... Foo does the Baz role"); |
92 | has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute"); |
93 | |
94 | =head1 DESCRIPTION |
95 | |
96 | This module provides some useful test functions for Mouse based classes. It |
97 | is an experimental first release, so comments and suggestions are very welcome. |
98 | |
99 | =head1 EXPORTED FUNCTIONS |
100 | |
101 | =over 4 |
102 | |
103 | =item B<meta_ok ($class_or_object)> |
104 | |
105 | Tests if a class or object has a metaclass. |
106 | |
107 | =item B<does_ok ($class_or_object, $role, ?$message)> |
108 | |
109 | Tests if a class or object does a certain role, similar to what C<isa_ok> |
110 | does for the C<isa> method. |
111 | |
112 | =item B<has_attribute_ok($class_or_object, $attr_name, ?$message)> |
113 | |
114 | Tests if a class or object has a certain attribute, similar to what C<can_ok> |
115 | does for the methods. |
116 | |
117 | =back |
118 | |
119 | =head1 SEE ALSO |
120 | |
121 | =over 4 |
122 | |
123 | =item L<Test::More> |
124 | |
125 | =back |
126 | |
127 | =head1 SEE ALSO |
128 | |
129 | L<Mouse> |
130 | |
131 | L<Test::Moose> |
132 | |
133 | =cut |
134 | |