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 | |
58 | package Mouse::Util::TypeConstraints; |
59 | |
60 | use Mouse::Util::TypeConstraints (); |
61 | |
62 | sub export_type_constraints_as_functions { # TEST ONLY |
63 | my $into = caller; |
64 | |
65 | foreach my $type( list_all_type_constraints() ) { |
66 | my $tc = find_type_constraint($type)->{_compiled_type_constraint}; |
67 | my $as = $into . '::' . $type; |
68 | |
69 | no strict 'refs'; |
70 | *{$as} = sub{ &{$tc} || undef }; |
71 | } |
72 | return; |
73 | } |
74 | |
1b9e472d |
75 | package Mouse::Meta::Attribute; |
76 | |
77 | sub applied_traits{ $_[0]->{traits} } # TEST ONLY |
78 | sub has_applied_traits{ exists $_[0]->{traits} } # TEST ONLY |
79 | |
b8848347 |
80 | 1; |
81 | |
82 | __END__ |
83 | |
84 | =pod |
85 | |
86 | =head1 NAME |
87 | |
88 | Test::Mouse - Test functions for Mouse specific features |
89 | |
90 | =head1 SYNOPSIS |
91 | |
92 | use Test::More plan => 1; |
93 | use Test::Mouse; |
94 | |
95 | meta_ok($class_or_obj, "... Foo has a ->meta"); |
96 | does_ok($class_or_obj, $role, "... Foo does the Baz role"); |
97 | has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute"); |
98 | |
99 | =cut |
100 | |