instance-protocol

diff --git a/Changes b/Changes
index b5d2e4d..27c5472 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,14 @@
 Revision history for Perl extension Class-MOP.
 
+0.30
+    * Class::MOP::Instance
+      - added new instance construction protocol
+        - added tests for this
+      - changed all relevant modules and examples
+        - Class::MOP::Class
+        - Class::MOP::Attribute
+        - examples/*
+
 0.26 Mon. April 24, 2006
     * Class::MOP::Class
       - added find_attribute_by_name method

diff --git a/README b/README
index 338ce3b..2443f43 100644 (file)
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Class::MOP version 0.26
+Class::MOP version 0.30
 ===========================
 
 See the individual module documentation for more information

diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod
index e14a17a..8e84dbd 100644 (file)
--- a/examples/ClassEncapsulatedAttributes.pod
+++ b/examples/ClassEncapsulatedAttributes.pod
@@ -5,7 +5,7 @@ package # hide the package from PAUSE
 use strict;
 use warnings;
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 use base 'Class::MOP::Class';
 
@@ -37,7 +37,7 @@ package # hide the package from PAUSE
 use strict;
 use warnings;
 
-our $VERSION = '0.03';
+our $VERSION = '0.04';
 
 use base 'Class::MOP::Attribute';
 
@@ -57,7 +57,10 @@ sub initialize_instance_slot {
         $val = $self->default($meta_instance->get_instance); 
     }
     # now add this to the instance structure
-    $meta_instance->get_slot_value($class->name)->{$self->name} = $val;   
+    $meta_instance->get_slot_value(
+        $meta_instance->get_instance, 
+        $class->name
+    )->{$self->name} = $val;   
 }
 
 sub generate_accessor_method {

diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod
index 779cc77..ec1d21b 100644 (file)
--- a/examples/InsideOutClass.pod
+++ b/examples/InsideOutClass.pod
@@ -6,7 +6,7 @@ package # hide the package from PAUSE
 use strict;
 use warnings;
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 use Carp         'confess';
 use Scalar::Util 'refaddr';

diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod
index 1847939..3ce659b 100644 (file)
--- a/examples/LazyClass.pod
+++ b/examples/LazyClass.pod
@@ -7,7 +7,7 @@ use warnings;
 
 use Carp 'confess';
 
-our $VERSION = '0.03';
+our $VERSION = '0.04';
 
 use base 'Class::MOP::Attribute';
 

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index a08426f..20e02b6 100644 (file)
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -11,7 +11,7 @@ use Class::MOP::Class;
 use Class::MOP::Attribute;
 use Class::MOP::Method;
 
-our $VERSION = '0.26';
+our $VERSION = '0.30';
 
 ## ----------------------------------------------------------------------------
 ## Setting up our environment ...
@@ -70,6 +70,14 @@ Class::MOP::Class->meta->add_attribute(
     ))
 );
 
+Class::MOP::Class->meta->add_attribute(
+    Class::MOP::Attribute->new('$:instance_metaclass' => (
+        reader   => 'instance_metaclass',
+        init_arg => ':instance_metaclass',
+        default  => 'Class::MOP::Instance',        
+    ))
+);
+
 ## Class::MOP::Attribute
 
 Class::MOP::Attribute->meta->add_attribute(

diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index f8cfe64..0677448 100644 (file)
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -7,7 +7,7 @@ use warnings;
 use Carp         'confess';
 use Scalar::Util 'blessed', 'reftype', 'weaken';
 
-our $VERSION = '0.07';
+our $VERSION = '0.08';
 
 sub meta { 
     require Class::MOP::Class;
@@ -128,28 +128,36 @@ sub detach_from_class {
 
 sub generate_accessor_method {
     my ($self, $attr_name) = @_;
+    my $meta_instance = $self->associated_class->instance_metaclass;
     sub {
-        $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
-        $_[0]->{$attr_name};
+        $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
+        $meta_instance->get_slot_value($_[0], $attr_name);
     };
 }
 
 sub generate_reader_method {
     my ($self, $attr_name) = @_; 
+    my $meta_instance = $self->associated_class->instance_metaclass;
     sub { 
         confess "Cannot assign a value to a read-only accessor" if @_ > 1;
-        $_[0]->{$attr_name}; 
+        $meta_instance->get_slot_value($_[0], $attr_name); 
     };   
 }
 
 sub generate_writer_method {
     my ($self, $attr_name) = @_; 
-    sub { $_[0]->{$attr_name} = $_[1] };
+    my $meta_instance = $self->associated_class->instance_metaclass;    
+    sub { 
+        $meta_instance->set_slot_value($_[0], $attr_name, $_[1]);
+    };
 }
 
 sub generate_predicate_method {
     my ($self, $attr_name) = @_; 
-    sub { defined $_[0]->{$attr_name} ? 1 : 0 };
+    my $meta_instance = $self->associated_class->instance_metaclass;    
+    sub { 
+        $meta_instance->has_slot_value($_[0], $attr_name);
+    };
 }
 
 sub process_accessors {

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index b32e02a..5ba6570 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.13';
+our $VERSION = '0.14';
 
 use Class::MOP::Instance;
 
@@ -67,7 +67,8 @@ sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
                 '$:package'             => $package_name, 
                 '%:attributes'          => {},
                 '$:attribute_metaclass' => $options{':attribute_metaclass'} || 'Class::MOP::Attribute',
-                '$:method_metaclass'    => $options{':method_metaclass'}    || 'Class::MOP::Method',                
+                '$:method_metaclass'    => $options{':method_metaclass'}    || 'Class::MOP::Method',
+                '$:instance_metaclass'  => $options{':instance_metaclass'}  || 'Class::MOP::Instance',    
             } => $class;
         }
         else {
@@ -160,6 +161,7 @@ sub name                { $_[0]->{'$:package'}             }
 sub get_attribute_map   { $_[0]->{'%:attributes'}          }
 sub attribute_metaclass { $_[0]->{'$:attribute_metaclass'} }
 sub method_metaclass    { $_[0]->{'$:method_metaclass'}    }
+sub instance_metaclass  { $_[0]->{'$:instance_metaclass'}  }
 
 # Instance Construction & Cloning
 
@@ -177,7 +179,7 @@ sub new_object {
 
 sub construct_instance {
     my ($class, %params) = @_;
-    my $meta_instance = Class::MOP::Instance->new($class);
+    my $meta_instance = $class->instance_metaclass->new($class);
     foreach my $attr ($class->compute_all_applicable_attributes()) {
         $attr->initialize_instance_slot($class, $meta_instance, \%params);
     }
@@ -777,6 +779,8 @@ to use them or not.
 
 =over 4
 
+=item B<instance_metaclass>
+
 =item B<new_object (%params)>
 
 This is a convience method for creating a new object of the class, and 

diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm
index 1bd598c..9d47700 100644 (file)
--- a/lib/Class/MOP/Instance.pm
+++ b/lib/Class/MOP/Instance.pm
@@ -33,11 +33,19 @@ sub has_slot {
 }
 
 sub get_slot_value {
-    my ($self, $slot_name) = @_;
-    return $self->{instance}->{$slot_name};
+    my ($self, $instance, $slot_name) = @_;
+    return $instance->{$slot_name};
 }
 
-*set_slot_value = \&add_slot;
+sub set_slot_value {
+    my ($self, $instance, $slot_name, $value) = @_;
+    $instance->{$slot_name} = $value;
+}
+
+sub has_slot_value {
+    my ($self, $instance, $slot_name) = @_;
+    defined $instance->{$slot_name} ? 1 : 0;
+}
 
 sub get_instance { (shift)->{instance} }
 
@@ -69,6 +77,8 @@ Class::MOP::Instance - Instance Meta Object
 
 =item B<set_slot_value>
 
+=item B<has_slot_value>
+
 =item B<get_instance>
 
 =back

diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index a59ef86..febc677 100644 (file)
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 136;
+use Test::More tests => 140;
 use Test::Exception;
 
 BEGIN {
@@ -26,6 +26,7 @@ my @methods = qw(
     
     initialize create create_anon_class
     
+    instance_metaclass
     new_object clone_object
     construct_instance construct_class_instance clone_instance
     check_metaclass_compatability
@@ -73,7 +74,13 @@ foreach my $non_method_name (qw(
 
 # check for the right attributes
 
-my @attributes = ('$:package', '%:attributes', '$:attribute_metaclass', '$:method_metaclass');
+my @attributes = (
+    '$:package', 
+    '%:attributes', 
+    '$:attribute_metaclass', 
+    '$:method_metaclass', 
+    '$:instance_metaclass'
+);
 
 is_deeply(
     [ sort @attributes ],

diff --git a/t/060_instance.t b/t/060_instance.t
new file mode 100644 (file)
index 0000000..5dbbde1
--- /dev/null
+++ b/t/060_instance.t
@@ -0,0 +1,14 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 1;
+use Test::Exception;
+
+use Scalar::Util 'reftype', 'isweak';
+
+BEGIN {
+    use_ok('Class::MOP::Instance');    
+}
+