home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / Test / Moose.pm next >
Encoding:
Perl POD Document  |  2010-07-25  |  3.5 KB  |  185 lines

  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.09';
  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. =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.  
  185.