more stuff

diff --git a/Changes b/Changes
index 2148063..9e61249 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,7 +1,16 @@
 Revision history for Perl extension Class-MOP.
 
 0.04 
-    - some documentation suggestions from #perl6
+    * Class::MOP::Class
+      - some documentation suggestions from #perl6
+    
+    * Class::MOP::Attribute
+      - improved error messages    
+    
+    * examples/
+      - added new examples:
+        - AttributesWithHistory
+        - 
 
 0.03 Fri Feb. 3, 2006
     - converted to Module::Build instead of EU::MM

diff --git a/examples/AttributesWithHistory.pod b/examples/AttributesWithHistory.pod
index 0061171..7039c5a 100644 (file)
--- a/examples/AttributesWithHistory.pod
+++ b/examples/AttributesWithHistory.pod
@@ -97,7 +97,7 @@ AttributesWithHistory - An example attribute metaclass which keeps a history of
   
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance() => $class;
+      bless $class->meta->construct_instance(@_) => $class;
   }
   
 =head1 DESCRIPTION
@@ -122,4 +122,3 @@ 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/ClassEncapsulatedAttributes.pod b/examples/ClassEncapsulatedAttributes.pod
new file mode 100644 (file)
index 0000000..030fdb4
--- /dev/null
+++ b/examples/ClassEncapsulatedAttributes.pod
@@ -0,0 +1,160 @@
+
+package # hide the package from PAUSE
+    ClassEncapsulatedAttributes;
+
+use strict;
+use warnings;
+
+use Class::MOP 'meta';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Class';
+
+sub construct_instance {
+    my ($class, %params) = @_;
+    #use Data::Dumper; warn Dumper \%params;    
+    my $instance = {};
+    foreach my $current_class ($class->class_precedence_list()) {
+        $instance->{$current_class} = {} 
+            unless exists $instance->{$current_class};
+        my $meta = $class->initialize($current_class);
+        foreach my $attr_name ($meta->get_attribute_list()) {
+            my $attr = $meta->get_attribute($attr_name);
+            # if the attr has an init_arg, use that, otherwise,
+            # use the attributes name itself as the init_arg
+            my $init_arg = $attr->has_init_arg() ? $attr->init_arg() : $attr->name;
+            # try to fetch the init arg from the %params ...
+            my $val;        
+            $val = $params{$current_class}->{$init_arg} 
+                if exists $params{$current_class} && 
+                   exists ${$params{$current_class}}{$init_arg};
+            # if nothing was in the %params, we can use the 
+            # attribute's default value (if it has one)
+            $val ||= $attr->default($instance) if $attr->has_default();
+            # now add this to the instance structure
+            $instance->{$current_class}->{$attr_name} = $val;
+        }
+    }  
+    #use Data::Dumper; warn Dumper $instance;
+    return $instance;
+}
+
+package # hide the package from PAUSE
+    ClassEncapsulatedAttributes::Attribute;
+
+use strict;
+use warnings;
+
+use Class::MOP 'meta';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Attribute';
+
+sub generate_accessor_method {
+    my ($self, $attr_name) = @_;
+    my $class_name = $self->associated_class->name;
+    eval qq{sub {
+        \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1] if scalar(\@_) == 2;
+        \$_[0]->{'$class_name'}->{'$attr_name'};
+    }};
+}
+
+sub generate_reader_method {
+    my ($self, $attr_name) = @_; 
+    my $class_name = $self->associated_class->name;
+    eval qq{sub {
+        \$_[0]->{'$class_name'}->{'$attr_name'};
+    }};   
+}
+
+sub generate_writer_method {
+    my ($self, $attr_name) = @_; 
+    my $class_name = $self->associated_class->name;    
+    eval qq{sub {
+        \$_[0]->{'$class_name'}->{'$attr_name'} = \$_[1];
+    }};
+}
+
+sub generate_predicate_method {
+    my ($self, $attr_name) = @_; 
+    my $class_name = $self->associated_class->name;    
+    eval qq{sub {
+        defined \$_[0]->{'$class_name'}->{'$attr_name'} ? 1 : 0;
+    }};
+}
+
+## &remove_attribute is left as an exercise for the reader :)
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes
+
+=head1 SYNOPSIS
+
+  package Foo;
+  
+  sub meta { ClassEncapsulatedAttributes->initialize($_[0]) }
+  
+  Foo->meta->add_attribute(
+      ClassEncapsulatedAttributes::Attribute->new('foo' => (
+          accessor  => 'Foo_foo',
+          default   => 'init in FOO'
+      ))
+  );   
+  
+  sub new  {
+      my $class = shift;
+      bless $class->meta->construct_instance(@_) => $class;
+  }
+  
+  package Bar;
+  our @ISA = ('Foo');
+  
+  # duplicate the attribute name here
+  Bar->meta->add_attribute(
+      ClassEncapsulatedAttributes::Attribute->new('foo' => (
+          accessor  => 'Bar_foo',
+          default   => 'init in BAR'            
+      ))
+  );      
+  
+  # ... later in other code ...
+  
+  my $bar = Bar->new();
+  prints $bar->Bar_foo(); # init in BAR
+  prints $bar->Foo_foo(); # init in FOO  
+  
+  # and ...
+  
+  my $bar = Bar->new(
+      'Foo' => { 'foo' => 'Foo::foo' },
+      'Bar' => { 'foo' => 'Bar::foo' }        
+  );  
+  
+  prints $bar->Bar_foo(); # Foo::foo
+  prints $bar->Foo_foo(); # Bar::foo  
+  
+=head1 DESCRIPTION
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=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 17f9044..dfb38d2 100644 (file)
--- a/examples/InsideOutClass.pod
+++ b/examples/InsideOutClass.pod
@@ -105,7 +105,7 @@ InsideOutClass - A set of example metaclasses which implement the Inside-Out tec
   
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance() => $class;
+      bless $class->meta->construct_instance(@_) => $class;
   }  
 
   # now you can just use the class as normal

diff --git a/examples/InstanceCountingClass.pod b/examples/InstanceCountingClass.pod
index 93ba4d5..614303e 100644 (file)
--- a/examples/InstanceCountingClass.pod
+++ b/examples/InstanceCountingClass.pod
@@ -41,7 +41,7 @@ InstanceCountingClass - An example metaclass which counts instances
   sub meta { InstanceCountingClass->initialize($_[0]) }
   sub new  {
       my $class = shift;
-      bless $class->meta->construct_instance() => $class;
+      bless $class->meta->construct_instance(@_) => $class;
   }
 
   # ... meanwhile, somewhere in the code

diff --git a/examples/Perl6Attribute.pod b/examples/Perl6Attribute.pod
index 47c93f9..95cf71b 100644 (file)
--- 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;
+      bless $class->meta->construct_instance(@_) => $class;
   }
 
 =head1 DESCRIPTION

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

diff --git a/t/101_InstanceCountingClass_test.t b/t/101_InstanceCountingClass_test.t
index 9f2215f..829ab28 100644 (file)
--- a/t/101_InstanceCountingClass_test.t
+++ b/t/101_InstanceCountingClass_test.t
@@ -26,7 +26,7 @@ a simple demonstration of how to make a metaclass.
     sub meta { InstanceCountingClass->initialize($_[0]) }
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance() => $class;
+        bless $class->meta->construct_instance(@_) => $class;
     }
     
     package Bar;

diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t
index a8cd234..6510ca7 100644 (file)
--- a/t/102_InsideOutClass_test.t
+++ b/t/102_InsideOutClass_test.t
@@ -33,7 +33,7 @@ BEGIN {
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance() => $class;
+        bless $class->meta->construct_instance(@_) => $class;
     }
 }
 

diff --git a/t/103_Perl6Attribute_test.t b/t/103_Perl6Attribute_test.t
index 90772f0..84e1ea9 100644 (file)
--- a/t/103_Perl6Attribute_test.t
+++ b/t/103_Perl6Attribute_test.t
@@ -22,7 +22,7 @@ BEGIN {
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance() => $class;
+        bless $class->meta->construct_instance(@_) => $class;
     }        
 }
 

diff --git a/t/104_AttributesWithHistory_test.t b/t/104_AttributesWithHistory_test.t
index 702162e..ada9d67 100644 (file)
--- a/t/104_AttributesWithHistory_test.t
+++ b/t/104_AttributesWithHistory_test.t
@@ -29,7 +29,7 @@ BEGIN {
     
     sub new  {
         my $class = shift;
-        bless $class->meta->construct_instance() => $class;
+        bless $class->meta->construct_instance(@_) => $class;
     }        
 }
 

diff --git a/t/105_ClassEncapsulatedAttributes_test.t b/t/105_ClassEncapsulatedAttributes_test.t
new file mode 100644 (file)
index 0000000..199b4c2
--- /dev/null
+++ b/t/105_ClassEncapsulatedAttributes_test.t
@@ -0,0 +1,117 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 29;
+use File::Spec;
+
+BEGIN { 
+    use_ok('Class::MOP');    
+    require_ok(File::Spec->catdir('examples', 'ClassEncapsulatedAttributes.pod'));
+}
+
+{
+    package Foo;
+    
+    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(
+        ClassEncapsulatedAttributes::Attribute->new('bar' => (
+            reader  => 'get_bar',
+            writer  => 'set_bar',
+            default => 'init in FOO'
+        ))
+    );    
+    
+    sub new  {
+        my $class = shift;
+        bless $class->meta->construct_instance(@_) => $class;
+    }
+    
+    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(
+        ClassEncapsulatedAttributes::Attribute->new('bar' => (
+            reader  => 'get_bar',
+            writer  => 'set_bar',
+            default => 'init in BAR'          
+        ))
+    );    
+    
+    sub SUPER_foo     { (shift)->SUPER::foo(@_)     }
+    sub SUPER_has_foo { (shift)->SUPER::foo(@_)     }    
+    sub SUPER_get_bar { (shift)->SUPER::get_bar()   }    
+    sub SUPER_set_bar { (shift)->SUPER::set_bar(@_) }        
+      
+}
+
+{
+    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');
+
+    my $bar = Bar->new();
+    isa_ok($bar, 'Bar');
+
+    can_ok($bar, 'foo');
+    can_ok($bar, 'has_foo');
+    can_ok($bar, 'get_bar');
+    can_ok($bar, 'set_bar');
+
+    ok($foo->has_foo, '... Foo::has_foo == 1');
+    ok($bar->has_foo, '... Bar::has_foo == 1');
+
+    is($foo->foo, 'init in FOO', '... got the right default value for Foo::foo');
+    is($bar->foo, 'init in BAR', '... got the right default value for Bar::foo');
+    
+    is($bar->SUPER_foo(), 'init in FOO', '... got the right default value for Bar::SUPER::foo');    
+    
+    $bar->SUPER_foo(undef);
+
+    is($bar->SUPER_foo(), undef, '... successfully set Foo::foo through Bar::SUPER::foo');        
+    ok(!$bar->SUPER_has_foo, '... BAR::SUPER::has_foo == 0');    
+
+    ok($foo->has_foo, '... Foo::has_foo (is still) 1');
+}
+
+{
+    my $bar = Bar->new(
+        'Foo' => { 'foo' => 'Foo::foo' },
+        'Bar' => { 'foo' => 'Bar::foo' }        
+    );
+    isa_ok($bar, 'Bar');
+
+    can_ok($bar, 'foo');
+    can_ok($bar, 'has_foo');
+    can_ok($bar, 'get_bar');
+    can_ok($bar, 'set_bar');
+
+    ok($bar->has_foo, '... Bar::has_foo == 1');
+    ok($bar->SUPER_has_foo, '... Bar::SUPER_has_foo == 1');    
+
+    is($bar->foo, 'Bar::foo', '... got the right default value for Bar::foo');    
+    is($bar->SUPER_foo(), 'Foo::foo', '... got the right default value for Bar::SUPER::foo');    
+}
+