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