2 package Class::MOP::Class;
8 use Scalar::Util 'blessed', 'reftype';
9 use Sub::Name 'subname';
10 use B 'svref_2object';
12 our $VERSION = '0.01';
17 # Metaclasses are singletons, so we cache them here.
18 # there is no need to worry about destruction though
19 # because they should die only when the program dies.
20 # After all, do package definitions even get reaped?
23 my ($class, $package_name) = @_;
24 (defined $package_name && $package_name)
25 || confess "You must pass a package name";
26 $METAS{$package_name} ||= bless \$package_name => blessed($class) || $class;
31 my ($class, $package_name, $package_version, %options) = @_;
32 (defined $package_name && $package_name)
33 || confess "You must pass a package name";
34 my $code = "package $package_name;";
35 $code .= "\$$package_name\:\:VERSION = '$package_version';"
36 if defined $package_version;
38 confess "creation of $package_name failed : $@" if $@;
39 my $meta = $class->initialize($package_name);
40 $meta->superclasses(@{$options{superclasses}})
41 if exists $options{superclasses};
42 if (exists $options{methods}) {
43 foreach my $method_name (keys %{$options{methods}}) {
44 $meta->add_method($method_name, $options{methods}->{$method_name});
57 ${$self->name . '::VERSION'};
67 @{$self->name . '::ISA'} = @supers;
69 @{$self->name . '::ISA'};
72 sub class_precedence_list {
75 # We need to check for ciruclar inheirtance here.
76 # This will do nothing if all is well, and blow
77 # up otherwise. Yes, it's an ugly hack, better
78 # suggestions are welcome.
79 { $self->name->isa('This is a test for circular inheritance') }
80 # ... and no back to our regularly scheduled program
84 $self->initialize($_)->class_precedence_list()
85 } $self->superclasses()
92 my ($self, $method_name, $method) = @_;
93 (defined $method_name && $method_name)
94 || confess "You must define a method name";
95 # use reftype here to allow for blessed subs ...
96 (reftype($method) && reftype($method) eq 'CODE')
97 || confess "Your code block must be a CODE reference";
98 my $full_method_name = ($self->name . '::' . $method_name);
101 no warnings 'redefine';
102 *{$full_method_name} = subname $full_method_name => $method;
107 ## private utility functions for has_method
108 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } };
109 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } };
112 my ($self, $method_name) = @_;
113 (defined $method_name && $method_name)
114 || confess "You must define a method name";
116 my $sub_name = ($self->name . '::' . $method_name);
119 return 0 if !defined(&{$sub_name});
120 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
121 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
128 my ($self, $method_name) = @_;
129 (defined $method_name && $method_name)
130 || confess "You must define a method name";
133 return \&{$self->name . '::' . $method_name}
134 if $self->has_method($method_name);
135 return; # <- make sure to return undef
139 my ($self, $method_name) = @_;
140 (defined $method_name && $method_name)
141 || confess "You must define a method name";
143 my $removed_method = $self->get_method($method_name);
146 delete ${$self->name . '::'}{$method_name}
147 if defined $removed_method;
149 return $removed_method;
152 sub get_method_list {
155 grep { $self->has_method($_) } %{$self->name . '::'};
158 sub compute_all_applicable_methods {
161 # keep a record of what we have seen
162 # here, this will handle all the
163 # inheritence issues because we are
164 # using the &class_precedence_list
165 my (%seen_class, %seen_method);
166 foreach my $class ($self->class_precedence_list()) {
167 next if $seen_class{$class};
168 $seen_class{$class}++;
169 # fetch the meta-class ...
170 my $meta = $self->initialize($class);
171 foreach my $method_name ($meta->get_method_list()) {
172 next if exists $seen_method{$method_name};
173 $seen_method{$method_name}++;
175 name => $method_name,
177 code => $meta->get_method($method_name)
184 ## Recursive Version of compute_all_applicable_methods
185 # sub compute_all_applicable_methods {
186 # my ($self, $seen) = @_;
190 # if (exists $seen->{$_}) {
197 # class => $self->name,
198 # code => $self->get_method($_)
201 # } $self->get_method_list()),
203 # $self->initialize($_)->compute_all_applicable_methods($seen)
204 # } $self->superclasses()
208 sub find_all_methods_by_name {
209 my ($self, $method_name) = @_;
210 (defined $method_name && $method_name)
211 || confess "You must define a method name to find";
213 # keep a record of what we have seen
214 # here, this will handle all the
215 # inheritence issues because we are
216 # using the &class_precedence_list
218 foreach my $class ($self->class_precedence_list()) {
219 next if $seen_class{$class};
220 $seen_class{$class}++;
221 # fetch the meta-class ...
222 my $meta = $self->initialize($class);
224 name => $method_name,
226 code => $meta->get_method($method_name)
227 } if $meta->has_method($method_name);
241 Class::MOP::Class - Class Meta Object
249 Stevan Little E<gt>stevan@iinteractive.comE<lt>
251 =head1 COPYRIGHT AND LICENSE
253 Copyright 2006 by Infinity Interactive, Inc.
255 L<http://www.iinteractive.com>
257 This library is free software; you can redistribute it and/or modify
258 it under the same terms as Perl itself.