t/lib/Test/Mouse.pm

   1 package Test::Mouse;
   2
   3 use strict;
   4 use warnings;
   5 use Carp qw(croak);
   6 use Mouse::Util qw(find_meta does_role);
   7
   8 use base qw(Test::Builder::Module);
   9
  10 our @EXPORT = qw(meta_ok does_ok has_attribute_ok);
  11
  12 sub meta_ok ($;$) {
  13     my ($class_or_obj, $message) = @_;
  14
  15     $message ||= "The object has a meta";
  16
  17     if (find_meta($class_or_obj)) {
  18         return __PACKAGE__->builder->ok(1, $message)
  19     }
  20     else {
  21         return __PACKAGE__->builder->ok(0, $message);
  22     }
  23 }
  24
  25 sub does_ok ($$;$) {
  26     my ($class_or_obj, $does, $message) = @_;
  27
  28     if(!defined $does){
  29         croak "You must pass a role name";
  30     }
  31     $message ||= "The object does $does";
  32
  33     if (does_role($class_or_obj, $does)) {
  34         return __PACKAGE__->builder->ok(1, $message)
  35     }
  36     else {
  37         return __PACKAGE__->builder->ok(0, $message);
  38     }
  39 }
  40
  41 sub has_attribute_ok ($$;$) {
  42     my ($class_or_obj, $attr_name, $message) = @_;
  43
  44     $message ||= "The object does has an attribute named $attr_name";
  45
  46     my $meta = find_meta($class_or_obj);
  47
  48     if ($meta->find_attribute_by_name($attr_name)) {
  49         return __PACKAGE__->builder->ok(1, $message)
  50     }
  51     else {
  52         return __PACKAGE__->builder->ok(0, $message);
  53     }
  54 }
  55
  56 # Moose compatible methods/functions
  57
  58 package
  59     Mouse::Meta::Module;
  60
  61 sub version   { no strict 'refs'; ${shift->name.'::VERSION'}   }
  62 sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
  63 sub identifier {
  64     my $self = shift;
  65     return join '-' => (
  66        $self->name,
  67         ($self->version   || ()),
  68         ($self->authority || ()),
  69     );
  70 }
  71
  72 package
  73     Mouse::Meta::Role;
  74
  75 for my $modifier_type (qw/before after around/) {
  76     my $modifier = "${modifier_type}_method_modifiers";
  77     my $has_method_modifiers = sub{
  78         my($self, $method_name) = @_;
  79         my $m = $self->{$modifier}->{$method_name};
  80         return $m && @{$m} != 0;
  81     };
  82
  83     no strict 'refs';
  84     *{ 'has_' . $modifier_type . '_method_modifiers' } = $has_method_modifiers;
  85 }
  86
  87
  88 sub has_override_method_modifier {
  89     my ($self, $method_name) = @_;
  90     return exists $self->{override_method_modifiers}->{$method_name};
  91 }
  92
  93 sub get_method_modifier_list {
  94     my($self, $modifier_type) = @_;
  95
  96     return keys %{ $self->{$modifier_type . '_method_modifiers'} };
  97 }
  98
  99 package
 100     Mouse::Util::TypeConstraints;
 101
 102 use Mouse::Util::TypeConstraints ();
 103
 104 sub export_type_constraints_as_functions { # TEST ONLY
 105     my $into = caller;
 106
 107     foreach my $type( list_all_type_constraints() ) {
 108         my $tc = find_type_constraint($type)->_compiled_type_constraint;
 109         my $as = $into . '::' . $type;
 110
 111         no strict 'refs';
 112         *{$as} = sub{ &{$tc} || undef };
 113     }
 114     return;
 115 }
 116
 117 package
 118     Mouse::Meta::Attribute;
 119
 120 sub applied_traits{            $_[0]->{traits} } # TEST ONLY
 121 sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY
 122
 123 1;
 124
 125 __END__
 126
 127 =pod
 128
 129 =head1 NAME
 130
 131 Test::Mouse - Test functions for Mouse specific features
 132
 133 =head1 SYNOPSIS
 134
 135   use Test::More plan => 1;
 136   use Test::Mouse;
 137
 138   meta_ok($class_or_obj, "... Foo has a ->meta");
 139   does_ok($class_or_obj, $role, "... Foo does the Baz role");
 140   has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute");
 141
 142 =cut
 143