start of the new user-level API

diff --git a/Changes b/Changes
index fbcc008..1a4f6c7 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,15 @@
 Revision history for Perl extension Class-MOP.
 
+0.05
+    * Class::MOP::Class
+      - added the &attribute_metaclass and &method_metaclass
+        functions which return a metaclass name to use for 
+        attributes/methods respectively
+        
+    * examples/
+      - adjusted the example code and tests to use the new
+        &attribute_metaclass feature of Class::MOP::Class
+
 0.04 Fri Feb. 3, 2006
     * Class::MOP::Class
       - some documentation suggestions from #perl6

diff --git a/examples/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod
index 7c19e7a..d6380e3 100644 (file)
--- a/examples/ClassEncapsulatedAttributes.pod
+++ b/examples/ClassEncapsulatedAttributes.pod
@@ -38,6 +38,8 @@ sub construct_instance {
     return $instance;
 }
 
+sub attribute_metaclass { 'ClassEncapsulatedAttributes::Attribute' }
+
 package # hide the package from PAUSE
     ClassEncapsulatedAttributes::Attribute;
 
@@ -101,12 +103,10 @@ ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulat
   
   sub meta { ClassEncapsulatedAttributes->initialize($_[0]) }
   
-  Foo->meta->add_attribute(
-      ClassEncapsulatedAttributes::Attribute->new('foo' => (
-          accessor  => 'Foo_foo',
-          default   => 'init in FOO'
-      ))
-  );   
+  Foo->meta->add_attribute('foo' => (
+      accessor  => 'Foo_foo',
+      default   => 'init in FOO'
+  ));
   
   sub new  {
       my $class = shift;
@@ -117,12 +117,10 @@ ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulat
   our @ISA = ('Foo');
   
   # duplicate the attribute name here
-  Bar->meta->add_attribute(
-      ClassEncapsulatedAttributes::Attribute->new('foo' => (
-          accessor  => 'Bar_foo',
-          default   => 'init in BAR'            
-      ))
-  );      
+  Bar->meta->add_attribute('foo' => (
+      accessor  => 'Bar_foo',
+      default   => 'init in BAR'            
+  ));      
   
   # ... later in other code ...
   

diff --git a/examples/InsideOutClass.pod b/examples/InsideOutClass.pod
index dfb38d2..b371c15 100644 (file)
--- a/examples/InsideOutClass.pod
+++ b/examples/InsideOutClass.pod
@@ -34,6 +34,8 @@ sub construct_instance {
     return $instance;
 }
 
+sub attribute_metaclass { 'InsideOutClass::Attribute' }
+
 package # hide the package from PAUSE
     InsideOutClass::Attribute;
 
@@ -96,12 +98,10 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec
   
   sub meta { InsideOutClass->initialize($_[0]) }
   
-  __PACKAGE__->meta->add_attribute(
-      InsideOutClass::Attribute->new('foo' => (
-          reader => 'get_foo',
-          writer => 'set_foo'
-      ))
-  );    
+  __PACKAGE__->meta->add_attribute('foo' => (
+      reader => 'get_foo',
+      writer => 'set_foo'
+  ));    
   
   sub new  {
       my $class = shift;

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 303137f..74d76b4 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.04';
+our $VERSION = '0.05';
 
 sub import {
     shift;

diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm
index ecf8f5d..6ebd6d1 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.01';
+our $VERSION = '0.02';
 
 # Self-introspection
 
@@ -146,6 +146,9 @@ sub class_precedence_list {
 
 ## Methods
 
+# un-used right now ...
+sub method_metaclass { 'Class::MOP::Method' }
+
 sub add_method {
     my ($self, $method_name, $method) = @_;
     (defined $method_name && $method_name)
@@ -266,10 +269,16 @@ sub find_all_methods_by_name {
 
 ## Attributes
 
+sub attribute_metaclass { 'Class::MOP::Attribute' }
+
 sub add_attribute {
-    my ($self,$attribute) = @_;
-    (blessed($attribute) && $attribute->isa('Class::MOP::Attribute'))
-        || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";
+    my $self      = shift;
+    # either we have an attribute object already
+    # or we need to create one from the args provided
+    my $attribute = blessed($_[0]) ? $_[0] : $self->attribute_metaclass->new(@_);
+    # make sure it is derived from the correct type though
+    ($attribute->isa('Class::MOP::Attribute'))
+        || confess "Your attribute must be an instance of Class::MOP::Attribute (or a subclass)";    
     $attribute->attach_to_class($self);
     $attribute->install_accessors();        
     $self->{'%:attrs'}->{$attribute->name} = $attribute;
@@ -558,6 +567,8 @@ what B<Class::ISA::super_path> does, but we don't remove duplicate names.
 
 =over 4
 
+=item B<method_metaclass>
+
 =item B<add_method ($method_name, $method)>
 
 This will take a C<$method_name> and CODE reference to that 
@@ -644,6 +655,8 @@ their own. See L<Class::MOP::Attribute> for more details.
 
 =over 4
 
+=item B<attribute_metaclass>
+
 =item B<add_attribute ($attribute_name, $attribute_meta_object)>
 
 This stores a C<$attribute_meta_object> in the B<Class::MOP::Class> 

diff --git a/t/013_add_attribute_alternate.t b/t/013_add_attribute_alternate.t
new file mode 100644 (file)
index 0000000..8b168c6
--- /dev/null
+++ b/t/013_add_attribute_alternate.t
@@ -0,0 +1,108 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 27;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Class::MOP', ':universal');        
+}
+
+{
+    package Point;
+
+    Point->meta->add_attribute('$.x' => (
+        reader   => 'x',
+        init_arg => 'x'
+    ));
+
+    Point->meta->add_attribute('$.y' => (
+        accessor => 'y',
+        init_arg => 'y'
+    ));
+
+    sub new {
+        my $class = shift;
+        bless $class->meta->construct_instance(@_) => $class;
+    }
+
+    sub clear {
+        my $self = shift;
+        $self->{'$.x'} = 0;
+        $self->{'$.y'} = 0;            
+    }
+
+    package Point3D;
+    our @ISA = ('Point');
+    
+    Point3D->meta->add_attribute('$:z' => (
+        default => 123
+    ));
+
+    sub clear {
+        my $self = shift;
+        $self->{'$:z'} = 0;
+        $self->SUPER::clear();
+    }
+}
+
+isa_ok(Point->meta, 'Class::MOP::Class');
+isa_ok(Point3D->meta, 'Class::MOP::Class');
+
+# ... test the classes themselves
+
+my $point = Point->new('x' => 2, 'y' => 3);
+isa_ok($point, 'Point');
+
+can_ok($point, 'x');
+can_ok($point, 'y');
+can_ok($point, 'clear');
+
+{
+    my $meta = $point->meta;
+    is($meta, Point->meta(), '... got the meta from the instance too');
+}
+
+is($point->y, 3, '... the $.y attribute was initialized correctly through the metaobject');
+
+$point->y(42);
+is($point->y, 42, '... the $.y attribute was set properly with the accessor');
+
+is($point->x, 2, '... the $.x attribute was initialized correctly through the metaobject');
+
+$point->x(42);
+is($point->x, 2, '... the $.x attribute was not altered');
+
+$point->clear();
+
+is($point->y, 0, '... the $.y attribute was cleared correctly');
+is($point->x, 0, '... the $.x attribute was cleared correctly');
+
+my $point3d = Point3D->new('x' => 1, 'y' => 2, '$:z' => 3);
+isa_ok($point3d, 'Point3D');
+isa_ok($point3d, 'Point');
+
+{
+    my $meta = $point3d->meta;
+    is($meta, Point3D->meta(), '... got the meta from the instance too');
+}
+
+can_ok($point3d, 'x');
+can_ok($point3d, 'y');
+can_ok($point3d, 'clear');
+
+is($point3d->x, 1, '... the $.x attribute was initialized correctly through the metaobject');
+is($point3d->y, 2, '... the $.y attribute was initialized correctly through the metaobject');
+is($point3d->{'$:z'}, 3, '... the $:z attribute was initialized correctly through the metaobject');
+
+{
+    my $point3d = Point3D->new();
+    isa_ok($point3d, 'Point3D');
+    
+    is($point3d->x, undef, '... the $.x attribute was not initialized');
+    is($point3d->y, undef, '... the $.y attribute was not initialized');
+    is($point3d->{'$:z'}, 123, '... the $:z attribute was initialized correctly through the metaobject');    
+        
+}

diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t
index 6510ca7..fb7581e 100644 (file)
--- a/t/102_InsideOutClass_test.t
+++ b/t/102_InsideOutClass_test.t
@@ -16,20 +16,16 @@ BEGIN {
     
     sub meta { InsideOutClass->initialize($_[0]) }
     
-    Foo->meta->add_attribute(
-        InsideOutClass::Attribute->new('foo' => (
-            accessor  => 'foo',
-            predicate => 'has_foo',
-        ))
-    );
+    Foo->meta->add_attribute('foo' => (
+        accessor  => 'foo',
+        predicate => 'has_foo',
+    ));
     
-    Foo->meta->add_attribute(
-        InsideOutClass::Attribute->new('bar' => (
-            reader  => 'get_bar',
-            writer  => 'set_bar',
-            default => 'FOO is BAR'            
-        ))
-    );    
+    Foo->meta->add_attribute('bar' => (
+        reader  => 'get_bar',
+        writer  => 'set_bar',
+        default => 'FOO is BAR'            
+    ));
     
     sub new  {
         my $class = shift;

diff --git a/t/105_ClassEncapsulatedAttributes_test.t b/t/105_ClassEncapsulatedAttributes_test.t
index 199b4c2..47952e6 100644 (file)
--- a/t/105_ClassEncapsulatedAttributes_test.t
+++ b/t/105_ClassEncapsulatedAttributes_test.t
@@ -16,21 +16,17 @@ BEGIN {
     
     sub meta { ClassEncapsulatedAttributes->initialize($_[0]) }
     
-    Foo->meta->add_attribute(
-        ClassEncapsulatedAttributes::Attribute->new('foo' => (
-            accessor  => 'foo',
-            predicate => 'has_foo',            
-            default   => 'init in FOO'
-        ))
-    );
+    Foo->meta->add_attribute('foo' => (
+        accessor  => 'foo',
+        predicate => 'has_foo',            
+        default   => 'init in FOO'
+    ));
     
-    Foo->meta->add_attribute(
-        ClassEncapsulatedAttributes::Attribute->new('bar' => (
-            reader  => 'get_bar',
-            writer  => 'set_bar',
-            default => 'init in FOO'
-        ))
-    );    
+    Foo->meta->add_attribute('bar' => (
+        reader  => 'get_bar',
+        writer  => 'set_bar',
+        default => 'init in FOO'
+    ));
     
     sub new  {
         my $class = shift;
@@ -40,21 +36,17 @@ BEGIN {
     package Bar;
     our @ISA = ('Foo');
     
-    Bar->meta->add_attribute(
-        ClassEncapsulatedAttributes::Attribute->new('foo' => (
-            accessor  => 'foo',
-            predicate => 'has_foo',
-            default   => 'init in BAR'            
-        ))
-    );  
+    Bar->meta->add_attribute('foo' => (
+        accessor  => 'foo',
+        predicate => 'has_foo',
+        default   => 'init in BAR'            
+    ));
     
-    Bar->meta->add_attribute(
-        ClassEncapsulatedAttributes::Attribute->new('bar' => (
-            reader  => 'get_bar',
-            writer  => 'set_bar',
-            default => 'init in BAR'          
-        ))
-    );    
+    Bar->meta->add_attribute('bar' => (
+        reader  => 'get_bar',
+        writer  => 'set_bar',
+        default => 'init in BAR'          
+    ));
     
     sub SUPER_foo     { (shift)->SUPER::foo(@_)     }
     sub SUPER_has_foo { (shift)->SUPER::foo(@_)     }