lib/Test/Moose.pm

   1 package Test::Moose;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Sub::Exporter;
   7 use Test::Builder;
   8
   9 use List::MoreUtils 'all';
  10 use Moose::Util 'does_role', 'find_meta';
  11
  12 our $VERSION   = '0.93';
  13 $VERSION = eval $VERSION;
  14 our $AUTHORITY = 'cpan:STEVAN';
  15
  16 my @exports = qw[
  17     meta_ok
  18     does_ok
  19     has_attribute_ok
  20     with_immutable
  21 ];
  22
  23 Sub::Exporter::setup_exporter({
  24     exports => \@exports,
  25     groups  => { default => \@exports }
  26 });
  27
  28 ## the test builder instance ...
  29
  30 my $Test = Test::Builder->new;
  31
  32 ## exported functions
  33
  34 sub meta_ok ($;$) {
  35     my ($class_or_obj, $message) = @_;
  36
  37     $message ||= "The object has a meta";
  38
  39     if (find_meta($class_or_obj)) {
  40         return $Test->ok(1, $message)
  41     }
  42     else {
  43         return $Test->ok(0, $message);
  44     }
  45 }
  46
  47 sub does_ok ($$;$) {
  48     my ($class_or_obj, $does, $message) = @_;
  49
  50     $message ||= "The object does $does";
  51
  52     if (does_role($class_or_obj, $does)) {
  53         return $Test->ok(1, $message)
  54     }
  55     else {
  56         return $Test->ok(0, $message);
  57     }
  58 }
  59
  60 sub has_attribute_ok ($$;$) {
  61     my ($class_or_obj, $attr_name, $message) = @_;
  62
  63     $message ||= "The object does has an attribute named $attr_name";
  64
  65     my $meta = find_meta($class_or_obj);
  66
  67     if ($meta->find_attribute_by_name($attr_name)) {
  68         return $Test->ok(1, $message)
  69     }
  70     else {
  71         return $Test->ok(0, $message);
  72     }
  73 }
  74
  75 sub with_immutable (&@) {
  76     my $block = shift;
  77     my $before = $Test->current_test;
  78     $block->();
  79     $_->meta->make_immutable for @_;
  80     $block->();
  81     my $num_tests = $Test->current_test - $before;
  82     return all { $_ } ($Test->summary)[-$num_tests..-1];
  83 }
  84
  85 1;
  86
  87 __END__
  88
  89 =pod
  90
  91 =head1 NAME
  92
  93 Test::Moose - Test functions for Moose specific features
  94
  95 =head1 SYNOPSIS
  96
  97   use Test::More plan => 1;
  98   use Test::Moose;
  99
 100   meta_ok($class_or_obj, "... Foo has a ->meta");
 101   does_ok($class_or_obj, $role, "... Foo does the Baz role");
 102   has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute");
 103
 104 =head1 DESCRIPTION
 105
 106 This module provides some useful test functions for Moose based classes. It
 107 is an experimental first release, so comments and suggestions are very welcome.
 108
 109 =head1 EXPORTED FUNCTIONS
 110
 111 =over 4
 112
 113 =item B<meta_ok ($class_or_object)>
 114
 115 Tests if a class or object has a metaclass.
 116
 117 =item B<does_ok ($class_or_object, $role, ?$message)>
 118
 119 Tests if a class or object does a certain role, similar to what C<isa_ok>
 120 does for the C<isa> method.
 121
 122 =item B<has_attribute_ok($class_or_object, $attr_name, ?$message)>
 123
 124 Tests if a class or object has a certain attribute, similar to what C<can_ok>
 125 does for the methods.
 126
 127 =back
 128
 129 =head1 TODO
 130
 131 =over 4
 132
 133 =item Convert the Moose test suite to use this module.
 134
 135 =item Here is a list of possible functions to write
 136
 137 =over 4
 138
 139 =item immutability predicates
 140
 141 =item anon-class predicates
 142
 143 =item discovering original method from modified method
 144
 145 =item attribute metaclass predicates (attribute_isa?)
 146
 147 =back
 148
 149 =back
 150
 151 =head1 SEE ALSO
 152
 153 =over 4
 154
 155 =item L<Test::More>
 156
 157 =back
 158
 159 =head1 BUGS
 160
 161 All complex software has bugs lurking in it, and this module is no
 162 exception. If you find a bug please either email me, or add the bug
 163 to cpan-RT.
 164
 165 =head1 AUTHOR
 166
 167 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 168
 169 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 170
 171 =head1 COPYRIGHT AND LICENSE
 172
 173 Copyright 2007-2009 by Infinity Interactive, Inc.
 174
 175 L<http://www.iinteractive.com>
 176
 177 This library is free software; you can redistribute it and/or modify
 178 it under the same terms as Perl itself.
 179
 180 =cut
 181