From: Stevan Little <stevan.little@iinteractive.com>
Date: Tue, 14 Feb 2006 21:01:35 +0000 (+0000)
Subject: moving some tests around, increasing the coverage and generally improving the test... 
X-Git-Tag: 0_10~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=013b1897ada42ebdd970371868cc3679d3a49344;p=gitmo%2FClass-MOP.git

moving some tests around, increasing the coverage and generally improving the test suite
---

diff --git a/MANIFEST b/MANIFEST
index 109d2ee..8548f1d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1,8 +1,8 @@
 Build.PL
 Changes
+Makefile.PL
 MANIFEST
 MANIFEST.SKIP
-Makefile.PL
 META.yml
 README
 examples/AttributesWithHistory.pod
diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm
index 1dfc3b3..fa13bf3 100644
--- a/lib/Class/MOP/Attribute.pm
+++ b/lib/Class/MOP/Attribute.pm
@@ -114,36 +114,32 @@ sub detach_from_class {
 
 sub generate_accessor_method {
     my ($self, $attr_name) = @_;
-    eval qq{sub {
-        \$_[0]->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
-        \$_[0]->{'$attr_name'};
-    }};
+    sub {
+        $_[0]->{$attr_name} = $_[1] if scalar(@_) == 2;
+        $_[0]->{$attr_name};
+    };
 }
 
 sub generate_reader_method {
     my ($self, $attr_name) = @_; 
-    eval qq{sub {
-        \$_[0]->{'$attr_name'};
-    }};   
+    sub { $_[0]->{$attr_name} };   
 }
 
 sub generate_writer_method {
     my ($self, $attr_name) = @_; 
-    eval qq{sub {
-        \$_[0]->{'$attr_name'} = \$_[1];
-    }};
+    sub { $_[0]->{$attr_name} = $_[1] };
 }
 
 sub generate_predicate_method {
     my ($self, $attr_name) = @_; 
-    eval qq{sub {
-        defined \$_[0]->{'$attr_name'} ? 1 : 0;
-    }};
+    sub { defined $_[0]->{$attr_name} ? 1 : 0 };
 }
 
 sub process_accessors {
     my ($self, $type, $accessor) = @_;
-    if (reftype($accessor) && reftype($accessor) eq 'HASH') {
+    if (reftype($accessor)) {
+        (reftype($accessor) eq 'HASH')
+            || confess "bad accessor/reader/writer/predicate format, must be a HASH ref";
         my ($name, $method) = each %{$accessor};
         return ($name, Class::MOP::Attribute::Accessor->wrap($method));        
     }
diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index c109368..2baa6f3 100644
--- a/lib/Class/MOP/Class.pm
+++ b/lib/Class/MOP/Class.pm
@@ -252,7 +252,8 @@ sub add_method {
         
     no strict 'refs';
     no warnings 'redefine';
-    *{$full_method_name} = subname $full_method_name => $method;
+#    *{$full_method_name} = subname $full_method_name => $method;
+    *{$full_method_name} = $method;
 }
 
 sub alias_method {
diff --git a/t/010_self_introspection.t b/t/010_self_introspection.t
index 87416dd..c8308b6 100644
--- a/t/010_self_introspection.t
+++ b/t/010_self_introspection.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 117;
+use Test::More tests => 118;
 use Test::Exception;
 
 BEGIN {
@@ -11,6 +11,11 @@ BEGIN {
     use_ok('Class::MOP::Class');        
 }
 
+{
+    my $class = Class::MOP::Class->initialize('Foo');
+    is($class->meta, Class::MOP::Class->meta, '... instance and class both lead to the same meta');
+}
+
 my $meta = Class::MOP::Class->meta();
 isa_ok($meta, 'Class::MOP::Class');
 
diff --git a/t/014_attribute_introspection.t b/t/014_attribute_introspection.t
index 2fb3acb..12f8c94 100644
--- a/t/014_attribute_introspection.t
+++ b/t/014_attribute_introspection.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 38;
+use Test::More tests => 39;
 use Test::Exception;
 
 BEGIN {
@@ -11,6 +11,11 @@ BEGIN {
 }
 
 {
+    my $attr = Class::MOP::Attribute->new('$test');
+    is($attr->meta, Class::MOP::Attribute->meta, '... instance and class both lead to the same meta');
+}
+
+{
     my $meta = Class::MOP::Attribute->meta();
     isa_ok($meta, 'Class::MOP::Class');
     
diff --git a/t/016_class_errors_and_edge_cases.t b/t/016_class_errors_and_edge_cases.t
new file mode 100644
index 0000000..b9b3915
--- /dev/null
+++ b/t/016_class_errors_and_edge_cases.t
@@ -0,0 +1,11 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Class::MOP');
+}
\ No newline at end of file
diff --git a/t/020_attribute.t b/t/020_attribute.t
index 3e255f6..a85579d 100644
--- a/t/020_attribute.t
+++ b/t/020_attribute.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 62;
+use Test::More tests => 52;
 use Test::Exception;
 
 BEGIN {
@@ -113,62 +113,3 @@ BEGIN {
     
     is_deeply($attr, $attr_clone, '... but they are the same inside');       
 }
-
-# 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',
-    ));
-} '... can create accessors with reader/writers';
-
-lives_ok {
-    Class::MOP::Attribute->new('$foo', (
-        accessor => 'foo',
-        writer   => 'set_foo',
-    ));
-} '... can create accessors with reader/writers';
-
-lives_ok {
-    Class::MOP::Attribute->new('$foo', (
-        accessor => 'foo',
-        reader   => 'get_foo',        
-        writer   => 'set_foo',
-    ));
-} '... can create accessors with reader/writers';
-
-dies_ok {
-    Class::MOP::Attribute->new();
-} '... no name argument';
-
-dies_ok {
-    Class::MOP::Attribute->new('');
-} '... bad name argument';
-
-dies_ok {
-    Class::MOP::Attribute->new(0);
-} '... bad name argument';
-
-dies_ok {
-    Class::MOP::Attribute->install_accessors();
-} '... bad install_accessors argument';
-
-dies_ok {
-    Class::MOP::Attribute->install_accessors(bless {} => 'Fail');
-} '... bad install_accessors argument';
-
-dies_ok {
-    Class::MOP::Attribute->remove_accessors();
-} '... bad remove_accessors argument';
-
-dies_ok {
-    Class::MOP::Attribute->remove_accessors(bless {} => 'Fail');
-} '... bad remove_accessors argument';
diff --git a/t/021_attribute_errors_and_edge_cases.t b/t/021_attribute_errors_and_edge_cases.t
new file mode 100644
index 0000000..1b8c514
--- /dev/null
+++ b/t/021_attribute_errors_and_edge_cases.t
@@ -0,0 +1,140 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Class::MOP');
+    use_ok('Class::MOP::Attribute');
+}
+
+
+{
+    my $regexp = qr/hello (.*)/;
+    my $attr = Class::MOP::Attribute->new('$test' => (
+        default => $regexp
+    ));    
+    
+    ok($attr->has_default, '... we have a default value');
+    is($attr->default, $regexp, '... and got the value we expected');
+}
+
+{ # bad construtor args
+    dies_ok {
+        Class::MOP::Attribute->new();
+    } '... no name argument';
+
+    dies_ok {
+        Class::MOP::Attribute->new('');
+    } '... bad name argument';
+
+    dies_ok {
+        Class::MOP::Attribute->new(0);
+    } '... bad name argument';
+}
+
+{
+    my $attr = Class::MOP::Attribute->new('$test');    
+    dies_ok {
+        $attr->attach_to_class();
+    } '... attach_to_class died as expected';
+    
+    dies_ok {
+        $attr->attach_to_class('Fail');
+    } '... attach_to_class died as expected';    
+    
+    dies_ok {
+        $attr->attach_to_class(bless {} => 'Fail');
+    } '... attach_to_class died as expected';    
+}
+
+{
+    my $attr = Class::MOP::Attribute->new('$test' => (
+        reader => [ 'whoops, this wont work' ]
+    ));
+    
+    $attr->attach_to_class(Class::MOP::Class->initialize('Foo'));
+
+    dies_ok {
+        $attr->install_accessors;
+    } '... bad reader format';  
+}
+
+{
+    my $attr = Class::MOP::Attribute->new('$test');
+
+    dies_ok {
+        $attr->process_accessors('fail', 'my_failing_sub');
+    } '... cannot find "fail" type generator';
+}
+
+
+{
+    {
+        package My::Attribute;
+        our @ISA = ('Class::MOP::Attribute');
+        sub generate_reader_method { eval { die } }
+    }
+
+    my $attr = My::Attribute->new('$test' => (
+        reader => 'test'
+    ));
+    
+    dies_ok {
+        $attr->install_accessors;
+    } '... failed to generate accessors correctly';    
+}
+
+{
+    my $attr = Class::MOP::Attribute->new('$test' => (
+        predicate => 'has_test'
+    ));
+    
+    my $Bar = Class::MOP::Class->create('Bar' => '0.01');
+    isa_ok($Bar, 'Class::MOP::Class');
+    
+    $Bar->add_attribute($attr);
+    
+    can_ok('Bar', 'has_test');
+    
+    is($attr, $Bar->remove_attribute('$test'), '... removed the $test attribute');    
+    
+    ok(!Bar->can('has_test'), '... Bar no longer has the "has_test" method');    
+}
+
+
+{
+    # 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',
+        ));
+    } '... can create accessors with reader/writers';
+
+    lives_ok {
+        Class::MOP::Attribute->new('$foo', (
+            accessor => 'foo',
+            writer   => 'set_foo',
+        ));
+    } '... can create accessors with reader/writers';
+
+    lives_ok {
+        Class::MOP::Attribute->new('$foo', (
+            accessor => 'foo',
+            reader   => 'get_foo',        
+            writer   => 'set_foo',
+        ));
+    } '... can create accessors with reader/writers';
+}