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