From: Stevan Little <stevan.little@iinteractive.com>
Date: Tue, 31 Jan 2006 16:50:21 +0000 (+0000)
Subject: Class::MOP - lots of knot tying, this should make subclassing more reliable and strai... 
X-Git-Tag: 0_02~12
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=727919c540c7d73b1abc551d528c827f1b71fc0d;p=gitmo%2FClass-MOP.git

Class::MOP - lots of knot tying, this should make subclassing more reliable and straightforward
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 2e04e05..5221858 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -5,6 +5,7 @@ use strict;
 use warnings;
 
 use Scalar::Util 'blessed';
+use Carp         'confess';
 
 use Class::MOP::Class;
 use Class::MOP::Attribute;
@@ -22,6 +23,68 @@ sub import {
     }
 }
 
+## Bootstrapping
+
+# We need to add in the meta-attributes here so that 
+# any subclass of Class::MOP::* will be able to 
+# inherit them using &construct_instance
+
+## Class::MOP::Class
+
+Class::MOP::Class->meta->add_attribute(
+    Class::MOP::Attribute->new('$:pkg' => (
+        init_arg => ':pkg'
+    ))
+);
+
+Class::MOP::Class->meta->add_attribute(
+    Class::MOP::Attribute->new('%:attrs' => (
+        init_arg => ':attrs',
+        default  => sub { {} }
+    ))
+);
+
+## Class::MOP::Attribute
+
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('name'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('accessor'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('reader'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('writer'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('predicate'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('init_arg'));
+Class::MOP::Attribute->meta->add_attribute(Class::MOP::Attribute->new('default'));
+
+# NOTE: (meta-circularity)
+# This should be one of the last things done
+# it will "tie the knot" with Class::MOP::Attribute
+# so that it uses the attributes meta-objects 
+# to construct itself. 
+Class::MOP::Attribute->meta->add_method('new' => sub {
+    my $class   = shift;
+    my $name    = shift;
+    my %options = @_;    
+        
+    (defined $name && $name)
+        || confess "You must provide a name for the attribute";
+    (!exists $options{reader} && !exists $options{writer})
+        || confess "You cannot declare an accessor and reader and/or writer functions"
+            if exists $options{accessor};
+            
+    bless $class->meta->construct_instance(name => $name, %options) => $class;
+});
+
+# NOTE: (meta-circularity)
+# This is how we "tie the knot" for the class
+# meta-objects. This is used to construct the
+# Class::MOP::Class instances after all the 
+# bootstrapping is complete.
+Class::MOP::Class->meta->add_method('construct_class_instance' => sub {
+    my ($class, $package_name) = @_;
+    (defined $package_name && $package_name)
+        || confess "You must pass a package name";      
+    bless Class::MOP::Class->meta->construct_instance(':pkg' => $package_name) => blessed($class) || $class        
+});
+
 1;
 
 __END__
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index c4bdd5b..52898ba 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -7,13 +7,22 @@ use warnings;
 use Carp         'confess';
 use Scalar::Util 'blessed', 'reftype';
 
-use Class::MOP::Class;
-use Class::MOP::Method;
-
 our $VERSION = '0.01';
 
-sub meta { Class::MOP::Class->initialize($_[0]) }
+sub meta { 
+    require Class::MOP::Class;
+    Class::MOP::Class->initialize($_[0]) 
+}
 
+# NOTE: (meta-circularity)
+# This method will be replaces in the 
+# boostrap section of Class::MOP, by 
+# a new version which uses the 
+# &Class::MOP::Class::construct_instance
+# method to build an attribute meta-object
+# which itself is described with attribute
+# meta-objects. 
+#     - Ain't meta-circularity grand? :)
 sub new {
     my $class   = shift;
     my $name    = shift;
@@ -38,12 +47,12 @@ sub new {
 
 sub name { $_[0]->{name} }
 
-sub has_accessor  { defined($_[0]->{accessor}) ? 1 : 0  }
-sub has_reader    { defined($_[0]->{reader}) ? 1 : 0    }
-sub has_writer    { defined($_[0]->{writer}) ? 1 : 0    }
+sub has_accessor  { defined($_[0]->{accessor})  ? 1 : 0 }
+sub has_reader    { defined($_[0]->{reader})    ? 1 : 0 }
+sub has_writer    { defined($_[0]->{writer})    ? 1 : 0 }
 sub has_predicate { defined($_[0]->{predicate}) ? 1 : 0 }
-sub has_init_arg  { defined($_[0]->{init_arg}) ? 1 : 0  }
-sub has_default   { defined($_[0]->{default}) ? 1 : 0   }
+sub has_init_arg  { defined($_[0]->{init_arg})  ? 1 : 0 }
+sub has_default   { defined($_[0]->{default})   ? 1 : 0 }
 
 sub accessor  { $_[0]->{accessor}  } 
 sub reader    { $_[0]->{reader}    }
@@ -54,69 +63,69 @@ sub init_arg  { $_[0]->{init_arg}  }
 sub default { 
     my $self = shift;
     if (reftype($self->{default}) && reftype($self->{default}) eq 'CODE') {
+        # if the default is a CODE ref, then 
+        # we pass in the instance and default
+        # can return a value based on that 
+        # instance. Somewhat crude, but works.
         return $self->{default}->(shift);
     }           
     $self->{default};
 }
 
-sub install_accessors {
-    my ($self, $class) = @_;
-    (blessed($class) && $class->isa('Class::MOP::Class'))
-        || confess "You must pass a Class::MOP::Class instance (or a subclass)";    
-        
-    if ($self->has_accessor()) {
-        my $accessor = $self->accessor();
+{
+    # this is just a utility routine to 
+    # handle the details of accessors
+    my $_inspect_accessor = sub {
+        my ($attr_name, $type, $accessor) = @_;
+    
+        my %ACCESSOR_TEMPLATES = (
+            'accessor' => sub {
+                $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
+                $_[0]->{$attr_name};
+            },
+            'reader' => sub { 
+                $_[0]->{$attr_name};
+            },
+            'writer' => sub {
+                $_[0]->{$attr_name} = $_[1];
+                return;
+            },
+            'predicate' => sub {
+                return defined $_[0]->{$attr_name} ? 1 : 0;
+            }            
+        );    
+    
         if (reftype($accessor) && reftype($accessor) eq 'HASH') {
             my ($name, $method) = each %{$accessor};
-            $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
+            return ($name, Class::MOP::Attribute::Accessor->wrap($method));        
         }
         else {
-            $class->add_method($accessor => Class::MOP::Attribute::Accessor->wrap(sub {
-                $_[0]->{$self->name} = $_[1] if scalar(@_) == 2;
-                $_[0]->{$self->name};
-            }));
-        }
-    }
-    else {
-        if ($self->has_reader()) {      
-            my $reader = $self->reader();
-            if (reftype($reader) && reftype($reader) eq 'HASH') {
-                my ($name, $method) = each %{$reader};
-                $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
-            }
-            else {             
-                $class->add_method($reader => Class::MOP::Attribute::Accessor->wrap(sub { 
-                    $_[0]->{$self->name};
-                }));        
-            }
-        }
-        if ($self->has_writer()) {
-            my $writer = $self->writer();
-            if (reftype($writer) && reftype($writer) eq 'HASH') {
-                my ($name, $method) = each %{$writer};
-                $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
-            }
-            else {            
-                $class->add_method($writer => Class::MOP::Attribute::Accessor->wrap(sub {
-                    $_[0]->{$self->name} = $_[1];
-                    return;
-                }));            
-            }
-        }
+            return ($accessor => Class::MOP::Attribute::Accessor->wrap($ACCESSOR_TEMPLATES{$type}));
+        }    
+    };
+
+    sub install_accessors {
+        my ($self, $class) = @_;
+        (blessed($class) && $class->isa('Class::MOP::Class'))
+            || confess "You must pass a Class::MOP::Class instance (or a subclass)";    
+        
+        $class->add_method(
+            $_inspect_accessor->($self->name, 'accessor' => $self->accessor())
+        ) if $self->has_accessor();
+
+        $class->add_method(            
+            $_inspect_accessor->($self->name, 'reader' => $self->reader())
+        ) if $self->has_reader();
+    
+        $class->add_method(
+            $_inspect_accessor->($self->name, 'writer' => $self->writer())
+        ) if $self->has_writer();
+    
+        $class->add_method(
+            $_inspect_accessor->($self->name, 'predicate' => $self->predicate())
+        ) if $self->has_predicate();
     }
     
-    if ($self->has_predicate()) {
-        my $predicate = $self->predicate();
-        if (reftype($predicate) && reftype($predicate) eq 'HASH') {
-            my ($name, $method) = each %{$predicate};
-            $class->add_method($name, Class::MOP::Attribute::Accessor->wrap($method));        
-        }
-        else {
-            $class->add_method($predicate => Class::MOP::Attribute::Accessor->wrap(sub {
-                defined $_[0]->{$self->name} ? 1 : 0;
-            }));
-        }
-    }    
 }
 
 sub remove_accessors {
@@ -170,6 +179,8 @@ package Class::MOP::Attribute::Accessor;
 use strict;
 use warnings;
 
+use Class::MOP::Method;
+
 our $VERSION = '0.01';
 
 our @ISA = ('Class::MOP::Method');
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 988c735..15a9ae6 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -26,11 +26,25 @@ sub meta { $_[0]->initialize($_[0]) }
     sub initialize {
         my ($class, $package_name) = @_;
         (defined $package_name && $package_name)
-            || confess "You must pass a package name";
-        $METAS{$package_name} ||= bless { 
+            || confess "You must pass a package name";        
+        return $METAS{$package_name} if exists $METAS{$package_name};
+        $METAS{$package_name} = $class->construct_class_instance($package_name);
+    }
+    
+    # NOTE: (meta-circularity) 
+    # this is a special form of &construct_instance 
+    # (see below), which is used to construct class
+    # meta-object instances. It will be replaces in 
+    # the bootstrap section in Class::MOP with one 
+    # which uses the normal &construct_instance.
+    sub construct_class_instance {
+        my ($class, $package_name) = @_;
+        (defined $package_name && $package_name)
+            || confess "You must pass a package name";        
+        bless { 
             '$:pkg'   => $package_name, 
             '%:attrs' => {} 
-        } => blessed($class) || $class;
+        } => blessed($class) || $class        
     }
 }
 
@@ -311,7 +325,6 @@ sub compute_all_applicable_attributes {
     return @attrs;    
 }
 
-
 1;
 
 __END__
@@ -378,6 +391,14 @@ 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.
 
+=item B<construct_class_instance ($package_name)>
+
+This will construct an instance of B<Class::MOP::Class>, it is 
+here so that we can actually "tie the knot" for B<Class::MOP::Class> 
+to use C<construct_instance> once all the bootstrapping is done. This 
+method is used internally by C<initialize> and should never be called
+from outside of that method really.
+
 =back
 
 =head2 Informational 
diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm
index 874159a..f049563 100644
--- a/lib/Class/MOP/Method.pm
+++ b/lib/Class/MOP/Method.pm
@@ -7,11 +7,12 @@ use warnings;
 use Carp         'confess';
 use Scalar::Util 'reftype';
 
-use Class::MOP::Class;
-
 our $VERSION = '0.01';
 
-sub meta { Class::MOP::Class->initialize($_[0]) }
+sub meta { 
+    require Class::MOP::Class;
+    Class::MOP::Class->initialize($_[0]) 
+}
 
 sub wrap { 
     my $class = shift;
diff --git a/t/005_attributes.t b/t/005_attributes.t
index 1b16ea0..80d38f7 100644
--- a/t/005_attributes.t
+++ b/t/005_attributes.t
@@ -22,7 +22,7 @@ my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => (
 {
     package Foo;
 
-    my $meta = __PACKAGE__->meta;
+    my $meta = Foo->meta;
     ::lives_ok {
         $meta->add_attribute($FOO_ATTR);
     } '... we added an attribute to Foo successfully';
@@ -35,7 +35,7 @@ my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => (
     package Bar;
     our @ISA = ('Foo');
     
-    my $meta = __PACKAGE__->meta;
+    my $meta = Bar->meta;
     ::lives_ok {
         $meta->add_attribute($BAR_ATTR);
     } '... we added an attribute to Bar successfully';
@@ -49,7 +49,7 @@ my $BAZ_ATTR = Class::MOP::Attribute->new('$baz' => (
     package Baz;
     our @ISA = ('Bar');
     
-    my $meta = __PACKAGE__->meta;
+    my $meta = Baz->meta;
     ::lives_ok {
         $meta->add_attribute($BAZ_ATTR);
     } '... we added an attribute to Baz successfully';
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 314afe3..ebb51cd 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -7,6 +7,7 @@ use Test::More no_plan => 1;
 use Test::Exception;
 
 BEGIN {
+    use_ok('Class::MOP');
     use_ok('Class::MOP::Class');        
 }
 
@@ -46,6 +47,13 @@ foreach my $non_method_name (qw(
     ok(!$meta->has_method($non_method_name), '... NOT Class::MOP::Class->has_method(' . $non_method_name . ')');        
 }
 
+foreach my $attribute_name (
+    '$:pkg', '%:attrs'
+    ) {
+    ok($meta->has_attribute($attribute_name), '... Class::MOP::Class->has_attribute(' . $attribute_name . ')');        
+    isa_ok($meta->get_attribute($attribute_name), 'Class::MOP::Attribute');            
+}
+
 is($meta->name, 'Class::MOP::Class', '... Class::MOP::Class->name');
 is($meta->version, $Class::MOP::Class::VERSION, '... Class::MOP::Class->version');
 
diff --git a/t/020_attribute.t b/t/020_attribute.t
index 3e8daf7..3051fb6 100644
--- a/t/020_attribute.t
+++ b/t/020_attribute.t
@@ -7,6 +7,7 @@ use Test::More no_plan => 1;
 use Test::Exception;
 
 BEGIN {
+    use_ok('Class::MOP');
     use_ok('Class::MOP::Attribute');
 }
 
diff --git a/t/030_method.t b/t/030_method.t
index b0d4923..82b19bb 100644
--- a/t/030_method.t
+++ b/t/030_method.t
@@ -7,6 +7,7 @@ use Test::More no_plan => 1;
 use Test::Exception;
 
 BEGIN {
+    use_ok('Class::MOP');    
     use_ok('Class::MOP::Method');
 }
 
diff --git a/t/100_BinaryTree_test.t b/t/100_BinaryTree_test.t
index a7684eb..08e2945 100644
--- a/t/100_BinaryTree_test.t
+++ b/t/100_BinaryTree_test.t
@@ -3,9 +3,10 @@
 use strict;
 use warnings;
 
-use Test::More tests => 67;
+use Test::More tests => 68;
 
 BEGIN { 
+    use_ok('Class::MOP');    
     use_ok('t::lib::BinaryTree');
 }
 
diff --git a/t/lib/BinaryTree.pm b/t/lib/BinaryTree.pm
index 37d9742..04c0e3f 100644
--- a/t/lib/BinaryTree.pm
+++ b/t/lib/BinaryTree.pm
@@ -9,7 +9,7 @@ use warnings;
 our $VERSION = '0.01';
 
 __PACKAGE__->meta->add_attribute(
-    Class::MOP::Attribute->new('_uid' => (
+    Class::MOP::Attribute->new('$:uid' => (
         reader  => 'getUID',
         writer  => 'setUID',
         default => sub { 
@@ -20,7 +20,7 @@ __PACKAGE__->meta->add_attribute(
 );
 
 __PACKAGE__->meta->add_attribute(
-    Class::MOP::Attribute->new('_node' => (
+    Class::MOP::Attribute->new('$:node' => (
         reader   => 'getNodeValue',
         writer   => 'setNodeValue',
         init_arg => ':node'
@@ -28,7 +28,7 @@ __PACKAGE__->meta->add_attribute(
 );
 
 __PACKAGE__->meta->add_attribute(      
-    Class::MOP::Attribute->new('_parent' => (
+    Class::MOP::Attribute->new('$:parent' => (
         predicate => 'hasParent',
         reader    => 'getParent',
         writer    => 'setParent'
@@ -36,14 +36,14 @@ __PACKAGE__->meta->add_attribute(
 );
 
 __PACKAGE__->meta->add_attribute(
-    Class::MOP::Attribute->new('_left' => (
+    Class::MOP::Attribute->new('$:left' => (
         predicate => 'hasLeft',         
         reader    => 'getLeft',
         writer => { 
             'setLeft' => sub {
                 my ($self, $tree) = @_;
             	$tree->setParent($self) if defined $tree;
-                $self->{_left} = $tree;    
+                $self->{'$:left'} = $tree;    
                 $self;                    
             }
        },
@@ -51,14 +51,14 @@ __PACKAGE__->meta->add_attribute(
 );
 
 __PACKAGE__->meta->add_attribute(  
-    Class::MOP::Attribute->new('_right' => (
+    Class::MOP::Attribute->new('$:right' => (
         predicate => 'hasRight',           
         reader    => 'getRight',
         writer => {
             'setRight' => sub {
                 my ($self, $tree) = @_;   
             	$tree->setParent($self) if defined $tree;
-                $self->{_right} = $tree;      
+                $self->{'$:right'} = $tree;      
                 $self;                    
             }
         }