From: Stevan Little <stevan.little@iinteractive.com>
Date: Sat, 29 Apr 2006 03:00:35 +0000 (+0000)
Subject: arrays
X-Git-Tag: 0_29_02~32
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0e76a376a5c60908efc13fe22f438b4b282ef313;p=gitmo%2FClass-MOP.git

arrays
---

diff --git a/examples/ArrayBasedInstance.pod b/examples/ArrayBasedInstance.pod
new file mode 100644
index 0000000..19a4815
--- /dev/null
+++ b/examples/ArrayBasedInstance.pod
@@ -0,0 +1,135 @@
+
+package # hide the package from PAUSE
+    ArrayBasedInstance::Attribute;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Attribute';    
+
+sub generate_accessor_method {
+    my $self = shift;
+    my $attr_name = $self->name;
+    return sub {
+        my $meta_instance = $self->associated_class->get_meta_instance;            
+        $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 = shift;
+    my $attr_name = $self->name;
+    return sub { 
+        confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+        my $meta_instance = $self->associated_class->get_meta_instance;        
+        $meta_instance->get_slot_value($_[0], $attr_name); 
+    };   
+}
+
+sub generate_writer_method {
+    my $self = shift;
+    my $attr_name = $self->name;
+    return sub { 
+        my $meta_instance = $self->associated_class->get_meta_instance;        
+        $meta_instance->set_slot_value($_[0], $attr_name, $_[1]);
+    };
+}
+
+sub generate_predicate_method {
+    my $self = shift;
+    my $attr_name = $self->name;
+    return sub { 
+        my $meta_instance = $self->associated_class->get_meta_instance;        
+        defined $meta_instance->get_slot_value($_[0], $attr_name) ? 1 : 0;
+    };
+}    
+
+package # hide the package from PAUSE
+    ArrayBasedInstance::Instance;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Instance';
+
+sub new {
+    my ($class, $meta, @attrs) = @_;
+    my $self = $class->SUPER::new($meta, @attrs);
+    my $index = 0;
+    $self->{slot_index_map} = { map { $_ => $index++ } $self->get_all_slots };
+    return $self;
+}
+
+sub create_instance {
+    my $self = shift;
+    $self->bless_instance_structure([]);
+}
+
+# operations on meta instance
+
+sub get_all_slots {
+    my $self = shift;
+    return sort @{$self->{slots}};
+}
+
+sub get_slot_value {
+    my ($self, $instance, $slot_name) = @_;
+    return $instance->[ $self->{slot_index_map}->{$slot_name} ];
+}
+
+sub set_slot_value {
+    my ($self, $instance, $slot_name, $value) = @_;
+    $instance->[ $self->{slot_index_map}->{$slot_name} ] = $value;
+}
+
+sub initialize_slot {
+    my ($self, $instance, $slot_name) = @_;
+    $instance->[ $self->{slot_index_map}->{$slot_name} ] = undef;
+}
+
+sub is_slot_initialized {
+    # NOTE:
+    # maybe use CLOS's *special-unbound-value*
+    # for this ?
+    confess "Cannot really tell this for sure";
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ArrayBasedInstance - An example of an Array based instance 
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 SEE ALSO
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
+=cut
diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod
index 036da24..62c1004 100644
--- a/examples/InsideOutClass.pod
+++ b/examples/InsideOutClass.pod
@@ -1,5 +1,4 @@
 
-
 package # hide the package from PAUSE
     InsideOutClass::Instance;
 
@@ -30,7 +29,8 @@ sub set_slot_value {
 
 sub initialize_slot {
     my ($self, $instance, $slot_name) = @_;
-    $self->{meta}->add_package_variable(('%' . $slot_name) => {}); 
+    $self->{meta}->add_package_variable(('%' . $slot_name) => {})
+        unless $self->{meta}->has_package_variable('%' . $slot_name); 
     $self->{meta}->get_package_variable('%' . $slot_name)->{refaddr $instance} = undef;
 }
 
diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod
index 566aacf..6d6017d 100644
--- a/examples/LazyClass.pod
+++ b/examples/LazyClass.pod
@@ -65,6 +65,20 @@ sub generate_reader_method {
     };   
 }
 
+
+
+package # hide the package from PAUSE
+    LazyClass::Instance;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Instance';
+
+sub initialize_all_slots {}
+
 1;
 
 __END__
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 80ca6c5..06246b6 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -179,7 +179,9 @@ sub new_object {
 
 sub construct_instance {
     my ($class, %params) = @_;
-    my $instance = $class->get_meta_instance->create_instance();
+    my $meta_instance = $class->get_meta_instance();
+    my $instance = $meta_instance->create_instance();
+    $meta_instance->initialize_all_slots($instance);
     foreach my $attr ($class->compute_all_applicable_attributes()) {
         $attr->initialize_instance_slot($instance, \%params);
     }
diff --git a/lib/Class/MOP/Instance.pm b/lib/Class/MOP/Instance.pm
index d7bb7fb..1832e29 100644
--- a/lib/Class/MOP/Instance.pm
+++ b/lib/Class/MOP/Instance.pm
@@ -52,6 +52,13 @@ sub get_all_slots {
 
 # operations on created instances
 
+sub initialize_all_slots {
+    my ($self, $instance) = @_;
+    foreach my $slot_name ($self->get_all_slots) {
+        $self->initialize_slot($instance, $slot_name);
+    }
+}
+
 sub get_slot_value {
     my ($self, $instance, $slot_name) = @_;
     return $instance->{$slot_name};
@@ -114,14 +121,14 @@ Class::MOP::Instance - Instance Meta Object
 
 =item B<new>
 
-=item B<bless_instance_structure>
-
-=item B<compute_layout_from_class>
-
 =item B<create_instance>
 
+=item B<bless_instance_structure>
+
 =item B<get_all_slots>
 
+=item B<initialize_all_slots>
+
 =item B<get_slot_value>
 
 =item B<set_slot_value>
diff --git a/t/106_LazyClass_test.t b/t/106_LazyClass_test.t
index ff3e354..466f55a 100644
--- a/t/106_LazyClass_test.t
+++ b/t/106_LazyClass_test.t
@@ -16,6 +16,7 @@ BEGIN {
     
     use metaclass 'Class::MOP::Class' => (
         ':attribute_metaclass' => 'LazyClass::Attribute',
+        ':instance_metaclass'  => 'LazyClass::Instance',        
     );
 
     BinaryTree->meta->add_attribute('$:node' => (
diff --git a/t/108_ArrayBasedInstance_test.t b/t/108_ArrayBasedInstance_test.t
new file mode 100644
index 0000000..9893cbb
--- /dev/null
+++ b/t/108_ArrayBasedInstance_test.t
@@ -0,0 +1,69 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 19;
+use File::Spec;
+
+BEGIN { 
+    use_ok('Class::MOP');    
+    require_ok(File::Spec->catdir('examples', 'ArrayBasedInstance.pod'));
+}
+
+{
+    package Foo;
+    
+    use metaclass 'Class::MOP::Class' => (
+        ':attribute_metaclass' => 'ArrayBasedInstance::Attribute',
+        ':instance_metaclass'  => 'ArrayBasedInstance::Instance',
+    );
+    
+    Foo->meta->add_attribute('foo' => (
+        accessor  => 'foo',
+        predicate => 'has_foo',
+    ));
+    
+    Foo->meta->add_attribute('bar' => (
+        reader  => 'get_bar',
+        writer  => 'set_bar',
+        default => 'FOO is BAR'            
+    ));
+    
+    sub new  {
+        my $class = shift;
+        $class->meta->new_object(@_);
+    }
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'has_foo');
+can_ok($foo, 'get_bar');
+can_ok($foo, 'set_bar');
+
+ok(!$foo->has_foo, '... Foo::foo is not defined yet');
+is($foo->foo(), undef, '... Foo::foo is not defined yet');
+is($foo->get_bar(), 'FOO is BAR', '... Foo::bar has been initialized');
+
+$foo->foo('This is Foo');
+
+ok($foo->has_foo, '... Foo::foo is defined now');
+is($foo->foo(), 'This is Foo', '... Foo::foo == "This is Foo"');
+
+$foo->set_bar(42);
+is($foo->get_bar(), 42, '... Foo::bar == 42');
+
+my $foo2 = Foo->new();
+isa_ok($foo2, 'Foo');
+
+ok(!$foo2->has_foo, '... Foo2::foo is not defined yet');
+is($foo2->foo(), undef, '... Foo2::foo is not defined yet');
+is($foo2->get_bar(), 'FOO is BAR', '... Foo2::bar has been initialized');
+
+$foo2->set_bar('DONT PANIC');
+is($foo2->get_bar(), 'DONT PANIC', '... Foo2::bar == DONT PANIC');
+
+is($foo->get_bar(), 42, '... Foo::bar == 42');