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 ($;$) { ## no critic
  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 ($$;$) { ## no critic
  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 ($$;$) { ## no critic
  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 (&@) { ## no critic
  65     my $block = shift;
  66
  67     my $before = $Test->current_test;
  68
  69     $block->();
  70     $_->meta->make_immutable for @_;
  71     $block->();
  72     return if not defined wantarray;
  73
  74     my $num_tests = $Test->current_test - $before;
  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 =item B<with_immutable { CODE } @class_names>
 118
 119 Runs I<CODE> *which should contain normal tests) twice, and make each
 120 class in I<@class_names> immutable between the two runs.
 121
 122 =back
 123
 124 =head1 SEE ALSO
 125
 126 L<Mouse>
 127
 128 L<Test::Moose>
 129
 130 L<Test::More>
 131
 132 =cut
 133