Add tests
[gitmo/Mouse.git] / lib / Mouse / Meta / Module.pm
CommitLineData
3a63a2e7 1package Mouse::Meta::Module;
1d76ae62 2use Mouse::Util qw/:meta/; # enables strict and warnings
3a63a2e7 3
b397e301 4use Carp ();
5use Scalar::Util ();
fce211ae 6
fe1221ad 7my %METAS;
8536d351 8
029463f4 9if(Mouse::Util::MOUSE_XS){
fd168725 10 # register meta storage for performance
11 Mouse::Util::__register_metaclass_storage(\%METAS, 0);
12
13 # ensure thread safety
14 *CLONE = sub { Mouse::Util::__register_metaclass_storage(\%METAS, 1) };
15}
16
deb9a0f3 17sub _metaclass_cache { # DEPRECATED
230dd14a 18 my($self, $name) = @_;
8b0573c6 19 Carp::cluck('_metaclass_cache() has been deprecated. Use Mouse::Util::get_metaclass_by_name() instead');
fe1221ad 20 return $METAS{$name};
739525d0 21}
8536d351 22
739525d0 23sub initialize {
24 my($class, $package_name, @args) = @_;
8536d351 25
739525d0 26 ($package_name && !ref($package_name))
27 || $class->throw_error("You must pass a package name and it cannot be blessed");
8536d351 28
fe1221ad 29 return $METAS{$package_name}
739525d0 30 ||= $class->_construct_meta(package => $package_name, @args);
31}
8536d351 32
542f20ad 33sub reinitialize {
34 my($class, $package_name, @args) = @_;
35
f87debb9 36 $package_name = $package_name->name if ref $package_name;
37
542f20ad 38 ($package_name && !ref($package_name))
39 || $class->throw_error("You must pass a package name and it cannot be blessed");
40
902174eb 41 if(exists $METAS{$package_name}) {
42 unshift @args, %{ $METAS{$package_name} };
43 }
542f20ad 44 delete $METAS{$package_name};
45 return $class->initialize($package_name, @args);
46}
47
48sub _class_of{
739525d0 49 my($class_or_instance) = @_;
50 return undef unless defined $class_or_instance;
23274b88 51 return $METAS{ ref($class_or_instance) || $class_or_instance };
8536d351 52}
53
739525d0 54# Means of accessing all the metaclasses that have
55# been initialized thus far
542f20ad 56#sub _get_all_metaclasses { %METAS }
57sub _get_all_metaclass_instances { values %METAS }
58sub _get_all_metaclass_names { keys %METAS }
59sub _get_metaclass_by_name { $METAS{$_[0]} }
60#sub _store_metaclass_by_name { $METAS{$_[0]} = $_[1] }
61#sub _weaken_metaclass { weaken($METAS{$_[0]}) }
62#sub _does_metaclass_exist { defined $METAS{$_[0]} }
63#sub _remove_metaclass_by_name { delete $METAS{$_[0]} }
739525d0 64
43165725 65sub name;
3a63a2e7 66
2591e962 67sub namespace;
68
8536d351 69# add_attribute is an abstract method
70
deb9a0f3 71sub get_attribute_map { # DEPRECATED
8b0573c6 72 Carp::cluck('get_attribute_map() has been deprecated. Use get_attribute_list() and get_attribute() instead');
3a683350 73 return $_[0]->{attributes};
74}
75
8536d351 76sub has_attribute { exists $_[0]->{attributes}->{$_[1]} }
77sub get_attribute { $_[0]->{attributes}->{$_[1]} }
6cfa1e5e 78sub remove_attribute { delete $_[0]->{attributes}->{$_[1]} }
23264b5b 79
047d7af0 80sub get_attribute_list{ keys %{$_[0]->{attributes}} }
81
2fd74baf 82# XXX: not completely compatible with Moose
01afd8ff 83my %foreign = map{ $_ => undef } qw(
84 Mouse Mouse::Role Mouse::Util Mouse::Util::TypeConstraints
81bc0675 85 Carp Scalar::Util List::Util
01afd8ff 86);
cf267e67 87sub _get_method_body {
88 my($self, $method_name) = @_;
89 my $code = Mouse::Util::get_code_ref($self->{package}, $method_name);
90 return $code && !exists $foreign{ Mouse::Util::get_code_package($code) }
91 ? $code
92 : undef;
3a63a2e7 93}
94
3e44140b 95sub add_method;
96
3a63a2e7 97sub has_method {
98 my($self, $method_name) = @_;
78dc5ed1 99 defined($method_name)
100 or $self->throw_error('You must define a method name');
101
cf267e67 102 return defined( $self->{methods}{$method_name} )
103 || defined( $self->_get_method_body($method_name) );
3a63a2e7 104}
105
81bc0675 106sub get_method_body {
71e7b544 107 my($self, $method_name) = @_;
71e7b544 108 defined($method_name)
109 or $self->throw_error('You must define a method name');
110
cf267e67 111 return $self->{methods}{$method_name}
112 ||= $self->_get_method_body($method_name);
71e7b544 113}
114
cf267e67 115sub get_method {
6cfa1e5e 116 my($self, $method_name) = @_;
117
81bc0675 118 if(my $code = $self->get_method_body($method_name)){
637d4f17 119 return Mouse::Util::load_class($self->method_metaclass)->wrap(
81bc0675 120 body => $code,
9010458d 121 name => $method_name,
60e446e8 122 package => $self->name,
9010458d 123 associated_metaclass => $self,
6cfa1e5e 124 );
125 }
126
127 return undef;
8536d351 128}
3a63a2e7 129
8e64d0fa 130sub get_method_list {
3a63a2e7 131 my($self) = @_;
8e64d0fa 132
133 return grep { $self->has_method($_) } keys %{ $self->namespace };
3a63a2e7 134}
135
013ee5f0 136sub _collect_methods { # Mouse specific
137 my($meta, @args) = @_;
138
139 my @methods;
140 foreach my $arg(@args){
141 if(my $type = ref $arg){
142 if($type eq 'Regexp'){
143 push @methods, grep { $_ =~ $arg } $meta->get_all_method_names;
144 }
145 elsif($type eq 'ARRAY'){
146 push @methods, @{$arg};
147 }
148 else{
149 my $subname = ( caller(1) )[3];
150 $meta->throw_error(
151 sprintf(
a4faea11 152 'Methods passed to %s must be provided as a list,'
153 . ' ArrayRef or regular expression, not %s',
013ee5f0 154 $subname,
155 $type,
156 )
157 );
158 }
159 }
160 else{
161 push @methods, $arg;
162 }
163 }
164 return @methods;
165}
166
72dc2c9d 167my $ANON_SERIAL = 0; # anonymous class/role id
168my %IMMORTALS; # immortal anonymous classes
013ee5f0 169
72dc2c9d 170sub create {
171 my($self, $package_name, %options) = @_;
7a50b450 172
72dc2c9d 173 my $class = ref($self) || $self;
174 $self->throw_error('You must pass a package name') if @_ < 2;
7a50b450 175
72dc2c9d 176 my $superclasses;
177 if(exists $options{superclasses}){
178 if(Mouse::Util::is_a_metarole($self)){
179 delete $options{superclasses};
8f40866c 180 }
72dc2c9d 181 else{
182 $superclasses = delete $options{superclasses};
183 (ref $superclasses eq 'ARRAY')
184 || $self->throw_error("You must pass an ARRAY ref of superclasses");
7a50b450 185 }
72dc2c9d 186 }
7a50b450 187
72dc2c9d 188 my $attributes = delete $options{attributes};
189 if(defined $attributes){
190 (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
191 || $self->throw_error("You must pass an ARRAY ref of attributes");
192 }
193 my $methods = delete $options{methods};
194 if(defined $methods){
195 (ref $methods eq 'HASH')
196 || $self->throw_error("You must pass a HASH ref of methods");
197 }
198 my $roles = delete $options{roles};
199 if(defined $roles){
200 (ref $roles eq 'ARRAY')
201 || $self->throw_error("You must pass an ARRAY ref of roles");
202 }
203 my $mortal;
204 my $cache_key;
205
206 if(!defined $package_name){ # anonymous
207 $mortal = !$options{cache};
208
209 # anonymous but immortal
210 if(!$mortal){
211 # something like Super::Class|Super::Class::2=Role|Role::1
212 $cache_key = join '=' => (
213 join('|', @{$superclasses || []}),
214 join('|', sort @{$roles || []}),
215 );
216 return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
7a50b450 217 }
72dc2c9d 218 $options{anon_serial_id} = ++$ANON_SERIAL;
219 $package_name = $class . '::__ANON__::' . $ANON_SERIAL;
220 }
7a50b450 221
72dc2c9d 222 # instantiate a module
223 {
224 no strict 'refs';
225 ${ $package_name . '::VERSION' } = delete $options{version} if exists $options{version};
226 ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
227 }
228
229 my $meta = $self->initialize( $package_name, %options);
230
73063f7b 231 Scalar::Util::weaken($METAS{$package_name})
72dc2c9d 232 if $mortal;
233
a062712d 234 $meta->add_method(meta => sub {
72dc2c9d 235 $self->initialize(ref($_[0]) || $_[0]);
236 });
237
238 $meta->superclasses(@{$superclasses})
239 if defined $superclasses;
240
241 # NOTE:
242 # process attributes first, so that they can
243 # install accessors, but locally defined methods
244 # can then overwrite them. It is maybe a little odd, but
245 # I think this should be the order of things.
246 if (defined $attributes) {
247 if(ref($attributes) eq 'ARRAY'){
248 # array of Mouse::Meta::Attribute
249 foreach my $attr (@{$attributes}) {
250 $meta->add_attribute($attr);
7a50b450 251 }
252 }
72dc2c9d 253 else{
254 # hash map of name and attribute spec pairs
255 while(my($name, $attr) = each %{$attributes}){
256 $meta->add_attribute($name => $attr);
7a50b450 257 }
258 }
72dc2c9d 259 }
260 if (defined $methods) {
261 while(my($method_name, $method_body) = each %{$methods}){
262 $meta->add_method($method_name, $method_body);
7a50b450 263 }
72dc2c9d 264 }
265 if (defined $roles){
266 Mouse::Util::apply_all_roles($package_name, @{$roles});
267 }
7a50b450 268
72dc2c9d 269 if($cache_key){
270 $IMMORTALS{$cache_key} = $meta;
7a50b450 271 }
272
72dc2c9d 273 return $meta;
274}
7a50b450 275
72dc2c9d 276sub DESTROY{
277 my($self) = @_;
39a8df63 278
72dc2c9d 279 return if $Mouse::Util::in_global_destruction;
7a50b450 280
72dc2c9d 281 my $serial_id = $self->{anon_serial_id};
72dc2c9d 282 return if !$serial_id;
e75f21db 283
a4faea11 284 # XXX: cleaning stash with threads causes panic/SEGV on legacy perls.
20a12328 285 if(exists $INC{'threads.pm'}) {
286 # (caller)[2] indicates the caller's line number,
a4faea11 287 # which is zero when the current thread is joining (destroying).
20a12328 288 return if( (caller)[2] == 0);
289 }
290
a4faea11 291 # clean up mortal anonymous class stuff
292
293 # @ISA is a magical variable, so we must clear it manually.
72dc2c9d 294 @{$self->{superclasses}} = () if exists $self->{superclasses};
7a50b450 295
72dc2c9d 296 # Then, clear the symbol table hash
297 %{$self->namespace} = ();
8f40866c 298
72dc2c9d 299 my $name = $self->name;
300 delete $METAS{$name};
7a50b450 301
72dc2c9d 302 $name =~ s/ $serial_id \z//xms;
72dc2c9d 303 no strict 'refs';
304 delete ${$name}{ $serial_id . '::' };
72dc2c9d 305 return;
7a50b450 306}
307
3a63a2e7 308
3091;
3a63a2e7 310__END__
311
312=head1 NAME
313
a4faea11 314Mouse::Meta::Module - The common base class of Mouse::Meta::Class and Mouse::Meta::Role
3a63a2e7 315
a25ca8d6 316=head1 VERSION
317
b11787bf 318This document describes Mouse version 0.80
a25ca8d6 319
503ed648 320=head1 DESCRIPTION
321
a4faea11 322This class is an abstract base class of meta classes and meta roles.
503ed648 323
b995be6a 324=head1 SEE ALSO
325
31c5194b 326L<Class::MOP::Class>
327
328L<Class::MOP::Module>
329
330L<Class::MOP::Package>
b995be6a 331
3a63a2e7 332=cut
2cea7a5f 333