From: Stevan Little <stevan.little@iinteractive.com>
Date: Mon, 6 Feb 2006 07:08:42 +0000 (+0000)
Subject: whole bunch of stuff
X-Git-Tag: 0_06~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5659d76e5bb87873fa7c80efdf1cce8c40d40237;p=gitmo%2FClass-MOP.git

whole bunch of stuff
---

diff --git a/TODO b/TODO
index 38440fc..81b803b 100644
--- a/TODO
+++ b/TODO
@@ -10,7 +10,7 @@ This will simplify some code, and really is not very expensive anyway
 
 - clean up bootstrapping to include the accessors, etc for attributes
 
-(PARTIALLY DONE) - could use some tests 
+(DONE)
 
 Having all this meta-info is useful actually, so why not add it, and 
 let the methods get overwritten if they need to be, its a small price
@@ -18,7 +18,7 @@ to pay for what we get from it.
 
 - clean up all ->initialize($_[0]) handling
 
-(PARTIALLY DONE) - needs tests
+(DONE)
   
 We should always be sure that $_[0] is a package name, and not 
 a blessed intstance.
@@ -41,7 +41,7 @@ class to implement, as is the construct_instance.
 
 - General Purpose &new_object and &clone_object method
 
-(PARTIALLY DONE) - needs tests
+(PARTIALLY DONE) - needs more tests
 
 I seem to be writing a new method each time, but since we dont
 have a Object class to always inherit from, this is needed.
diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod
index fe712c8..95c4688 100644
--- a/examples/AttributesWithHistory.pod
+++ b/examples/AttributesWithHistory.pod
@@ -95,7 +95,7 @@ AttributesWithHistory - An example attribute metaclass which keeps a history of
   
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance(@_) => $class;
+      $class->meta->new_object(@_);
   }
   
 =head1 DESCRIPTION
diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod
index 6087196..80bf6bb 100644
--- 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.02';
+our $VERSION = '0.03';
 
 use base 'Class::MOP::Class';
 
@@ -111,7 +111,7 @@ ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulat
   
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance(@_) => $class;
+      $class->meta->new_object(@_);
   }
   
   package Bar;
diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod
index d82cd03..653f917 100644
--- a/examples/InsideOutClass.pod
+++ b/examples/InsideOutClass.pod
@@ -104,8 +104,8 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec
   
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance(@_) => $class;
-  }  
+      $class->meta->new_object(@_);
+  } 
 
   # now you can just use the class as normal
 
diff --git a/examples/InstanceCountingClass.pod b/examples/InstanceCountingClass.pod
index 92ae097..5730517 100644
--- a/examples/InstanceCountingClass.pod
+++ b/examples/InstanceCountingClass.pod
@@ -40,7 +40,7 @@ InstanceCountingClass - An example metaclass which counts instances
   
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance(@_) => $class;
+      $class->meta->new_object(@_);
   }
 
   # ... meanwhile, somewhere in the code
diff --git a/examples/LazyClass.pod b/examples/LazyClass.pod
index e3c0b42..e4c7635 100644
--- a/examples/LazyClass.pod
+++ b/examples/LazyClass.pod
@@ -96,9 +96,9 @@ LazyClass - An example metaclass with lazy initialization
       default => sub { BinaryTree->new() }    
   ));    
   
-  sub new {
+  sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance(@_) => $class;
+      $class->meta->new_object(@_);
   }
   
   # ... later in code
diff --git a/examples/Perl6Attribute.pod b/examples/Perl6Attribute.pod
index 95cf71b..930c6cd 100644
--- a/examples/Perl6Attribute.pod
+++ b/examples/Perl6Attribute.pod
@@ -47,7 +47,7 @@ Perl6Attribute - An example attribute metaclass for Perl 6 style attributes
   
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance(@_) => $class;
+      $class->meta->new_object(@_);
   }
 
 =head1 DESCRIPTION
diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index f40f794..7b01847 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -147,12 +147,16 @@ Class::MOP::Attribute->meta->add_method('new' => sub {
         
     (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};
-    $options{init_arg} = $name if not exists $options{init_arg};
+    $options{init_arg} = $name 
+        if not exists $options{init_arg};
 
-    bless $class->meta->construct_instance(name => $name, %options) => blessed($class) || $class;
+    # return the new object
+    $class->meta->new_object(name => $name, %options);
+});
+
+Class::MOP::Attribute->meta->add_method('clone' => sub {
+    my $self = shift;
+    $self->meta->clone_object($self, @_);    
 });
 
 1;
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index c780a1d..dbdc2dc 100644
--- 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.02';
+our $VERSION = '0.03';
 
 sub meta { 
     require Class::MOP::Class;
@@ -30,11 +30,8 @@ sub new {
         
     (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};
-    
-    $options{init_arg} = $name if not exists $options{init_arg};
+    $options{init_arg} = $name 
+        if not exists $options{init_arg};
             
     bless {
         name      => $name,
@@ -51,6 +48,19 @@ sub new {
 }
 
 # NOTE:
+# this is a primative (and kludgy) clone operation 
+# for now, it will be repleace in the Class::MOP
+# bootstrap with a proper one, however we know 
+# that this one will work fine for now.
+sub clone {
+    my $self    = shift;
+    my %options = @_;
+    (blessed($self))
+        || confess "Can only clone an instance";
+    return bless { %{$self}, %options } => blessed($self);
+}
+
+# NOTE:
 # the next bunch of methods will get bootstrapped 
 # away in the Class::MOP bootstrapping section
 
@@ -254,6 +264,8 @@ An attribute must (at the very least), have a C<$name>. All other
 C<%options> are contained added as key-value pairs. Acceptable keys
 are as follows:
 
+=item B<clone (%options)>
+
 =over 4
 
 =item I<init_arg>
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index 529b4f6..7863468 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -6,6 +6,7 @@ use warnings;
 
 use Carp         'confess';
 use Scalar::Util 'blessed', 'reftype';
+use Hash::Util   'lock_keys';
 use Sub::Name    'subname';
 use B            'svref_2object';
 
@@ -150,6 +151,63 @@ sub clone_object {
     bless $class->clone_instance($instance, @_) => blessed($instance);
 }
 
+#{
+#    sub _deep_clone {       
+#        my ($object, $cache) = @_;
+#        return $object unless ref($object);
+#        # check for an active cache
+#        return _deep_clone_ref($object, ($cache = {}), 'HASH') if not defined $cache;      
+#        # if we have it in the cache them return the cached clone
+#        return $cache->{$object} if exists $cache->{$object};
+#        # now try it as an object, which will in
+#        # turn try it as ref if its not an object
+#        # and store it in case we run into a circular ref
+#        $cache->{$object} = _deep_clone_object($object, $cache);    
+#    }
+#
+#    sub _deep_clone_object {
+#        my ($object, $cache) = @_;
+#        # check to see if its an object, with a clone method    
+#        # or if we have an object, with no clone method, then
+#        # we will respect its encapsulation, and not muck with 
+#        # its internals. Basically, we assume it does not want
+#        # to be cloned    
+#        return $cache->{$object} = ($object->can('clone') ? $object->clone() : $object) 
+#            if blessed($object);
+#        return $cache->{$object} = _deep_clone_ref($object, $cache);     
+#    }
+#
+#    sub _deep_clone_ref { 
+#        my ($object, $cache, $ref_type) = @_;
+#        $ref_type ||= ref($object);
+#        my ($clone, $tied);
+#        if ($ref_type eq 'HASH') {
+#            $clone = {};
+#            tie %{$clone}, ref $tied if $tied = tied(%{$object});    
+#            %{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } %{$object};
+#        } 
+#        elsif ($ref_type eq 'ARRAY') {
+#            $clone = [];
+#            tie @{$clone}, ref $tied if $tied = tied(@{$object});
+#            @{$clone} = map { ref($_) ? _deep_clone($_, $cache) : $_ } @{$object};
+#        } 
+#        elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
+#            my $var = "";
+#            $clone = \$var;
+#            tie ${$clone}, ref $tied if $tied = tied(${$object});
+#            ${$clone} = _deep_clone(${$object}, $cache);
+#        } 
+#        else {
+#            # shallow copy reference to code, glob, regex
+#            $clone = $object;
+#        }
+#        # store it in our cache
+#        $cache->{$object} = $clone;
+#        # and return the clone
+#        return $clone;    
+#    }    
+#}
+
 sub clone_instance {
     my ($class, $instance, %params) = @_;
     (blessed($instance))
@@ -159,7 +217,7 @@ sub clone_instance {
     # instead of this cheap hack. I will 
     # add that in later. 
     # (use the Class::Cloneable::Util code)
-    my $clone = { %{$instance} }; 
+    my $clone = { %{$instance} }; #_deep_clone($instance); 
     foreach my $attr ($class->compute_all_applicable_attributes()) {
         my $init_arg = $attr->init_arg();
         # try to fetch the init arg from the %params ...        
diff --git a/t/006_new_and_clone_metaclasses.t b/t/006_new_and_clone_metaclasses.t
index 3646cf4..68916b0 100644
--- a/t/006_new_and_clone_metaclasses.t
+++ b/t/006_new_and_clone_metaclasses.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 29;
+use Test::More tests => 32;
 use Test::Exception;
 
 BEGIN {
@@ -92,6 +92,11 @@ my $bar = $bar_meta->new_object();
 isa_ok($bar, 'Bar');
 isa_ok($bar, 'Foo');
 
+my $baz = $baz_meta->new_object();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
 my $cloned_foo = $foo_meta->clone_object($foo);
 isa_ok($cloned_foo, 'Foo');
 
diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t
new file mode 100644
index 0000000..d0c9ba9
--- /dev/null
+++ b/t/014_attribute_introspection.t
@@ -0,0 +1,70 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 38;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Class::MOP');        
+}
+
+{
+    my $meta = Class::MOP::Attribute->meta();
+    isa_ok($meta, 'Class::MOP::Class');
+    
+    my @methods = qw(
+        meta 
+        new clone
+        name
+        has_accessor  accessor
+        has_writer    writer
+        has_reader    reader
+        has_predicate predicate
+        has_init_arg  init_arg
+        has_default   default
+        
+        associated_class
+        attach_to_class detach_from_class
+        
+        generate_accessor_method
+        generate_reader_method
+        generate_writer_method
+        generate_predicate_method
+        
+        process_accessors
+        install_accessors
+        remove_accessors
+        );
+        
+    is_deeply(
+        [ sort @methods ],
+        [ sort $meta->get_method_list ],
+        '... our method list matches');        
+    
+    foreach my $method_name (@methods) {
+        ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
+    }
+    
+    my @attributes = qw(
+        name accessor reader writer predicate
+        init_arg default associated_class
+        );
+
+    is_deeply(
+        [ sort @attributes ],
+        [ sort $meta->get_attribute_list ],
+        '... our attribute list matches');
+    
+    foreach my $attribute_name (@attributes) {
+        ok($meta->has_attribute($attribute_name), '... Class::MOP::Attribute->has_attribute(' . $attribute_name . ')');        
+    }
+    
+    # We could add some tests here to make sure that 
+    # the attribute have the appropriate 
+    # accessor/reader/writer/predicate combinations, 
+    # but that is getting a little excessive so I  
+    # wont worry about it for now. Maybe if I get 
+    # bored I will do it.
+}
\ No newline at end of file
diff --git a/t/020_attribute.t b/t/020_attribute.t
index fd0be90..77e3589 100644
--- a/t/020_attribute.t
+++ b/t/020_attribute.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 65;
+use Test::More tests => 62;
 use Test::Exception;
 
 BEGIN {
@@ -22,7 +22,13 @@ BEGIN {
     ok(!$attr->has_accessor, '... $attr does not have an accessor');
     ok(!$attr->has_reader, '... $attr does not have an reader');
     ok(!$attr->has_writer, '... $attr does not have an writer');
-    ok(!$attr->has_default, '... $attr does not have an default');                
+    ok(!$attr->has_default, '... $attr does not have an default');  
+    
+    my $attr_clone = $attr->clone();
+    isa_ok($attr_clone, 'Class::MOP::Attribute');
+    isnt($attr, $attr_clone, '... but they are different instances');
+    
+    is_deeply($attr, $attr_clone, '... but they are the same inside');
 }
 
 {
@@ -41,7 +47,13 @@ BEGIN {
     
     ok(!$attr->has_accessor, '... $attr does not have an accessor');
     ok(!$attr->has_reader, '... $attr does not have an reader');
-    ok(!$attr->has_writer, '... $attr does not have an writer');               
+    ok(!$attr->has_writer, '... $attr does not have an writer');   
+    
+    my $attr_clone = $attr->clone();
+    isa_ok($attr_clone, 'Class::MOP::Attribute');
+    isnt($attr, $attr_clone, '... but they are different instances');
+    
+    is_deeply($attr, $attr_clone, '... but they are the same inside');                
 }
 
 {
@@ -63,7 +75,13 @@ BEGIN {
     is($attr->accessor, 'foo', '... $attr->accessor == foo');
     
     ok(!$attr->has_reader, '... $attr does not have an reader');
-    ok(!$attr->has_writer, '... $attr does not have an writer');               
+    ok(!$attr->has_writer, '... $attr does not have an writer');   
+    
+    my $attr_clone = $attr->clone();
+    isa_ok($attr_clone, 'Class::MOP::Attribute');
+    isnt($attr, $attr_clone, '... but they are different instnaces');
+    
+    is_deeply($attr, $attr_clone, '... but they are the same inside');                
 }
 
 {
@@ -87,30 +105,45 @@ BEGIN {
     ok($attr->has_writer, '... $attr does have an writer');
     is($attr->writer, 'set_foo', '... $attr->writer == set_foo');    
 
-    ok(!$attr->has_accessor, '... $attr does not have an accessor');    
+    ok(!$attr->has_accessor, '... $attr does not have an accessor'); 
+    
+    my $attr_clone = $attr->clone();
+    isa_ok($attr_clone, 'Class::MOP::Attribute');
+    isnt($attr, $attr_clone, '... but they are different instnaces');
+    
+    is_deeply($attr, $attr_clone, '... but they are the same inside');       
 }
 
-dies_ok {
+# NOTE:
+# the next three tests once tested that 
+# the code would fail, but we lifted the 
+# restriction so you can have an accessor 
+# along with a reader/writer pair (I mean 
+# why not really). So now they test that 
+# it works, which is kinda silly, but it 
+# tests the API change, so I keep it.
+
+lives_ok {
     Class::MOP::Attribute->new('$foo', (
         accessor => 'foo',
         reader   => 'get_foo',
     ));
-} '... cannot create accessors with reader/writers';
+} '... can create accessors with reader/writers';
 
-dies_ok {
+lives_ok {
     Class::MOP::Attribute->new('$foo', (
         accessor => 'foo',
         writer   => 'set_foo',
     ));
-} '... cannot create accessors with reader/writers';
+} '... can create accessors with reader/writers';
 
-dies_ok {
+lives_ok {
     Class::MOP::Attribute->new('$foo', (
         accessor => 'foo',
         reader   => 'get_foo',        
         writer   => 'set_foo',
     ));
-} '... cannot create accessors with reader/writers';
+} '... can create accessors with reader/writers';
 
 dies_ok {
     Class::MOP::Attribute->new();
@@ -139,25 +172,3 @@ dies_ok {
 dies_ok {
     Class::MOP::Attribute->remove_accessors(bless {} => 'Fail');
 } '... bad remove_accessors argument';
-
-
-{
-    my $meta = Class::MOP::Attribute->meta();
-    isa_ok($meta, 'Class::MOP::Class');
-    
-    foreach my $method_name (qw(
-        meta 
-        new
-        has_accessor accessor
-        has_writer   writer
-        has_reader   reader
-        has_init_arg init_arg
-        has_default  default
-        install_accessors
-        remove_accessors
-        )) {
-        ok($meta->has_method($method_name), '... Class::MOP::Attribute->has_method(' . $method_name . ')');
-    }
-    
-    
-}
diff --git a/t/101_InstanceCountingClass_test.t b/t/101_InstanceCountingClass_test.t
index 9941c7d..0cc7b7a 100644
--- a/t/101_InstanceCountingClass_test.t
+++ b/t/101_InstanceCountingClass_test.t
@@ -27,7 +27,7 @@ a simple demonstration of how to make a metaclass.
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance(@_) => $class;
+        $class->meta->new_object(@_);
     }
     
     package Bar;
diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t
index 5341b19..fcd877d 100644
--- a/t/102_InsideOutClass_test.t
+++ b/t/102_InsideOutClass_test.t
@@ -31,7 +31,7 @@ BEGIN {
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance(@_) => $class;
+        $class->meta->new_object(@_);
     }
 }
 
diff --git a/t/103_Perl6Attribute_test.t b/t/103_Perl6Attribute_test.t
index 8ad155c..d9e77bf 100644
--- a/t/103_Perl6Attribute_test.t
+++ b/t/103_Perl6Attribute_test.t
@@ -22,8 +22,8 @@ BEGIN {
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance(@_) => $class;
-    }        
+        $class->meta->new_object(@_);
+    }      
 }
 
 my $foo = Foo->new();
diff --git a/t/104_AttributesWithHistory_test.t b/t/104_AttributesWithHistory_test.t
index ada9d67..8542ef0 100644
--- a/t/104_AttributesWithHistory_test.t
+++ b/t/104_AttributesWithHistory_test.t
@@ -29,8 +29,8 @@ BEGIN {
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance(@_) => $class;
-    }        
+        $class->meta->new_object(@_);
+    }   
 }
 
 my $foo = Foo->new();
diff --git a/t/105_ClassEncapsulatedAttributes_test.t b/t/105_ClassEncapsulatedAttributes_test.t
index 712d35a..57b9760 100644
--- a/t/105_ClassEncapsulatedAttributes_test.t
+++ b/t/105_ClassEncapsulatedAttributes_test.t
@@ -30,7 +30,7 @@ BEGIN {
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance(@_) => $class;
+        $class->meta->new_object(@_);
     }
     
     package Bar;