X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FMeta%2FClass.pm;h=d1bffe32e6c83a12c04e537782f6da86c1d114cf;hp=81fb0b0812ae793a31b9414813cfdf640f2d4126;hb=3a63a2e7ef8fbac5f61eab04baecbf5d19374b83;hpb=0d6273f0da76fefde1c6d84676f4af4c6161b02e

diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 81fb0b0..d1bffe3 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -5,9 +5,11 @@ use warnings;
 use Mouse::Meta::Method::Constructor;
 use Mouse::Meta::Method::Destructor;
 use Scalar::Util qw/blessed weaken/;
-use Mouse::Util qw/get_linear_isa version authority identifier/;
+use Mouse::Util qw/get_linear_isa version authority identifier get_code_info/;
 use Carp 'confess';
 
+use base qw(Mouse::Meta::Module);
+
 do {
     my %METACLASS_CACHE;
 
@@ -20,12 +22,19 @@ do {
     }
 
     sub initialize {
-        my $class = blessed($_[0]) || $_[0];
-        my $name  = $_[1];
+        my($class, $package_name, @args) = @_;
 
-        $METACLASS_CACHE{$name} = $class->new(name => $name)
-            if !exists($METACLASS_CACHE{$name});
-        return $METACLASS_CACHE{$name};
+        ($package_name && !ref($package_name))
+            || confess("You must pass a package name and it cannot be blessed");
+
+        return $METACLASS_CACHE{$package_name}
+            ||= $class->_construct_class_instance(package => $package_name, @args);
+    }
+
+    sub class_of{
+        my($class_or_instance) = @_;
+        return undef unless defined $class_or_instance;
+        return $METACLASS_CACHE{ blessed($class_or_instance) || $class_or_instance };
     }
 
     # Means of accessing all the metaclasses that have
@@ -40,21 +49,28 @@ do {
     sub remove_metaclass_by_name    { $METACLASS_CACHE{$_[0]} = undef }
 };
 
-sub new {
-    my $class = shift;
-    my %args  = @_;
+sub _construct_class_instance {
+    my($class, %args) = @_;
 
-    $args{attributes} = {};
+    $args{attributes}   = {};
     $args{superclasses} = do {
         no strict 'refs';
-        \@{ $args{name} . '::ISA' };
+        \@{ $args{package} . '::ISA' };
     };
-    $args{roles} ||= [];
+    $args{roles}   ||= [];
+    $args{methods} ||= {};
 
     bless \%args, $class;
 }
 
-sub name { $_[0]->{name} }
+sub name { $_[0]->{package} }
+sub _method_map{ $_[0]->{methods} }
+
+sub namespace{
+    my $name = $_[0]->{package};
+    no strict 'refs';
+    return \%{ $name . '::' };
+}
 
 sub superclasses {
     my $self = shift;
@@ -67,50 +83,11 @@ sub superclasses {
     @{ $self->{superclasses} };
 }
 
-sub add_method {
-    my $self = shift;
-    my $name = shift;
-    my $code = shift;
-
-    my $pkg = $self->name;
-
-    no strict 'refs';
-    no warnings 'redefine';
-    $self->{'methods'}->{$name}++; # Moose stores meta object here.
-    *{ $pkg . '::' . $name } = $code;
-}
-
-sub has_method {
-    my $self = shift;
-    my $name = shift;
-    $self->name->can($name);
-}
-
-# copied from Class::Inspector
-my $get_methods_for_class = sub {
-    my $self = shift;
-    my $name = shift;
-
-    no strict 'refs';
-    # Get all the CODE symbol table entries
-    my @functions =
-      grep !/^(?:has|with|around|before|after|augment|inner|blessed|extends|confess|override|super)$/,
-      grep { defined &{"${name}::$_"} }
-      keys %{"${name}::"};
-    push @functions, keys %{$self->{'methods'}->{$name}} if $self;
-    wantarray ? @functions : \@functions;
-};
-
-sub get_method_list {
-    my $self = shift;
-    $get_methods_for_class->($self, $self->name);
-}
-
 sub get_all_method_names {
     my $self = shift;
     my %uniq;
     return grep { $uniq{$_}++ == 0 }
-            map { $get_methods_for_class->(undef, $_) }
+            map { Mouse::Meta::Class->initialize($_)->get_method_list() }
             $self->linearized_isa;
 }
 
@@ -209,6 +186,7 @@ sub make_immutable {
     my $self = shift;
     my %args = (
         inline_constructor => 1,
+        inline_destructor  => 1,
         @_,
     );
 
@@ -308,9 +286,11 @@ sub does_role {
         || confess "You must supply a role name to look for";
 
     for my $class ($self->linearized_isa) {
-        next unless $class->can('meta') and $class->meta->can('roles');
-        for my $role (@{ $class->meta->roles }) {
-            return 1 if $role->name eq $role_name;
+        my $meta = class_of($class);
+        next unless $meta && $meta->can('roles');
+
+        for my $role (@{ $meta->roles }) {
+            return 1 if $role->does_role($role_name);
         }
     }
 
@@ -318,7 +298,7 @@ sub does_role {
 }
 
 sub create {
-    my ($self, $package_name, %options) = @_;
+    my ($class, $package_name, %options) = @_;
 
     (ref $options{superclasses} eq 'ARRAY')
         || confess "You must pass an ARRAY ref of superclasses"
@@ -355,11 +335,11 @@ sub create {
         version
         authority
     )};
-    my $meta = $self->initialize( $package_name => %initialize_options );
+    my $meta = $class->initialize( $package_name => %initialize_options );
 
     # FIXME totally lame
     $meta->add_method('meta' => sub {
-        $self->initialize(ref($_[0]) || $_[0]);
+        Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
     });
 
     $meta->superclasses(@{$options{superclasses}})