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   = '1.9900';
  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     Class::MOP::class_of($_)->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 =item B<with_immutable { CODE } @class_names>
 128
 129 Runs B<CODE> (which should contain normal tests) twice, and make each
 130 class in C<@class_names> immutable in between the two runs.
 131
 132 =back
 133
 134 =head1 TODO
 135
 136 =over 4
 137
 138 =item Convert the Moose test suite to use this module.
 139
 140 =item Here is a list of possible functions to write
 141
 142 =over 4
 143
 144 =item immutability predicates
 145
 146 =item anon-class predicates
 147
 148 =item discovering original method from modified method
 149
 150 =item attribute metaclass predicates (attribute_isa?)
 151
 152 =back
 153
 154 =back
 155
 156 =head1 SEE ALSO
 157
 158 =over 4
 159
 160 =item L<Test::More>
 161
 162 =back
 163
 164 =head1 BUGS
 165
 166 See L<Moose/BUGS> for details on reporting bugs.
 167
 168 =head1 AUTHOR
 169
 170 Anders Nor Berle E<lt>debolaz@gmail.comE<gt>
 171
 172 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 173
 174 =head1 COPYRIGHT AND LICENSE
 175
 176 Copyright 2007-2009 by Infinity Interactive, Inc.
 177
 178 L<http://www.iinteractive.com>
 179
 180 This library is free software; you can redistribute it and/or modify
 181 it under the same terms as Perl itself.
 182
 183 =cut
 184