Class::MOP - refactoring the binary tree test code

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

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 107734d..988c735 100644 (file)
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -11,6 +11,10 @@ use B            'svref_2object';
 
 our $VERSION = '0.01';
 
+# Self-introspection
+
+sub meta { $_[0]->initialize($_[0]) }
+
 # Creation
 
 {
@@ -42,19 +46,43 @@ sub create {
     my $meta = $class->initialize($package_name);
     $meta->superclasses(@{$options{superclasses}})
         if exists $options{superclasses};
+    # NOTE:
+    # process attributes first, so that they can 
+    # install accessors, but locally defined methods
+    # can then overwrite them. It is maybe a little odd, but
+    # I think this should be the order of things.
+    if (exists $options{attributes}) {
+        foreach my $attr (@{$options{attributes}}) {
+            $meta->add_attribute($attr);
+        }
+    }        
     if (exists $options{methods}) {
         foreach my $method_name (keys %{$options{methods}}) {
             $meta->add_method($method_name, $options{methods}->{$method_name});
         }
-    }
+    }  
     return $meta;
 }
 
 # Instance Construction
 
 sub construct_instance {
-    my ($canidate, %params) = @_;
-    # ...
+    my ($class, %params) = @_;
+    my $instance = {};
+    foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
+        # if the attr has an init_arg, use that, otherwise,
+        # use the attributes name itself as the init_arg
+        my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
+        # 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)
+        $val ||= $attr->default($instance) if $attr->has_default();
+        # now add this to the instance structure
+        $instance->{$attr->name} = $val;
+    }
+    return $instance;
 }
 
 # Informational 
@@ -115,8 +143,8 @@ sub add_method {
 {
 
     ## private utility functions for has_method
-    my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } };
-    my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } };
+    my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' };
+    my $_find_subroutine_name         = sub { eval { svref_2object($_[0])->GV->NAME        } || '' };
 
     sub has_method {
         my ($self, $method_name) = @_;
@@ -219,12 +247,11 @@ sub find_all_methods_by_name {
 ## Attributes
 
 sub add_attribute {
-    my ($self, $attribute_name, $attribute) = @_;
-    (defined $attribute_name && $attribute_name)
-        || confess "You must define an attribute name";
+    my ($self,$attribute) = @_;
     (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
         || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
-    $self->{'%:attrs'}->{$attribute_name} = $attribute;
+    $attribute->install_accessors($self);        
+    $self->{'%:attrs'}->{$attribute->name} = $attribute;
 }
 
 sub has_attribute {
@@ -249,6 +276,7 @@ sub remove_attribute {
     my $removed_attribute = $self->{'%:attrs'}->{$attribute_name};    
     delete $self->{'%:attrs'}->{$attribute_name} 
         if defined $removed_attribute;
+    $removed_attribute->remove_accessors($self);        
     return $removed_attribute;
 } 
 
@@ -282,10 +310,7 @@ sub compute_all_applicable_attributes {
     }
     return @attrs;    
 }
- 
-sub create_all_accessors {
-    
-}
+
 
 1;
 
@@ -303,6 +328,16 @@ Class::MOP::Class - Class Meta Object
 
 =head1 METHODS
 
+=head2 Self Introspection
+
+=over 4
+
+=item B<meta>
+
+This allows Class::MOP::Class to actually introspect itself.
+
+=back
+
 =head2 Class construction
 
 These methods handle creating Class objects, which can be used to 
@@ -334,12 +369,12 @@ This initializes a Class object for a given a C<$package_name>.
 
 =over 4
 
-=item B<construct_instance ($canidate, %params)>
+=item B<construct_instance (%params)>
 
-This will construct and instance using the C<$canidate> as storage 
+This will construct and instance using a HASH ref as storage 
 (currently only HASH references are supported). This will collect all 
 the applicable attribute meta-objects and layout out the fields in the 
-C<$canidate>, it will then initialize them using either use the 
+HASH ref, it will then initialize them using either use the 
 corresponding key in C<%params> or any default value or initializer 
 found in the attribute meta-object.
 
@@ -507,13 +542,7 @@ This will traverse the inheritance heirachy and return a list of HASH
 references for all the applicable attributes for this class. The HASH 
 references will contain the following information; the attribute name, 
 the class which the attribute is associated with and the actual 
-attribute meta-object
-
-=item B<create_all_accessors>
-
-This will communicate with all of the classes attributes to create
-and install the appropriate accessors. (see L<The Attribute Protocol> 
-below for more details).
+attribute meta-object.
 
 =back