Moose-2.1405HEADMoose-2.1405master

15 files changed, 1267 insertions, 0 deletions

diff --git a/t/cmop/lib/ArrayBasedStorage.pm b/t/cmop/lib/ArrayBasedStorage.pm
new file mode 100644
index 0000000..3d83a38
--- /dev/null
+++ b/t/cmop/lib/ArrayBasedStorage.pm
@@ -0,0 +1,132 @@
+package # hide the package from PAUSE
+    ArrayBasedStorage::Instance;
+
+use strict;
+use warnings;
+use Scalar::Util qw/refaddr/;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+my $unbound = \'empty-slot-value';
+
+use parent 'Class::MOP::Instance';
+
+sub new {
+    my ($class, $meta, @attrs) = @_;
+    my $self = $class->SUPER::new($meta, @attrs);
+    my $index = 0;
+    $self->{'slot_index_map'} = { map { $_ => $index++ } $self->get_all_slots };
+    return $self;
+}
+
+sub create_instance {
+    my $self = shift;
+    my $instance = bless [], $self->_class_name;
+    $self->initialize_all_slots($instance);
+    return $instance;
+}
+
+sub clone_instance {
+    my ($self, $instance) = shift;
+    $self->bless_instance_structure([ @$instance ]);
+}
+
+# operations on meta instance
+
+sub get_slot_index_map { (shift)->{'slot_index_map'} }
+
+sub initialize_slot {
+    my ($self, $instance, $slot_name) = @_;
+    $self->set_slot_value($instance, $slot_name, $unbound);
+}
+
+sub deinitialize_slot {
+    my ( $self, $instance, $slot_name ) = @_;
+    $self->set_slot_value($instance, $slot_name, $unbound);
+}
+
+sub get_all_slots {
+    my $self = shift;
+    return sort $self->SUPER::get_all_slots;
+}
+
+sub get_slot_value {
+    my ($self, $instance, $slot_name) = @_;
+    my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
+    return $value unless ref $value;
+    refaddr $value eq refaddr $unbound ? undef : $value;
+}
+
+sub set_slot_value {
+    my ($self, $instance, $slot_name, $value) = @_;
+    $instance->[ $self->{'slot_index_map'}->{$slot_name} ] = $value;
+}
+
+sub is_slot_initialized {
+    my ($self, $instance, $slot_name) = @_;
+    # NOTE: maybe use CLOS's *special-unbound-value* for this?
+    my $value = $instance->[ $self->{'slot_index_map'}->{$slot_name} ];
+    return 1 unless ref $value;
+    refaddr $value eq refaddr $unbound ? 0 : 1;
+}
+
+sub is_dependent_on_superclasses { 1 }
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ArrayBasedStorage - An example of an Array based instance storage
+
+=head1 SYNOPSIS
+
+  package Foo;
+
+  use metaclass (
+    ':instance_metaclass'  => 'ArrayBasedStorage::Instance'
+  );
+
+  __PACKAGE__->meta->add_attribute('foo' => (
+      reader => 'get_foo',
+      writer => 'set_foo'
+  ));
+
+  sub new  {
+      my $class = shift;
+      $class->meta->new_object(@_);
+  }
+
+  # now you can just use the class as normal
+
+=head1 DESCRIPTION
+
+This is a proof of concept using the Instance sub-protocol
+which uses ARRAY refs to store the instance data.
+
+This is very similar now to the InsideOutClass example, and
+in fact, they both share the exact same test suite, with
+the only difference being the Instance metaclass they use.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 SEE ALSO
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/AttributesWithHistory.pm b/t/cmop/lib/AttributesWithHistory.pm
new file mode 100644
index 0000000..4978c99
--- /dev/null
+++ b/t/cmop/lib/AttributesWithHistory.pm
@@ -0,0 +1,135 @@
+package # hide the package from PAUSE
+    AttributesWithHistory;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.05';
+
+use parent 'Class::MOP::Attribute';
+
+# this is for an extra attribute constructor
+# option, which is to be able to create a
+# way for the class to access the history
+AttributesWithHistory->meta->add_attribute('history_accessor' => (
+    reader    => 'history_accessor',
+    init_arg  => 'history_accessor',
+    predicate => 'has_history_accessor',
+));
+
+# this is a place to store the actual
+# history of the attribute
+AttributesWithHistory->meta->add_attribute('_history' => (
+    accessor => '_history',
+    default  => sub { {} },
+));
+
+sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' }
+
+AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub {
+    my ($self) = @_;
+    # and now add the history accessor
+    $self->associated_class->add_method(
+        $self->_process_accessors('history_accessor' => $self->history_accessor())
+    ) if $self->has_history_accessor();
+});
+
+package # hide the package from PAUSE
+    AttributesWithHistory::Method::Accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use parent 'Class::MOP::Method::Accessor';
+
+# generate the methods
+
+sub _generate_history_accessor_method {
+    my $attr_name = (shift)->associated_attribute->name;
+    eval qq{sub {
+        unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+            \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+        \}
+        \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\};
+    }};
+}
+
+sub _generate_accessor_method {
+    my $attr_name = (shift)->associated_attribute->name;
+    eval qq{sub {
+        if (scalar(\@_) == 2) {
+            unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+                \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+            \}
+            push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
+            \$_[0]->{'$attr_name'} = \$_[1];
+        }
+        \$_[0]->{'$attr_name'};
+    }};
+}
+
+sub _generate_writer_method {
+    my $attr_name = (shift)->associated_attribute->name;
+    eval qq{sub {
+        unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
+            \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
+        \}
+        push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
+        \$_[0]->{'$attr_name'} = \$_[1];
+    }};
+}
+
+1;
+
+=pod
+
+=head1 NAME
+
+AttributesWithHistory - An example attribute metaclass which keeps a history of changes
+
+=head1 SYSNOPSIS
+
+  package Foo;
+
+  Foo->meta->add_attribute(AttributesWithHistory->new('foo' => (
+      accessor         => 'foo',
+      history_accessor => 'get_foo_history',
+  )));
+
+  Foo->meta->add_attribute(AttributesWithHistory->new('bar' => (
+      reader           => 'get_bar',
+      writer           => 'set_bar',
+      history_accessor => 'get_bar_history',
+  )));
+
+  sub new  {
+      my $class = shift;
+      $class->meta->new_object(@_);
+  }
+
+=head1 DESCRIPTION
+
+This is an example of an attribute metaclass which keeps a
+record of all the values it has been assigned. It stores the
+history as a field in the attribute meta-object, and will
+autogenerate a means of accessing that history for the class
+which these attributes are added too.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/BinaryTree.pm b/t/cmop/lib/BinaryTree.pm
new file mode 100644
index 0000000..9a10e2c
--- /dev/null
+++ b/t/cmop/lib/BinaryTree.pm
@@ -0,0 +1,142 @@
+package BinaryTree;
+
+use strict;
+use warnings;
+use Carp qw/confess/;
+
+use metaclass;
+
+our $VERSION = '0.02';
+
+BinaryTree->meta->add_attribute('uid' => (
+    reader  => 'getUID',
+    writer  => 'setUID',
+    default => sub {
+        my $instance = shift;
+        ("$instance" =~ /\((.*?)\)$/)[0];
+    }
+));
+
+BinaryTree->meta->add_attribute('node' => (
+    reader   => 'getNodeValue',
+    writer   => 'setNodeValue',
+    clearer  => 'clearNodeValue',
+    init_arg => ':node'
+));
+
+BinaryTree->meta->add_attribute('parent' => (
+    predicate => 'hasParent',
+    reader    => 'getParent',
+    writer    => 'setParent',
+    clearer   => 'clearParent',
+));
+
+BinaryTree->meta->add_attribute('left' => (
+    predicate => 'hasLeft',
+    clearer   => 'clearLeft',
+    reader    => 'getLeft',
+    writer => {
+        'setLeft' => sub {
+            my ($self, $tree) = @_;
+            confess "undef left" unless defined $tree;
+                $tree->setParent($self) if defined $tree;
+            $self->{'left'} = $tree;
+            $self;
+        }
+   },
+));
+
+BinaryTree->meta->add_attribute('right' => (
+    predicate => 'hasRight',
+    clearer   => 'clearRight',
+    reader    => 'getRight',
+    writer => {
+        'setRight' => sub {
+            my ($self, $tree) = @_;
+            confess "undef right" unless defined $tree;
+                $tree->setParent($self) if defined $tree;
+            $self->{'right'} = $tree;
+            $self;
+        }
+    }
+));
+
+sub new {
+    my $class = shift;
+    $class->meta->new_object(':node' => shift);
+}
+
+sub removeLeft {
+    my ($self) = @_;
+    my $left = $self->getLeft();
+    $left->clearParent;
+    $self->clearLeft;
+    return $left;
+}
+
+sub removeRight {
+    my ($self) = @_;
+    my $right = $self->getRight;
+    $right->clearParent;
+    $self->clearRight;
+    return $right;
+}
+
+sub isLeaf {
+        my ($self) = @_;
+        return (!$self->hasLeft && !$self->hasRight);
+}
+
+sub isRoot {
+        my ($self) = @_;
+        return !$self->hasParent;
+}
+
+sub traverse {
+        my ($self, $func) = @_;
+    $func->($self);
+    $self->getLeft->traverse($func)  if $self->hasLeft;
+    $self->getRight->traverse($func) if $self->hasRight;
+}
+
+sub mirror {
+    my ($self) = @_;
+    # swap left for right
+    if( $self->hasLeft && $self->hasRight) {
+      my $left = $self->getLeft;
+      my $right = $self->getRight;
+      $self->setLeft($right);
+      $self->setRight($left);
+    } elsif( $self->hasLeft && !$self->hasRight){
+      my $left = $self->getLeft;
+      $self->clearLeft;
+      $self->setRight($left);
+    } elsif( !$self->hasLeft && $self->hasRight){
+      my $right = $self->getRight;
+      $self->clearRight;
+      $self->setLeft($right);
+    }
+
+    # and recurse
+    $self->getLeft->mirror  if $self->hasLeft;
+    $self->getRight->mirror if $self->hasRight;
+    $self;
+}
+
+sub size {
+    my ($self) = @_;
+    my $size = 1;
+    $size += $self->getLeft->size  if $self->hasLeft;
+    $size += $self->getRight->size if $self->hasRight;
+    return $size;
+}
+
+sub height {
+    my ($self) = @_;
+    my ($left_height, $right_height) = (0, 0);
+    $left_height = $self->getLeft->height()   if $self->hasLeft();
+    $right_height = $self->getRight->height() if $self->hasRight();
+    return 1 + (($left_height > $right_height) ? $left_height : $right_height);
+}
+
+1;
diff --git a/t/cmop/lib/C3MethodDispatchOrder.pm b/t/cmop/lib/C3MethodDispatchOrder.pm
new file mode 100644
index 0000000..c156133
--- /dev/null
+++ b/t/cmop/lib/C3MethodDispatchOrder.pm
@@ -0,0 +1,145 @@
+package # hide from PAUSE
+    C3MethodDispatchOrder;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Algorithm::C3;
+
+our $VERSION = '0.03';
+
+use parent 'Class::MOP::Class';
+
+my $_find_method = sub {
+    my ($class, $method) = @_;
+    foreach my $super ($class->class_precedence_list) {
+        return $super->meta->get_method($method)
+            if $super->meta->has_method($method);
+    }
+};
+
+C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub {
+    my $cont = shift;
+    my $meta = $cont->(@_);
+
+    # we need to look at $AUTOLOAD in the package where the coderef belongs
+    # if subname works, then it'll be where this AUTOLOAD method was installed
+    # otherwise, it'll be $C3MethodDispatchOrder::AUTOLOAD. get_code_info
+    # tells us where AUTOLOAD will look
+    my $autoload;
+    $autoload = sub {
+        my ($package) = Class::MOP::get_code_info($autoload);
+        my $label = ${ $package->meta->get_package_symbol('$AUTOLOAD') };
+        my $method_name = (split /\:\:/ => $label)[-1];
+        my $method = $_find_method->($_[0]->meta, $method_name);
+        (defined $method) || confess "Method ($method_name) not found";
+        goto &$method;
+    };
+
+    $meta->add_method('AUTOLOAD' => $autoload)
+        unless $meta->has_method('AUTOLOAD');
+
+    $meta->add_method('can' => sub {
+        $_find_method->($_[0]->meta, $_[1]);
+    }) unless $meta->has_method('can');
+
+    return $meta;
+});
+
+sub superclasses {
+    my $self = shift;
+
+    $self->add_package_symbol('@SUPERS' => [])
+        unless $self->has_package_symbol('@SUPERS');
+
+    if (@_) {
+        my @supers = @_;
+        @{$self->get_package_symbol('@SUPERS')} = @supers;
+    }
+    @{$self->get_package_symbol('@SUPERS')};
+}
+
+sub class_precedence_list {
+    my $self = shift;
+    return map {
+        $_->name;
+    } Algorithm::C3::merge($self, sub {
+        my $class = shift;
+        map { $_->meta } $class->superclasses;
+    });
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order
+
+=head1 SYNOPSIS
+
+  # a classic diamond inheritence graph
+  #
+  #    <A>
+  #   /   \
+  # <B>   <C>
+  #   \   /
+  #    <D>
+
+  package A;
+  use metaclass 'C3MethodDispatchOrder';
+
+  sub hello { return "Hello from A" }
+
+  package B;
+  use metaclass 'C3MethodDispatchOrder';
+  B->meta->superclasses('A');
+
+  package C;
+  use metaclass 'C3MethodDispatchOrder';
+  C->meta->superclasses('A');
+
+  sub hello { return "Hello from C" }
+
+  package D;
+  use metaclass 'C3MethodDispatchOrder';
+  D->meta->superclasses('B', 'C');
+
+  print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A
+
+  # later in other code ...
+
+  print D->hello; # print 'Hello from C' instead of the normal 'Hello from A'
+
+=head1 DESCRIPTION
+
+This is an example of how you could change the method dispatch order of a
+class using L<Class::MOP>. Using the L<Algorithm::C3> module, this repleces
+the normal depth-first left-to-right perl dispatch order with the C3 method
+dispatch order (see the L<Algorithm::C3> or L<Class::C3> docs for more
+information about this).
+
+This example could be used as a template for other method dispatch orders
+as well, all that is required is to write a the C<class_precedence_list> method
+which will return a linearized list of classes to dispatch along.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/ClassEncapsulatedAttributes.pm b/t/cmop/lib/ClassEncapsulatedAttributes.pm
new file mode 100644
index 0000000..5fb3a24
--- /dev/null
+++ b/t/cmop/lib/ClassEncapsulatedAttributes.pm
@@ -0,0 +1,150 @@
+package # hide the package from PAUSE
+    ClassEncapsulatedAttributes;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.06';
+
+use parent 'Class::MOP::Class';
+
+sub initialize {
+    (shift)->SUPER::initialize(@_,
+        # use the custom attribute metaclass here
+        'attribute_metaclass' => 'ClassEncapsulatedAttributes::Attribute',
+    );
+}
+
+sub construct_instance {
+    my ($class, %params) = @_;
+
+    my $meta_instance = $class->get_meta_instance;
+    my $instance = $meta_instance->create_instance();
+
+    # initialize *ALL* attributes, including masked ones (as opposed to applicable)
+    foreach my $current_class ($class->class_precedence_list()) {
+        my $meta = $current_class->meta;
+        foreach my $attr_name ($meta->get_attribute_list()) {
+            my $attr = $meta->get_attribute($attr_name);
+            $attr->initialize_instance_slot($meta_instance, $instance, \%params);
+        }
+    }
+
+    return $instance;
+}
+
+package # hide the package from PAUSE
+    ClassEncapsulatedAttributes::Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.04';
+
+use parent 'Class::MOP::Attribute';
+
+# alter the way parameters are specified
+sub initialize_instance_slot {
+    my ($self, $meta_instance, $instance, $params) = @_;
+    # if the attr has an init_arg, use that, otherwise,
+    # use the attributes name itself as the init_arg
+    my $init_arg = $self->init_arg();
+    # try to fetch the init arg from the %params ...
+    my $class = $self->associated_class;
+    my $val;
+    $val = $params->{$class->name}->{$init_arg}
+        if exists $params->{$class->name} &&
+           exists ${$params->{$class->name}}{$init_arg};
+    # if nothing was in the %params, we can use the
+    # attribute's default value (if it has one)
+    if (!defined $val && $self->has_default) {
+        $val = $self->default($instance);
+    }
+
+    # now add this to the instance structure
+    $meta_instance->set_slot_value($instance, $self->name, $val);
+}
+
+sub name {
+    my $self = shift;
+    return ($self->associated_class->name . '::' . $self->SUPER::name)
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+ClassEncapsulatedAttributes - A set of example metaclasses with class encapsulated attributes
+
+=head1 SYNOPSIS
+
+  package Foo;
+
+  use metaclass 'ClassEncapsulatedAttributes';
+
+  Foo->meta->add_attribute('foo' => (
+      accessor  => 'Foo_foo',
+      default   => 'init in FOO'
+  ));
+
+  sub new  {
+      my $class = shift;
+      $class->meta->new_object(@_);
+  }
+
+  package Bar;
+  our @ISA = ('Foo');
+
+  # duplicate the attribute name here
+  Bar->meta->add_attribute('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
+
+This is an example metaclass which encapsulates a class's
+attributes on a per-class basis. This means that there is no
+possibility of name clashes with inherited attributes. This
+is similar to how C++ handles its data members.
+
+=head1 ACKNOWLEDGEMENTS
+
+Thanks to Yuval "nothingmuch" Kogman for the idea for this example.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/InsideOutClass.pm b/t/cmop/lib/InsideOutClass.pm
new file mode 100644
index 0000000..94ec0c5
--- /dev/null
+++ b/t/cmop/lib/InsideOutClass.pm
@@ -0,0 +1,194 @@
+package # hide the package from PAUSE
+    InsideOutClass::Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+use Carp         'confess';
+use Scalar::Util 'refaddr';
+
+use parent 'Class::MOP::Attribute';
+
+sub initialize_instance_slot {
+    my ($self, $meta_instance, $instance, $params) = @_;
+    my $init_arg = $self->init_arg;
+    # try to fetch the init arg from the %params ...
+    my $val;
+    $val = $params->{$init_arg} if exists $params->{$init_arg};
+    # if nothing was in the %params, we can use the
+    # attribute's default value (if it has one)
+    if (!defined $val && defined $self->default) {
+        $val = $self->default($instance);
+    }
+    my $_meta_instance = $self->associated_class->get_meta_instance;
+    $_meta_instance->initialize_slot($instance, $self->name);
+    $_meta_instance->set_slot_value($instance, $self->name, $val);
+}
+
+sub accessor_metaclass { 'InsideOutClass::Method::Accessor' }
+
+package # hide the package from PAUSE
+    InsideOutClass::Method::Accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Carp         'confess';
+use Scalar::Util 'refaddr';
+
+use parent 'Class::MOP::Method::Accessor';
+
+## Method generation helpers
+
+sub _generate_accessor_method {
+    my $attr       = (shift)->associated_attribute;
+    my $meta_class = $attr->associated_class;
+    my $attr_name  = $attr->name;
+    return sub {
+        my $meta_instance = $meta_class->get_meta_instance;
+        $meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
+        $meta_instance->get_slot_value($_[0], $attr_name);
+    };
+}
+
+sub _generate_reader_method {
+    my $attr       = (shift)->associated_attribute;
+    my $meta_class = $attr->associated_class;
+    my $attr_name  = $attr->name;
+    return sub {
+        confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+        $meta_class->get_meta_instance
+                   ->get_slot_value($_[0], $attr_name);
+    };
+}
+
+sub _generate_writer_method {
+    my $attr       = (shift)->associated_attribute;
+    my $meta_class = $attr->associated_class;
+    my $attr_name  = $attr->name;
+    return sub {
+        $meta_class->get_meta_instance
+                   ->set_slot_value($_[0], $attr_name, $_[1]);
+    };
+}
+
+sub _generate_predicate_method {
+    my $attr       = (shift)->associated_attribute;
+    my $meta_class = $attr->associated_class;
+    my $attr_name  = $attr->name;
+    return sub {
+        defined $meta_class->get_meta_instance
+                           ->get_slot_value($_[0], $attr_name) ? 1 : 0;
+    };
+}
+
+package # hide the package from PAUSE
+    InsideOutClass::Instance;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Carp         'confess';
+use Scalar::Util 'refaddr';
+
+use parent 'Class::MOP::Instance';
+
+sub create_instance {
+    my ($self, $class) = @_;
+        bless \(my $instance), $self->_class_name;
+}
+
+sub get_slot_value {
+    my ($self, $instance, $slot_name) = @_;
+    $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance};
+}
+
+sub set_slot_value {
+    my ($self, $instance, $slot_name, $value) = @_;
+    $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = $value;
+}
+
+sub initialize_slot {
+    my ($self, $instance, $slot_name) = @_;
+    $self->associated_metaclass->add_package_symbol(('%' . $slot_name) => {})
+        unless $self->associated_metaclass->has_package_symbol('%' . $slot_name);
+    $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} = undef;
+}
+
+sub is_slot_initialized {
+    my ($self, $instance, $slot_name) = @_;
+    return 0 unless $self->associated_metaclass->has_package_symbol('%' . $slot_name);
+    return exists $self->associated_metaclass->get_package_symbol('%' . $slot_name)->{refaddr $instance} ? 1 : 0;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InsideOutClass - A set of example metaclasses which implement the Inside-Out technique
+
+=head1 SYNOPSIS
+
+  package Foo;
+
+  use metaclass (
+    ':attribute_metaclass' => 'InsideOutClass::Attribute',
+    ':instance_metaclass'  => 'InsideOutClass::Instance'
+  );
+
+  __PACKAGE__->meta->add_attribute('foo' => (
+      reader => 'get_foo',
+      writer => 'set_foo'
+  ));
+
+  sub new  {
+      my $class = shift;
+      $class->meta->new_object(@_);
+  }
+
+  # 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.
+
+We must create a subclass of B<Class::MOP::Instance> and override
+the slot operations. This requires
+overloading C<get_slot_value>, C<set_slot_value>, C<slot_initialized>, and
+C<initialize_slot>, as well as their inline counterparts. Additionally we
+overload C<add_slot> in order to initialize the global hash containing the
+actual slot values.
+
+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 (threading, etc), but this is an example. A real implementation is left as
+an exercise to the reader.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/InstanceCountingClass.pm b/t/cmop/lib/InstanceCountingClass.pm
new file mode 100644
index 0000000..35053fe
--- /dev/null
+++ b/t/cmop/lib/InstanceCountingClass.pm
@@ -0,0 +1,72 @@
+package # hide the package from PAUSE
+    InstanceCountingClass;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.03';
+
+use parent 'Class::MOP::Class';
+
+InstanceCountingClass->meta->add_attribute('count' => (
+    reader  => 'get_count',
+    default => 0
+));
+
+InstanceCountingClass->meta->add_before_method_modifier('_construct_instance' => sub {
+    my ($class) = @_;
+    $class->{'count'}++;
+});
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+InstanceCountingClass - An example metaclass which counts instances
+
+=head1 SYNOPSIS
+
+  package Foo;
+
+  use metaclass 'InstanceCountingClass';
+
+  sub new  {
+      my $class = shift;
+      $class->meta->new_object(@_);
+  }
+
+  # ... 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 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/LazyClass.pm b/t/cmop/lib/LazyClass.pm
new file mode 100644
index 0000000..1a2dc13
--- /dev/null
+++ b/t/cmop/lib/LazyClass.pm
@@ -0,0 +1,162 @@
+package # hide the package from PAUSE
+    LazyClass::Attribute;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.05';
+
+use parent 'Class::MOP::Attribute';
+
+sub initialize_instance_slot {
+    my ($self, $meta_instance, $instance, $params) = @_;
+
+    # if the attr has an init_arg, use that, otherwise,
+    # use the attributes name itself as the init_arg
+    my $init_arg = $self->init_arg();
+
+    if ( exists $params->{$init_arg} ) {
+        my $val = $params->{$init_arg};
+        $meta_instance->set_slot_value($instance, $self->name, $val);
+    }
+}
+
+sub accessor_metaclass { 'LazyClass::Method::Accessor' }
+
+package # hide the package from PAUSE
+    LazyClass::Method::Accessor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+
+use parent 'Class::MOP::Method::Accessor';
+
+sub _generate_accessor_method {
+    my $attr = (shift)->associated_attribute;
+
+    my $attr_name = $attr->name;
+    my $meta_instance = $attr->associated_class->get_meta_instance;
+
+    sub {
+        if (scalar(@_) == 2) {
+            $meta_instance->set_slot_value($_[0], $attr_name, $_[1]);
+        }
+        else {
+            unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
+                my $value = $attr->has_default ? $attr->default($_[0]) : undef;
+                $meta_instance->set_slot_value($_[0], $attr_name, $value);
+            }
+
+            $meta_instance->get_slot_value($_[0], $attr_name);
+        }
+    };
+}
+
+sub _generate_reader_method {
+    my $attr = (shift)->associated_attribute;
+
+    my $attr_name = $attr->name;
+    my $meta_instance = $attr->associated_class->get_meta_instance;
+
+    sub {
+        confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+
+        unless ( $meta_instance->is_slot_initialized($_[0], $attr_name) ) {
+            my $value = $attr->has_default ? $attr->default($_[0]) : undef;
+            $meta_instance->set_slot_value($_[0], $attr_name, $value);
+        }
+
+        $meta_instance->get_slot_value($_[0], $attr_name);
+    };
+}
+
+package # hide the package from PAUSE
+    LazyClass::Instance;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use parent 'Class::MOP::Instance';
+
+sub initialize_all_slots {}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+LazyClass - An example metaclass with lazy initialization
+
+=head1 SYNOPSIS
+
+  package BinaryTree;
+
+  use metaclass (
+      ':attribute_metaclass' => 'LazyClass::Attribute',
+      ':instance_metaclass'  => 'LazyClass::Instance',
+  );
+
+  BinaryTree->meta->add_attribute('node' => (
+      accessor => 'node',
+      init_arg => ':node'
+  ));
+
+  BinaryTree->meta->add_attribute('left' => (
+      reader  => 'left',
+      default => sub { BinaryTree->new() }
+  ));
+
+  BinaryTree->meta->add_attribute('right' => (
+      reader  => 'right',
+      default => sub { BinaryTree->new() }
+  ));
+
+  sub new  {
+      my $class = shift;
+      $class->meta->new_object(@_);
+  }
+
+  # ... later in code
+
+  my $btree = BinaryTree->new();
+  # ... $btree is an empty hash, no keys are initialized yet
+
+=head1 DESCRIPTION
+
+This is an example metclass in which all attributes are created
+lazily. This means that no entries are made in the instance HASH
+until the last possible moment.
+
+The example above of a binary tree is a good use for such a
+metaclass because it allows the class to be space efficient
+without complicating the programing of it. This would also be
+ideal for a class which has a large amount of attributes,
+several of which are optional.
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/MyMetaClass.pm b/t/cmop/lib/MyMetaClass.pm
new file mode 100644
index 0000000..ade02e5
--- /dev/null
+++ b/t/cmop/lib/MyMetaClass.pm
@@ -0,0 +1,14 @@
+package MyMetaClass;
+
+use strict;
+use warnings;
+
+use parent 'Class::MOP::Class';
+
+sub mymetaclass_attributes{
+  my $self = shift;
+  return grep { $_->isa("MyMetaClass::Attribute") }
+    $self->get_all_attributes;
+}
+
+1;
diff --git a/t/cmop/lib/MyMetaClass/Attribute.pm b/t/cmop/lib/MyMetaClass/Attribute.pm
new file mode 100644
index 0000000..c187e9a
--- /dev/null
+++ b/t/cmop/lib/MyMetaClass/Attribute.pm
@@ -0,0 +1,8 @@
+package MyMetaClass::Attribute;
+
+use strict;
+use warnings;
+
+use parent 'Class::MOP::Attribute';
+
+1;
diff --git a/t/cmop/lib/MyMetaClass/Instance.pm b/t/cmop/lib/MyMetaClass/Instance.pm
new file mode 100644
index 0000000..5383c4a
--- /dev/null
+++ b/t/cmop/lib/MyMetaClass/Instance.pm
@@ -0,0 +1,8 @@
+package MyMetaClass::Instance;
+
+use strict;
+use warnings;
+
+use parent 'Class::MOP::Instance';
+
+1;
diff --git a/t/cmop/lib/MyMetaClass/Method.pm b/t/cmop/lib/MyMetaClass/Method.pm
new file mode 100644
index 0000000..072d49d
--- /dev/null
+++ b/t/cmop/lib/MyMetaClass/Method.pm
@@ -0,0 +1,8 @@
+package MyMetaClass::Method;
+
+use strict;
+use warnings;
+
+use parent 'Class::MOP::Method';
+
+1;
diff --git a/t/cmop/lib/MyMetaClass/Random.pm b/t/cmop/lib/MyMetaClass/Random.pm
new file mode 100644
index 0000000..1c79b7b
--- /dev/null
+++ b/t/cmop/lib/MyMetaClass/Random.pm
@@ -0,0 +1,6 @@
+package MyMetaClass::Random;
+
+use strict;
+use warnings;
+
+1;
diff --git a/t/cmop/lib/Perl6Attribute.pm b/t/cmop/lib/Perl6Attribute.pm
new file mode 100644
index 0000000..420ef30
--- /dev/null
+++ b/t/cmop/lib/Perl6Attribute.pm
@@ -0,0 +1,82 @@
+package # hide the package from PAUSE
+    Perl6Attribute;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.02';
+
+use parent 'Class::MOP::Attribute';
+
+Perl6Attribute->meta->add_around_method_modifier('new' => sub {
+    my $cont = shift;
+    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 '%');
+
+    $cont->($class, $attribute_name, %options);
+});
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Perl6Attribute - An example attribute metaclass for Perl 6 style attributes
+
+=head1 SYNOPSIS
+
+  package Foo;
+
+  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;
+      $class->meta->new_object(@_);
+  }
+
+=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 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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/t/cmop/lib/SyntaxError.pm b/t/cmop/lib/SyntaxError.pm
new file mode 100644
index 0000000..ab41f14
--- /dev/null
+++ b/t/cmop/lib/SyntaxError.pm
@@ -0,0 +1,9 @@
+package SyntaxError;
+use strict;
+use warnings;
+
+# this syntax error is intentional!
+
+    {
+
+1;