Commit | Line | Data |
b8848347 |
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 | |
1b9e472d |
33 | if (does_role($class_or_obj, $does)) { |
b8848347 |
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 | |
993e62a7 |
56 | # Moose compatible methods/functions |
57 | |
c9313657 |
58 | package |
59 | Mouse::Meta::Module; |
739525d0 |
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 | |
c9313657 |
72 | package |
73 | Mouse::Meta::Role; |
739525d0 |
74 | |
c9313657 |
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; |
993e62a7 |
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() ) { |
3b89ea91 |
108 | my $tc = find_type_constraint($type)->_compiled_type_constraint; |
993e62a7 |
109 | my $as = $into . '::' . $type; |
110 | |
111 | no strict 'refs'; |
112 | *{$as} = sub{ &{$tc} || undef }; |
113 | } |
114 | return; |
115 | } |
116 | |
c9313657 |
117 | package |
118 | Mouse::Meta::Attribute; |
1b9e472d |
119 | |
120 | sub applied_traits{ $_[0]->{traits} } # TEST ONLY |
121 | sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY |
122 | |
b8848347 |
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 | |