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