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 (reftype($method) && reftype($method) eq 'CODE')
96 || confess "Your code block must be a CODE reference";
97 my $full_method_name = ($self->name . '::' . $method_name);
100 *{$full_method_name} = subname $full_method_name => $method;
105 ## private utility functions for has_method
106 my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } };
107 my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } };
110 my ($self, $method_name, $method) = @_;
111 (defined $method_name && $method_name)
112 || confess "You must define a method name";
114 my $sub_name = ($self->name . '::' . $method_name);
117 return 0 if !defined(&{$sub_name});
118 return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name &&
119 $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__';
126 my ($self, $method_name, $method) = @_;
127 (defined $method_name && $method_name)
128 || confess "You must define a method name";
131 return \&{$self->name . '::' . $method_name}
132 if $self->has_method($method_name);
133 return; # <--- make sure to return undef
144 Class::MOP::Class - Class Meta Object
152 Stevan Little E<gt>stevan@iinteractive.comE<lt>
154 =head1 COPYRIGHT AND LICENSE
156 Copyright 2006 by Infinity Interactive, Inc.
158 L<http://www.iinteractive.com>
160 This library is free software; you can redistribute it and/or modify
161 it under the same terms as Perl itself.