Mouse::Util::does_role() respects $thing->does() method

[gitmo/Mouse.git] / lib / Test / Mouse.pm

diff --git a/lib/Test/Mouse.pm b/lib/Test/Mouse.pm
index 34697eb..ff1b98d 100644 (file)
--- a/lib/Test/Mouse.pm
+++ b/lib/Test/Mouse.pm
@@ -10,6 +10,7 @@ Mouse::Exporter->setup_import_methods(
         meta_ok
         does_ok
         has_attribute_ok
+        with_immutable
     )],
 );
 
@@ -19,7 +20,7 @@ my $Test = Test::Builder->new;
 
 ## exported functions
 
-sub meta_ok ($;$) {
+sub meta_ok ($;$) { ## no critic
     my ($class_or_obj, $message) = @_;
 
     $message ||= "The object has a meta";
@@ -32,7 +33,7 @@ sub meta_ok ($;$) {
     }
 }
 
-sub does_ok ($$;$) {
+sub does_ok ($$;$) { ## no critic
     my ($class_or_obj, $does, $message) = @_;
 
     $message ||= "The object does $does";
@@ -45,7 +46,7 @@ sub does_ok ($$;$) {
     }
 }
 
-sub has_attribute_ok ($$;$) {
+sub has_attribute_ok ($$;$) { ## no critic
     my ($class_or_obj, $attr_name, $message) = @_;
 
     $message ||= "The object does has an attribute named $attr_name";
@@ -60,6 +61,20 @@ sub has_attribute_ok ($$;$) {
     }
 }
 
+sub with_immutable (&@) { ## no critic
+    my $block = shift;
+
+    my $before = $Test->current_test;
+
+    $block->();
+    $_->meta->make_immutable for @_;
+    $block->();
+    return if not defined wantarray;
+
+    my $num_tests = $Test->current_test - $before;
+    return !grep{ !$_ } ($Test->summary)[-$num_tests .. -1];
+}
+
 1;
 __END__
 
@@ -99,13 +114,10 @@ does for the C<isa> method.
 Tests if a class or object has a certain attribute, similar to what C<can_ok>
 does for the methods.
 
-=back
+=item B<with_immutable { CODE } @class_names>
 
-=head1 SEE ALSO
-
-=over 4
-
-=item L<Test::More>
+Runs I<CODE> *which should contain normal tests) twice, and make each
+class in I<@class_names> immutable between the two runs.
 
 =back
 
@@ -115,5 +127,7 @@ L<Mouse>
 
 L<Test::Moose>
 
+L<Test::More>
+
 =cut