Avoid autovivification
[gitmo/Mouse.git] / lib / Test / Mouse.pm
CommitLineData
73e9153a 1package Test::Mouse;
2
3use Mouse::Exporter;
4use Mouse::Util qw(does_role find_meta);
5
6use Test::Builder;
7
8Mouse::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
19my $Test = Test::Builder->new;
20
21## exported functions
22
23sub 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
36sub 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
49sub 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 64sub 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 781;
79__END__
80
81=head1 NAME
82
83Test::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
96This module provides some useful test functions for Mouse based classes. It
97is 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
105Tests if a class or object has a metaclass.
106
107=item B<does_ok ($class_or_object, $role, ?$message)>
108
109Tests if a class or object does a certain role, similar to what C<isa_ok>
110does for the C<isa> method.
111
112=item B<has_attribute_ok($class_or_object, $attr_name, ?$message)>
113
114Tests if a class or object has a certain attribute, similar to what C<can_ok>
115does 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
129L<Mouse>
130
131L<Test::Moose>
132
133=cut
134