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