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