Checking in changes prior to tagging of version 0.50. Changelog diff is:
[gitmo/Mouse.git] / lib / Test / Mouse.pm
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
13         with_immutable
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
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
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