Commit | Line | Data |
df6dd016 |
1 | package |
2 | Mouse::Util; |
3 | |
4 | use strict; |
5 | use warnings; |
6 | |
7 | use warnings FATAL => 'redefine'; # to avoid to load Mouse::PurePerl |
8 | |
9 | use B (); |
10 | |
11 | sub is_class_loaded { |
12 | my $class = shift; |
13 | |
14 | return 0 if ref($class) || !defined($class) || !length($class); |
15 | |
16 | # walk the symbol table tree to avoid autovififying |
17 | # \*{${main::}{"Foo::"}} == \*main::Foo:: |
18 | |
19 | my $pack = \%::; |
20 | foreach my $part (split('::', $class)) { |
21 | my $entry = \$pack->{$part . '::'}; |
22 | return 0 if ref($entry) ne 'GLOB'; |
23 | $pack = *{$entry}{HASH} or return 0; |
24 | } |
25 | |
26 | # check for $VERSION or @ISA |
27 | return 1 if exists $pack->{VERSION} |
28 | && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} }; |
29 | return 1 if exists $pack->{ISA} |
30 | && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0; |
31 | |
32 | # check for any method |
33 | foreach my $name( keys %{$pack} ) { |
34 | my $entry = \$pack->{$name}; |
35 | return 1 if ref($entry) ne 'GLOB' || defined *{$entry}{CODE}; |
36 | } |
37 | |
38 | # fail |
39 | return 0; |
40 | } |
41 | |
42 | |
43 | # taken from Sub::Identify |
44 | sub get_code_info { |
45 | my ($coderef) = @_; |
46 | ref($coderef) or return; |
47 | |
48 | my $cv = B::svref_2object($coderef); |
49 | $cv->isa('B::CV') or return; |
50 | |
51 | my $gv = $cv->GV; |
52 | $gv->isa('B::GV') or return; |
53 | |
54 | return ($gv->STASH->NAME, $gv->NAME); |
55 | } |
56 | |
57 | sub get_code_package{ |
58 | my($coderef) = @_; |
59 | |
60 | my $cv = B::svref_2object($coderef); |
61 | $cv->isa('B::CV') or return ''; |
62 | |
63 | my $gv = $cv->GV; |
64 | $gv->isa('B::GV') or return ''; |
65 | |
66 | return $gv->STASH->NAME; |
67 | } |
68 | |
7d96ae4d |
69 | sub get_code_ref{ |
70 | my($package, $name) = @_; |
71 | no strict 'refs'; |
72 | no warnings 'once'; |
73 | use warnings FATAL => 'uninitialized'; |
74 | return *{$package . '::' . $name}{CODE}; |
75 | } |
76 | |
77 | package |
78 | Mouse::Util::TypeConstraints; |
79 | |
02d8cd0a |
80 | use Scalar::Util qw(blessed looks_like_number openhandle); |
81 | |
1d5ecd5f |
82 | sub _generate_class_type_for{ |
83 | my($for_class, $name) = @_; |
84 | |
02d8cd0a |
85 | my $predicate = sub{ blessed($_[0]) && $_[0]->isa($for_class) }; |
1d5ecd5f |
86 | |
87 | if(defined $name){ |
88 | no strict 'refs'; |
89 | *{ caller() . '::' . $name } = $predicate; |
90 | return; |
91 | } |
92 | |
93 | return $predicate; |
94 | } |
95 | |
96 | |
7d96ae4d |
97 | sub Any { 1 } |
98 | sub Item { 1 } |
7d96ae4d |
99 | |
100 | sub Bool { $_[0] ? $_[0] eq '1' : 1 } |
101 | sub Undef { !defined($_[0]) } |
102 | sub Defined { defined($_[0]) } |
103 | sub Value { defined($_[0]) && !ref($_[0]) } |
104 | sub Num { !ref($_[0]) && looks_like_number($_[0]) } |
105 | sub Int { defined($_[0]) && !ref($_[0]) && $_[0] =~ /^-?[0-9]+$/ } |
106 | sub Str { defined($_[0]) && !ref($_[0]) } |
107 | |
108 | sub Ref { ref($_[0]) } |
109 | sub ScalarRef { ref($_[0]) eq 'SCALAR' } |
110 | sub ArrayRef { ref($_[0]) eq 'ARRAY' } |
111 | sub HashRef { ref($_[0]) eq 'HASH' } |
112 | sub CodeRef { ref($_[0]) eq 'CODE' } |
113 | sub RegexpRef { ref($_[0]) eq 'Regexp' } |
114 | sub GlobRef { ref($_[0]) eq 'GLOB' } |
115 | |
116 | sub FileHandle { |
117 | openhandle($_[0]) || (blessed($_[0]) && $_[0]->isa("IO::Handle")) |
118 | } |
119 | |
120 | sub Object { blessed($_[0]) && blessed($_[0]) ne 'Regexp' } |
121 | |
122 | sub ClassName { Mouse::Util::is_class_loaded($_[0]) } |
123 | sub RoleName { (Mouse::Util::class_of($_[0]) || return 0)->isa('Mouse::Meta::Role') } |
124 | |
125 | |
43165725 |
126 | package |
127 | Mouse::Meta::Module; |
128 | |
926404f2 |
129 | sub name { $_[0]->{package} } |
130 | |
131 | sub _method_map { $_[0]->{methods} } |
132 | sub _attribute_map{ $_[0]->{attribute_map} } |
43165725 |
133 | |
2591e962 |
134 | sub namespace{ |
135 | my $name = $_[0]->{package}; |
136 | no strict 'refs'; |
137 | return \%{ $name . '::' }; |
138 | } |
139 | |
3e44140b |
140 | sub add_method { |
141 | my($self, $name, $code) = @_; |
142 | |
143 | if(!defined $name){ |
144 | $self->throw_error('You must pass a defined name'); |
145 | } |
146 | if(!defined $code){ |
147 | $self->throw_error('You must pass a defined code'); |
148 | } |
149 | |
150 | if(ref($code) ne 'CODE'){ |
151 | $code = \&{$code}; # coerce |
152 | } |
153 | |
154 | $self->{methods}->{$name} = $code; # Moose stores meta object here. |
155 | |
156 | my $pkg = $self->name; |
157 | no strict 'refs'; |
158 | no warnings 'redefine', 'once'; |
159 | *{ $pkg . '::' . $name } = $code; |
160 | return; |
161 | } |
162 | |
163 | |
43165725 |
164 | package |
165 | Mouse::Meta::Class; |
166 | |
167 | sub is_anon_class{ |
168 | return exists $_[0]->{anon_serial_id}; |
169 | } |
170 | |
171 | sub roles { $_[0]->{roles} } |
172 | |
cccb83de |
173 | sub linearized_isa { @{ get_linear_isa($_[0]->{package}) } } |
174 | |
43165725 |
175 | package |
176 | Mouse::Meta::Role; |
177 | |
178 | sub is_anon_role{ |
179 | return exists $_[0]->{anon_serial_id}; |
180 | } |
181 | |
182 | sub get_roles { $_[0]->{roles} } |
183 | |
184 | package |
185 | Mouse::Meta::Attribute; |
186 | |
d7d8d49b |
187 | use Mouse::Meta::Method::Accessor; |
43165725 |
188 | |
189 | # readers |
190 | |
191 | sub name { $_[0]->{name} } |
192 | sub associated_class { $_[0]->{associated_class} } |
193 | |
194 | sub accessor { $_[0]->{accessor} } |
195 | sub reader { $_[0]->{reader} } |
196 | sub writer { $_[0]->{writer} } |
197 | sub predicate { $_[0]->{predicate} } |
198 | sub clearer { $_[0]->{clearer} } |
199 | sub handles { $_[0]->{handles} } |
200 | |
201 | sub _is_metadata { $_[0]->{is} } |
202 | sub is_required { $_[0]->{required} } |
203 | sub default { $_[0]->{default} } |
204 | sub is_lazy { $_[0]->{lazy} } |
205 | sub is_lazy_build { $_[0]->{lazy_build} } |
206 | sub is_weak_ref { $_[0]->{weak_ref} } |
207 | sub init_arg { $_[0]->{init_arg} } |
208 | sub type_constraint { $_[0]->{type_constraint} } |
209 | |
210 | sub trigger { $_[0]->{trigger} } |
211 | sub builder { $_[0]->{builder} } |
212 | sub should_auto_deref { $_[0]->{auto_deref} } |
213 | sub should_coerce { $_[0]->{coerce} } |
214 | |
d899d3e7 |
215 | sub documentation { $_[0]->{documentation} } |
216 | |
43165725 |
217 | # predicates |
218 | |
219 | sub has_accessor { exists $_[0]->{accessor} } |
220 | sub has_reader { exists $_[0]->{reader} } |
221 | sub has_writer { exists $_[0]->{writer} } |
222 | sub has_predicate { exists $_[0]->{predicate} } |
223 | sub has_clearer { exists $_[0]->{clearer} } |
224 | sub has_handles { exists $_[0]->{handles} } |
225 | |
226 | sub has_default { exists $_[0]->{default} } |
227 | sub has_type_constraint { exists $_[0]->{type_constraint} } |
228 | sub has_trigger { exists $_[0]->{trigger} } |
229 | sub has_builder { exists $_[0]->{builder} } |
230 | |
d899d3e7 |
231 | sub has_documentation { exists $_[0]->{documentation} } |
232 | |
93540011 |
233 | sub accessor_metaclass(){ 'Mouse::Meta::Method::Accessor' } |
234 | |
43165725 |
235 | package |
236 | Mouse::Meta::TypeConstraint; |
237 | |
238 | sub name { $_[0]->{name} } |
239 | sub parent { $_[0]->{parent} } |
240 | sub message { $_[0]->{message} } |
241 | |
242 | sub _compiled_type_constraint{ $_[0]->{compiled_type_constraint} } |
243 | |
93540011 |
244 | sub _compiled_type_coercion { $_[0]->{_compiled_type_coercion} } |
df6dd016 |
245 | |
93540011 |
246 | |
247 | sub has_coercion{ exists $_[0]->{_compiled_type_coercion} } |
df6dd016 |
248 | |
249 | 1; |
250 | __END__ |