From: Stevan Little <stevan.little@iinteractive.com>
Date: Fri, 3 Feb 2006 02:00:28 +0000 (+0000)
Subject: adding in some more examples
X-Git-Tag: 0_02~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e2f8b0294f79326f6bae28672868e0732bf0cace;p=gitmo%2FClass-MOP.git

adding in some more examples
---

diff --git a/examples/InsideOutClass.pm b/examples/InsideOutClass.pm
index a73f24b..78d1df3 100644
--- a/examples/InsideOutClass.pm
+++ b/examples/InsideOutClass.pm
@@ -6,14 +6,16 @@ use warnings;
 
 use Class::MOP 'meta';
 
-use Scalar::Util 'refaddr';
+our $VERSION = '0.02';
 
-our $VERSION = '0.01';
+use Scalar::Util 'refaddr';
 
-__PACKAGE__->meta->superclasses('Class::MOP::Class');
+use base 'Class::MOP::Class';
 
 sub construct_instance {
     my ($class, %params) = @_;
+    # create a scalar ref to use as 
+    # the inside-out instance
     my $instance = \(my $var);
     foreach my $attr (map { $_->{attribute} } $class->compute_all_applicable_attributes()) {
         # if the attr has an init_arg, use that, otherwise,
@@ -31,27 +33,25 @@ sub construct_instance {
     return $instance;
 }
 
-
-package InsideOutAttribute;
+package InsideOutClass::Attribute;
 
 use strict;
 use warnings;
 
-use Carp         'confess';
-use Scalar::Util 'blessed', 'reftype', 'refaddr';
-
 use Class::MOP 'meta';
 
-our $VERSION = '0.01';
+our $VERSION = '0.02';
 
-__PACKAGE__->meta->superclasses('Class::MOP::Attribute');
+use Carp         'confess';
+use Scalar::Util 'blessed', 'reftype', 'refaddr';
+
+use base 'Class::MOP::Attribute';
 
 {
     # this is just a utility routine to 
     # handle the details of accessors
     my $_inspect_accessor = sub {
-        my ($attr_name, $type, $accessor) = @_;
-    
+        my ($attr_name, $type, $accessor) = @_;    
         my %ACCESSOR_TEMPLATES = (
             'accessor' => 'sub {
                 $' . $attr_name . '{ refaddr($_[0]) } = $_[1] if scalar(@_) == 2;
@@ -68,15 +68,9 @@ __PACKAGE__->meta->superclasses('Class::MOP::Attribute');
             }'
         );    
     
-        if (reftype($accessor) && reftype($accessor) eq 'HASH') {
-            my ($name, $method) = each %{$accessor};
-            return ($name, Class::MOP::Attribute::Accessor->wrap($method));        
-        }
-        else {
-            my $method = eval $ACCESSOR_TEMPLATES{$type};
-            confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
-            return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
-        }    
+        my $method = eval $ACCESSOR_TEMPLATES{$type};
+        confess "Could not create the $type for $attr_name CODE(\n" . $ACCESSOR_TEMPLATES{$type} . "\n) : $@" if $@;
+        return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
     };
 
     sub install_accessors {
@@ -84,7 +78,11 @@ __PACKAGE__->meta->superclasses('Class::MOP::Attribute');
         (blessed($class) && $class->isa('Class::MOP::Class'))
             || confess "You must pass a Class::MOP::Class instance (or a subclass)";       
         
+        # create the package variable to 
+        # store the inside out attribute
         $class->add_package_variable('%' . $self->name);
+        
+        # now create the accessor/reader/writer/predicate methods
              
         $class->add_method(
             $_inspect_accessor->($class->name . '::' . $self->name, 'accessor' => $self->accessor())
@@ -108,4 +106,74 @@ __PACKAGE__->meta->superclasses('Class::MOP::Attribute');
 
 ## &remove_attribute is left as an exercise for the reader :)
 
-1;
\ No newline at end of file
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InsideOutClass - A set of metaclasses which use the Inside-Out technique
+
+=head1 SYNOPSIS
+
+  package Foo;
+  
+  sub meta { InsideOutClass->initialize($_[0]) }
+  
+  __PACKAGE__->meta->add_attribute(
+      InsideOutClass::Attribute->new('foo' => (
+          reader => 'get_foo',
+          writer => 'set_foo'
+      ))
+  );    
+  
+  sub new  {
+      my $class = shift;
+      bless $class->meta->construct_instance() => $class;
+  }  
+
+  # now you can just use the class as normal
+
+=head1 DESCRIPTION
+
+This is a set of example metaclasses which implement the Inside-Out 
+class technique. What follows is a brief explaination of the code 
+found in this module.
+
+First step is to subclass B<Class::MOP::Class> and override the 
+C<construct_instance> method. The default C<construct_instance> 
+will create a HASH reference using the parameters and attribute 
+default values. Since inside-out objects don't use HASH refs, and 
+use package variables instead, we need to write code to handle 
+this difference. 
+
+The next step is to create the subclass of B<Class::MOP::Attribute> 
+and override the C<install_accessors> method (you would also need to
+override the C<remove_accessors> too, but we can safely ignore that 
+in our example). The C<install_accessor> method is called by the 
+C<add_attribute> method of B<Class::MOP::Class>, and will install 
+the accessors for your attribute. Since inside-out objects require 
+different types of accessors, we need to write the code to handle 
+this difference as well.
+
+And that is pretty much all. Of course I am ignoring need for 
+inside-out objects to be C<DESTROY>-ed, and some other details as 
+well, but this is an example. A real implementation is left as an 
+exercise to the reader.
+
+=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/InstanceCountingClass.pm b/examples/InstanceCountingClass.pm
index 75de0db..fdfb76d 100644
--- a/examples/InstanceCountingClass.pm
+++ b/examples/InstanceCountingClass.pm
@@ -8,7 +8,7 @@ use Class::MOP 'meta';
 
 our $VERSION = '0.01';
 
-__PACKAGE__->meta->superclasses('Class::MOP::Class');
+use base 'Class::MOP::Class';
 
 __PACKAGE__->meta->add_attribute(
     Class::MOP::Attribute->new('$:count' => (
@@ -23,4 +23,52 @@ sub construct_instance {
     return $class->SUPER::construct_instance();
 }
 
-1;
\ No newline at end of file
+1;
+
+__END__
+
+=pod
+
+=head1 NAME 
+
+InstanceCountingClass - An example metaclass which counts instances
+
+=head1 SYNOPSIS
+
+  package Foo;
+  
+  sub meta { InstanceCountingClass->initialize($_[0]) }
+  sub new  {
+      my $class = shift;
+      bless $class->meta->construct_instance() => $class;
+  }
+
+  # ... meanwhile, somewhere in the code
+
+  my $foo = Foo->new();
+  print Foo->meta->get_count(); # prints 1
+  
+  my $foo2 = Foo->new();
+  print Foo->meta->get_count(); # prints 2  
+  
+  # ... etc etc etc
+
+=head1 DESCRIPTION
+
+This is a classic example of a metaclass which keeps a count of each 
+instance which is created. 
+
+=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/Perl6Attribute.pm b/examples/Perl6Attribute.pm
new file mode 100644
index 0000000..5ba274e
--- /dev/null
+++ b/examples/Perl6Attribute.pm
@@ -0,0 +1,81 @@
+
+package Perl6Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Attribute';
+
+sub new {
+    my ($class, $attribute_name, %options) = @_;
+    
+    # extract the sigil and accessor name
+    my ($sigil, $accessor_name) = ($attribute_name =~ /^([\$\@\%])\.(.*)$/);
+    
+    # pass the accessor name
+    $options{accessor} = $accessor_name;
+    
+    # create a default value based on the sigil
+    $options{default} = sub { [] } if ($sigil eq '@');
+    $options{default} = sub { {} } if ($sigil eq '%');        
+    
+    $class->SUPER::new($attribute_name, %options);
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl6Attribute - An attribute metaclass for Perl 6 style attributes
+
+=head1 SYNOPSIS
+
+  package Foo;
+  
+  use Class::MOP 'meta';
+  
+  Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
+  Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));    
+  Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));    
+  
+  sub new  {
+      my $class = shift;
+      bless $class->meta->construct_instance() => $class;
+  }
+
+=head1 DESCRIPTION
+
+This is an attribute metaclass which implements Perl 6 style 
+attributes, including the auto-generating accessors. 
+
+This code is very simple, we only need to subclass 
+C<Class::MOP::Attribute> and override C<&new>. Then we just 
+pre-process the attribute name, and create the accessor name 
+and default value based on it. 
+
+More advanced features like the C<handles> trait (see 
+L<Perl6::Bible/A12>) can be accomplished as well doing the 
+same pre-processing approach. This is left as an exercise to 
+the reader though (if you do it, please send me a patch 
+though, and will update this).
+
+=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
\ No newline at end of file
diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index a401ee5..726f54d 100644
--- 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.01';
+our $VERSION = '0.02';
 
 sub import {
     shift;
diff --git a/t/102_InsideOutClass_test.t b/t/102_InsideOutClass_test.t
index f73eef4..dd09101 100644
--- a/t/102_InsideOutClass_test.t
+++ b/t/102_InsideOutClass_test.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More no_plan => 2;
+use Test::More tests => 19;
 
 BEGIN { 
     use_ok('Class::MOP');    
@@ -16,14 +16,14 @@ BEGIN {
     sub meta { InsideOutClass->initialize($_[0]) }
     
     Foo->meta->add_attribute(
-        InsideOutAttribute->new('foo' => (
+        InsideOutClass::Attribute->new('foo' => (
             accessor  => 'foo',
             predicate => 'has_foo',
         ))
     );
     
     Foo->meta->add_attribute(
-        InsideOutAttribute->new('bar' => (
+        InsideOutClass::Attribute->new('bar' => (
             reader  => 'get_bar',
             writer  => 'set_bar',
             default => 'FOO is BAR'            
diff --git a/t/103_Perl6Attribute_test.t b/t/103_Perl6Attribute_test.t
new file mode 100644
index 0000000..6dd8976
--- /dev/null
+++ b/t/103_Perl6Attribute_test.t
@@ -0,0 +1,41 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 10;
+
+BEGIN { 
+    use_ok('Class::MOP');    
+    use_ok('examples::Perl6Attribute');
+}
+
+{
+    package Foo;
+    
+    use Class::MOP 'meta';
+    
+    Foo->meta->add_attribute(Perl6Attribute->new('$.foo'));
+    Foo->meta->add_attribute(Perl6Attribute->new('@.bar'));    
+    Foo->meta->add_attribute(Perl6Attribute->new('%.baz'));    
+    
+    sub new  {
+        my $class = shift;
+        bless $class->meta->construct_instance() => $class;
+    }        
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+can_ok($foo, 'bar');
+can_ok($foo, 'baz');
+
+is($foo->foo, undef, '... Foo.foo == undef');
+
+$foo->foo(42);
+is($foo->foo, 42, '... Foo.foo == 42');
+
+is_deeply($foo->bar, [], '... Foo.bar == []');
+is_deeply($foo->baz, {}, '... Foo.baz == {}');