optimized

[gitmo/Class-MOP.git] / lib / Class / MOP / Class.pm

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 2f4fbba..1dd30eb 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -9,7 +9,7 @@ use Scalar::Util 'blessed', 'reftype';
 use Sub::Name    'subname';
 use B            'svref_2object';
 
-our $VERSION = '0.11';
+our $VERSION = '0.12';
 
 # Self-introspection 
 
@@ -17,7 +17,7 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
 
 # Creation
 
-{
+#{
     # Metaclasses are singletons, so we cache them here.
     # there is no need to worry about destruction though
     # because they should die only when the program dies.
@@ -97,7 +97,7 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
                            $class_name . "->meta => (" . (blessed($meta)) . ")";
         }        
     }
-}
+#}
 
 sub create {
     my ($class, $package_name, $package_version, %options) = @_;
@@ -134,11 +134,18 @@ sub create {
     return $meta;
 }
 
-sub create_anon_class {
-    my ($class, %options) = @_;   
-    require Digest::MD5;
-    my $package_name = 'Class::MOP::Class::__ANON__::' . Digest::MD5::md5_hex({} . time() . $$ . rand());
-    return $class->create($package_name, '0.00', %options);
+{
+    # NOTE:
+    # this should be sufficient, if you have a 
+    # use case where it is not, write a test and 
+    # I will change it.
+    my $ANON_CLASS_SERIAL = 0;
+    
+    sub create_anon_class {
+        my ($class, %options) = @_;   
+        my $package_name = 'Class::MOP::Class::__ANON__::SERIAL::' . ++$ANON_CLASS_SERIAL;
+        return $class->create($package_name, '0.00', %options);
+    }
 }
 
 ## Attribute readers
@@ -170,16 +177,7 @@ sub construct_instance {
     my ($class, %params) = @_;
     my $instance = {};
     foreach my $attr ($class->compute_all_applicable_attributes()) {
-        my $init_arg = $attr->init_arg();
-        # try to fetch the init arg from the %params ...
-        my $val;        
-        $val = $params{$init_arg} if exists $params{$init_arg};
-        # if nothing was in the %params, we can use the 
-        # attribute's default value (if it has one)
-        if (!defined $val && $attr->has_default) {
-            $val = $attr->default($instance); 
-        }            
-        $instance->{$attr->name} = $val;
+        $attr->initialize_instance_slot($class, $instance, \%params);
     }
     return $instance;
 }
@@ -219,11 +217,12 @@ sub version {
 
 sub superclasses {
     my $self = shift;
+    no strict 'refs';
     if (@_) {
         my @supers = @_;
-        @{$self->get_package_variable('@ISA')} = @supers;
+        @{$self->name . '::ISA'} = @supers;
     }
-    @{$self->get_package_variable('@ISA')};        
+    @{$self->name . '::ISA'};
 }
 
 sub class_precedence_list {
@@ -238,7 +237,7 @@ sub class_precedence_list {
     (
         $self->name, 
         map { 
-            $self->initialize($_)->class_precedence_list()
+            ($METAS{$_} || $self->initialize($_))->class_precedence_list()
         } $self->superclasses()
     );   
 }
@@ -490,8 +489,12 @@ sub get_attribute {
     my ($self, $attribute_name) = @_;
     (defined $attribute_name && $attribute_name)
         || confess "You must define an attribute name";
-    return $self->get_attribute_map->{$attribute_name} 
-        if $self->has_attribute($attribute_name);   
+    # OPTIMIZATION NOTE:
+    # we used to say `if $self->has_attribute($attribute_name)` 
+    # here, but since get_attribute is called so often, we 
+    # eliminate the function call here
+    return $self->{'%:attributes'}->{$attribute_name} 
+        if exists $self->{'%:attributes'}->{$attribute_name};   
     return; 
 } 
 
@@ -509,7 +512,12 @@ sub remove_attribute {
 
 sub get_attribute_list {
     my $self = shift;
-    keys %{$self->get_attribute_map};
+    # OPTIMIZATION NOTE:
+    # We don't use get_attribute_map here because 
+    # we ask for the attribute list quite often 
+    # in compute_all_applicable_attributes, so 
+    # eliminating the function call helps 
+    keys %{$self->{'%:attributes'}};
 } 
 
 sub compute_all_applicable_attributes {
@@ -524,7 +532,7 @@ sub compute_all_applicable_attributes {
         next if $seen_class{$class};
         $seen_class{$class}++;
         # fetch the meta-class ...
-        my $meta = $self->initialize($class);
+        my $meta = ($METAS{$class} || $self->initialize($class));
         foreach my $attr_name ($meta->get_attribute_list()) { 
             next if exists $seen_attr{$attr_name};
             $seen_attr{$attr_name}++;
@@ -534,6 +542,24 @@ sub compute_all_applicable_attributes {
     return @attrs;    
 }
 
+sub find_attribute_by_name {
+    my ($self, $attr_name) = @_;
+    # keep a record of what we have seen
+    # here, this will handle all the 
+    # inheritence issues because we are 
+    # using the &class_precedence_list
+    my %seen_class;
+    foreach my $class ($self->class_precedence_list()) {
+        next if $seen_class{$class};
+        $seen_class{$class}++;
+        # fetch the meta-class ...
+        my $meta = $self->initialize($class);
+        return $meta->get_attribute($attr_name)
+            if $meta->has_attribute($attr_name);
+    }
+    return;
+}
+
 # Class attributes
 
 sub add_package_variable {
@@ -1112,6 +1138,12 @@ HASH reference like C<compute_all_applicable_methods> because all
 that same information is discoverable through the attribute 
 meta-object itself.
 
+=item B<find_attribute_by_name ($attr_name)>
+
+This method will traverse the inheritance heirachy and find the 
+first attribute whose name matches C<$attr_name>, then return it. 
+It will return undef if nothing is found.
+
 =back
 
 =head2 Package Variables