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