From: gfx <gfuji@cpan.org>
Date: Tue, 22 Sep 2009 07:40:47 +0000 (+0900)
Subject: Add various things
X-Git-Tag: 0.32~7
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=7a50b45027c9f7baad76cfce7f78c822bd38f0a7;hp=60b5c3be4d0b3bb705df1e8d977f2ce90db6668d

Add various things
---

diff --git a/Changes b/Changes
index 52cb806..cf609ef 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,8 @@
 Revision history for Mouse
 
+0.32
+
+
 0.31 Tue Sep 22 11:08:12 2009
 
     * Add find_meta() and does_role() to Mouse::Util (gfx)
diff --git a/lib/Mouse.pm b/lib/Mouse.pm
index 1c76f7c..6948ce5 100644
--- a/lib/Mouse.pm
+++ b/lib/Mouse.pm
@@ -15,6 +15,7 @@ use Mouse::Util qw(load_class is_class_loaded);
 use Mouse::Meta::Attribute;
 use Mouse::Meta::Module;
 use Mouse::Meta::Class;
+use Mouse::Meta::Role;
 use Mouse::Object;
 use Mouse::Util::TypeConstraints;
 
diff --git a/lib/Mouse/Meta/Class.pm b/lib/Mouse/Meta/Class.pm
index 2689f85..7084439 100644
--- a/lib/Mouse/Meta/Class.pm
+++ b/lib/Mouse/Meta/Class.pm
@@ -23,7 +23,19 @@ sub _new {
         \@{ $args{package} . '::ISA' };
     };
 
-    bless \%args, $class;
+    #return Mouse::Meta::Class->initialize($class)->new_object(%args)
+    #    if $class ne __PACKAGE__;
+
+    return bless \%args, $class;
+}
+
+sub create_anon_class{
+    my $self = shift;
+    return $self->create(undef, @_);
+}
+
+sub is_anon_class{
+    return exists $_[0]->{anon_serial_id};
 }
 
 sub roles { $_[0]->{roles} }
@@ -53,11 +65,12 @@ sub add_attribute {
     if (@_ == 1 && blessed($_[0])) {
         my $attr = shift @_;
         $self->{'attributes'}{$attr->name} = $attr;
-    } else {
+    }
+    else {
         my $names = shift @_;
         $names = [$names] if !ref($names);
         my $metaclass = 'Mouse::Meta::Attribute';
-        my %options = @_;
+        my %options   = (@_ == 1 ? %{$_[0]} : @_);
 
         if ( my $metaclass_name = delete $options{metaclass} ) {
             my $new_class = Mouse::Util::resolve_metaclass_alias(
@@ -71,10 +84,10 @@ sub add_attribute {
 
         for my $name (@$names) {
             if ($name =~ s/^\+//) {
-                $metaclass->clone_parent($self, $name, @_);
+                $metaclass->clone_parent($self, $name, %options);
             }
             else {
-                $metaclass->create($self, $name, @_);
+                $metaclass->create($self, $name, %options);
             }
         }
     }
@@ -102,7 +115,7 @@ sub linearized_isa { @{ get_linear_isa($_[0]->name) } }
 
 sub new_object {
     my $self = shift;
-    my $args = (@_ == 1) ? $_[0] : { @_ };
+    my %args = (@_ == 1 ? %{$_[0]} : @_);
 
     my $instance = bless {}, $self->name;
 
@@ -110,18 +123,18 @@ sub new_object {
         my $from = $attribute->init_arg;
         my $key  = $attribute->name;
 
-        if (defined($from) && exists($args->{$from})) {
-            $args->{$from} = $attribute->coerce_constraint($args->{$from})
+        if (defined($from) && exists($args{$from})) {
+            $args{$from} = $attribute->coerce_constraint($args{$from})
                 if $attribute->should_coerce;
-            $attribute->verify_against_type_constraint($args->{$from});
+            $attribute->verify_against_type_constraint($args{$from});
 
-            $instance->{$key} = $args->{$from};
+            $instance->{$key} = $args{$from};
 
             weaken($instance->{$key})
                 if ref($instance->{$key}) && $attribute->is_weak_ref;
 
             if ($attribute->has_trigger) {
-                $attribute->trigger->($instance, $args->{$from});
+                $attribute->trigger->($instance, $args{$from});
             }
         }
         else {
@@ -293,133 +306,6 @@ sub does_role {
     return 0;
 }
 
-sub create {
-    my ($class, $package_name, %options) = @_;
-
-    (ref $options{superclasses} eq 'ARRAY')
-        || $class->throw_error("You must pass an ARRAY ref of superclasses")
-            if exists $options{superclasses};
-
-    (ref $options{attributes} eq 'ARRAY')
-        || $class->throw_error("You must pass an ARRAY ref of attributes")
-            if exists $options{attributes};
-
-    (ref $options{methods} eq 'HASH')
-        || $class->throw_error("You must pass a HASH ref of methods")
-            if exists $options{methods};
-
-    (ref $options{roles} eq 'ARRAY')
-        || $class->throw_error("You must pass an ARRAY ref of roles")
-            if exists $options{roles};
-
-    # instantiate a module
-    {
-        ( defined $package_name && $package_name )
-          || $class->throw_error("You must pass a package name");
-
-        no strict 'refs';
-        ${ $package_name . '::VERSION'   } = $options{version}   if exists $options{version};
-        ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority};
-    }
-
-    my %initialize_options = %options;
-    delete @initialize_options{qw(
-        package
-        superclasses
-        attributes
-        methods
-        roles
-        version
-        authority
-    )};
-    my $meta = $class->initialize( $package_name => %initialize_options );
-
-    # FIXME totally lame
-    $meta->add_method('meta' => sub {
-        Mouse::Meta::Class->initialize(ref($_[0]) || $_[0]);
-    });
-
-    $meta->superclasses(@{$options{superclasses}})
-        if exists $options{superclasses};
-
-    # NOTE:
-    # process attributes first, so that they can
-    # install accessors, but locally defined methods
-    # can then overwrite them. It is maybe a little odd, but
-    # I think this should be the order of things.
-    if (exists $options{attributes}) {
-        foreach my $attr (@{$options{attributes}}) {
-            Mouse::Meta::Attribute->create($meta, $attr->{name}, %$attr);
-        }
-    }
-    if (exists $options{methods}) {
-        foreach my $method_name (keys %{$options{methods}}) {
-            $meta->add_method($method_name, $options{methods}->{$method_name});
-        }
-    }
-    if (exists $options{roles}){
-        Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
-    }
-    return $meta;
-}
-
-{
-    my $ANON_CLASS_SERIAL = 0;
-    my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::';
-
-    my %IMMORTAL_ANON_CLASSES;
-    sub create_anon_class {
-        my ( $class, %options ) = @_;
-
-        my $cache = $options{cache};
-        my $cache_key;
-
-        if($cache){ # anonymous but not mortal
-                # something like Super::Class|Super::Class::2=Role|Role::1
-                $cache_key = join '=' => (
-                    join('|', @{$options{superclasses} || []}),
-                    join('|', sort @{$options{roles}   || []}),
-                );
-                return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key};
-        }
-        my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
-        my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options );
-
-        if($cache){
-            $IMMORTAL_ANON_CLASSES{$cache_key} = $meta;
-        }
-        else{
-            Mouse::Meta::Module::weaken_metaclass($package_name);
-        }
-        return $meta;
-    }
-
-    sub is_anon_class{
-        return exists $_[0]->{anon_class_id};
-    }
-
-
-    sub DESTROY{
-        my($self) = @_;
-
-        my $serial_id = $self->{anon_class_id};
-
-        return if !$serial_id;
-
-        my $stash = $self->namespace;
-
-        @{$self->{sperclasses}} = ();
-        %{$stash} = ();
-        Mouse::Meta::Module::remove_metaclass_by_name($self->name);
-
-        no strict 'refs';
-        delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' };
-
-        return;
-    }
-
-}
-
 1;
 
 __END__
diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm
index 091b8ef..74a8468 100755
--- a/lib/Mouse/Meta/Module.pm
+++ b/lib/Mouse/Meta/Module.pm
@@ -5,7 +5,6 @@ use warnings;
 use Mouse::Util qw/get_code_info not_supported load_class/;
 use Scalar::Util qw/blessed weaken/;
 
-
 {
     my %METACLASS_CACHE;
 
@@ -137,6 +136,146 @@ sub get_method_list {
     return grep { $self->has_method($_) } keys %{ $self->namespace };
 }
 
+{
+    my $ANON_SERIAL = 0;
+    my $ANON_PREFIX = 'Mouse::Meta::Module::__ANON__::';
+
+    my %IMMORTALS;
+
+    sub create {
+        my ($class, $package_name, %options) = @_;
+
+        $class->throw_error('You must pass a package name') if @_ == 1;
+
+
+        if(exists $options{superclasses}){
+            if($class->isa('Mouse::Meta::Class')){
+                (ref $options{superclasses} eq 'ARRAY')
+                    || $class->throw_error("You must pass an ARRAY ref of superclasses");
+            }
+            else{ # role
+                delete $options{superclasses};
+            }
+        }
+
+        my $attributes;
+        if(exists $options{attributes}){
+            $attributes = delete $options{attributes};
+           (ref $attributes eq 'ARRAY' || ref $attributes eq 'HASH')
+               || $class->throw_error("You must pass an ARRAY ref of attributes")
+           }
+
+        (ref $options{methods} eq 'HASH')
+            || $class->throw_error("You must pass a HASH ref of methods")
+                if exists $options{methods};
+
+        (ref $options{roles} eq 'ARRAY')
+            || $class->throw_error("You must pass an ARRAY ref of roles")
+                if exists $options{roles};
+
+
+        my @extra_options;
+        my $mortal;
+        my $cache_key;
+
+        if(!defined $package_name){ # anonymous
+            $mortal = !$options{cache};
+
+            # anonymous but immortal
+            if(!$mortal){
+                    # something like Super::Class|Super::Class::2=Role|Role::1
+                    $cache_key = join '=' => (
+                        join('|',      @{$options{superclasses} || []}),
+                        join('|', sort @{$options{roles}        || []}),
+                    );
+                    return $IMMORTALS{$cache_key} if exists $IMMORTALS{$cache_key};
+            }
+            $package_name = $ANON_PREFIX . ++$ANON_SERIAL;
+
+            push @extra_options, (anon_serial_id => $ANON_SERIAL);
+        }
+
+        # instantiate a module
+        {
+            no strict 'refs';
+            ${ $package_name . '::VERSION'   } = delete $options{version}   if exists $options{version};
+            ${ $package_name . '::AUTHORITY' } = delete $options{authority} if exists $options{authority};
+        }
+
+        my %initialize_options = %options;
+        delete @initialize_options{qw(
+            package
+            superclasses
+            attributes
+            methods
+            roles
+        )};
+        my $meta = $class->initialize( $package_name, %initialize_options, @extra_options);
+
+        Mouse::Meta::Module::weaken_metaclass($package_name)
+            if $mortal;
+
+        # FIXME totally lame
+        $meta->add_method('meta' => sub {
+            $class->initialize(ref($_[0]) || $_[0]);
+        });
+
+        $meta->superclasses(@{$options{superclasses}})
+            if exists $options{superclasses};
+
+        # NOTE:
+        # process attributes first, so that they can
+        # install accessors, but locally defined methods
+        # can then overwrite them. It is maybe a little odd, but
+        # I think this should be the order of things.
+        if (defined $attributes) {
+            if(ref($attributes) eq 'ARRAY'){
+                foreach my $attr (@{$attributes}) {
+                    $meta->add_attribute($attr->{name} => $attr);
+                }
+            }
+            else{
+                while(my($name, $attr) = each %{$attributes}){
+                    $meta->add_attribute($name => $attr);
+                }
+            }
+        }
+        if (exists $options{methods}) {
+            foreach my $method_name (keys %{$options{methods}}) {
+                $meta->add_method($method_name, $options{methods}->{$method_name});
+            }
+        }
+        if (exists $options{roles}){
+            Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
+        }
+
+        if(!$mortal && exists $meta->{anon_serial_id}){
+            $IMMORTALS{$cache_key} = $meta;
+        }
+
+        return $meta;
+    }
+
+    sub DESTROY{
+        my($self) = @_;
+
+        my $serial_id = $self->{anon_serial_id};
+
+        return if !$serial_id;
+
+        my $stash = $self->namespace;
+
+        @{$self->{superclasses}} = () if exists $self->{superclasses};
+        %{$stash} = ();
+        Mouse::Meta::Module::remove_metaclass_by_name($self->name);
+
+        no strict 'refs';
+        delete ${$ANON_PREFIX}{ $serial_id . '::' };
+
+        return;
+    }
+}
+
 sub throw_error{
     my($class, $message, %args) = @_;
 
diff --git a/lib/Mouse/Meta/Role.pm b/lib/Mouse/Meta/Role.pm
index 33b8426..48e1b81 100644
--- a/lib/Mouse/Meta/Role.pm
+++ b/lib/Mouse/Meta/Role.pm
@@ -9,6 +9,7 @@ sub method_metaclass(){ 'Mouse::Meta::Role::Method' } # required for get_method(
 
 sub _new {
     my $class = shift;
+
     my %args  = @_;
 
     $args{methods}          ||= {};
@@ -16,7 +17,19 @@ sub _new {
     $args{required_methods} ||= [];
     $args{roles}            ||= [];
 
-    bless \%args, $class;
+#    return Mouse::Meta::Class->initialize($class)->new_object(%args)
+#        if $class ne __PACKAGE__;
+
+    return bless \%args, $class;
+}
+
+sub create_anon_role{
+    my $self = shift;
+    return $self->create(undef, @_);
+}
+
+sub is_anon_role{
+    return exists $_[0]->{anon_serial_id};
 }
 
 sub get_roles { $_[0]->{roles} }
@@ -43,14 +56,50 @@ sub add_attribute {
     $self->{attributes}->{$name} = (@_ == 1) ? $_[0] : { @_ };
 }
 
+sub _canonicalize_apply_args{
+    my($self, $applicant, %args) = @_;
+
+    if($applicant->isa('Mouse::Meta::Class')){
+        $args{_to} = 'class';
+    }
+    elsif($applicant->isa('Mouse::Meta::Role')){
+        $args{_to} = 'role';
+    }
+    else{
+        $args{_to} = 'instance';
+
+        not_supported 'Application::ToInstance';
+    }
+
+    if($args{alias} && !exists $args{-alias}){
+        $args{-alias} = $args{alias};
+    }
+    if($args{excludes} && !exists $args{-excludes}){
+        $args{-excludes} = $args{excludes};
+    }
+
+    if(my $excludes = $args{-excludes}){
+        $args{-excludes} = {}; # replace with a hash ref
+        if(ref $excludes){
+            %{$args{-excludes}} = (map{ $_ => undef } @{$excludes});
+        }
+        else{
+            $args{-excludes}{$excludes} = undef;
+        }
+    }
+
+    return \%args;
+}
+
 sub _check_required_methods{
     my($role, $class, $args, @other_roles) = @_;
 
-    if($class->isa('Mouse::Meta::Class')){
+    if($args->{_to} eq 'class'){
         my $class_name = $class->name;
+        my $role_name  = $role->name;
+        my @missing;
         foreach my $method_name(@{$role->{required_methods}}){
-            unless($class_name->can($method_name)){
-                my $role_name       = $role->name;
+            if(!$class_name->can($method_name)){
                 my $has_method      = 0;
 
                 foreach my $another_role_spec(@other_roles){
@@ -60,11 +109,24 @@ sub _check_required_methods{
                         last;
                     }
                 }
-                
-                $role->throw_error("'$role_name' requires the method '$method_name' to be implemented by '$class_name'")
-                    unless $has_method;
+
+                push @missing, $method_name if !$has_method;
             }
         }
+        if(@missing){
+            $class->throw_error("'$role_name' requires the "
+                . (@missing == 1 ? 'method' : 'methods')
+                . " "
+                . english_list(map{ sprintf q{'%s'}, $_ } @missing)
+                . " to be implemented by '$class_name'");
+        }
+    }
+    elsif($args->{_to} eq 'role'){
+        # apply role($role) to role($class)
+        foreach my $method_name($role->get_required_method_list){
+            next if $class->has_method($method_name); # already has it
+            $class->add_required_methods($method_name);
+        }
     }
 
     return;
@@ -76,26 +138,15 @@ sub _apply_methods{
     my $role_name  = $role->name;
     my $class_name = $class->name;
 
-    my $alias    = (exists $args->{alias}    && !exists $args->{-alias})    ? $args->{alias}    : $args->{-alias};
-    my $excludes = (exists $args->{excludes} && !exists $args->{-excludes}) ? $args->{excludes} : $args->{-excludes};
-
-    my %exclude_map;
-
-    if(defined $excludes){
-        if(ref $excludes){
-            %exclude_map = map{ $_ => undef } @{$excludes};
-        }
-        else{
-            $exclude_map{$excludes} = undef;
-        }
-    }
+    my $alias    = $args->{-alias};
+    my $excludes = $args->{-excludes};
 
     foreach my $method_name($role->get_method_list){
         next if $method_name eq 'meta';
 
         my $code = $role_name->can($method_name);
 
-        if(!exists $exclude_map{$method_name}){
+        if(!exists $excludes->{$method_name}){
             if(!$class->has_method($method_name)){
                 $class->add_method($method_name => $code);
             }
@@ -104,8 +155,9 @@ sub _apply_methods{
         if($alias && $alias->{$method_name}){
             my $dstname = $alias->{$method_name};
 
-            my $slot = do{ no strict 'refs'; \*{$class_name . '::' . $dstname} };
-            if(defined(*{$slot}{CODE}) && *{$slot}{CODE} != $code){
+            my $dstcode = do{ no strict 'refs'; *{$class_name . '::' . $dstname}{CODE} };
+
+            if(defined($dstcode) && $dstcode != $code){
                 $class->throw_error("Cannot create a method alias if a local method of the same name exists");
             }
             else{
@@ -120,7 +172,7 @@ sub _apply_methods{
 sub _apply_attributes{
     my($role, $class, $args) = @_;
 
-    if ($class->isa('Mouse::Meta::Class')) {
+    if ($args->{_to} eq 'class') {
         # apply role to class
         for my $attr_name ($role->get_attribute_list) {
             next if $class->has_attribute($attr_name);
@@ -137,7 +189,8 @@ sub _apply_attributes{
 
             $attr_metaclass->create($class, $attr_name => %$spec);
         }
-    } else {
+    }
+    elsif($args->{_to} eq 'role'){
         # apply role to role
         for my $attr_name ($role->get_attribute_list) {
             next if $class->has_attribute($attr_name);
@@ -153,7 +206,7 @@ sub _apply_attributes{
 sub _apply_modifiers{
     my($role, $class, $args) = @_;
 
-    for my $modifier_type (qw/before after around override/) {
+    for my $modifier_type (qw/override before around after/) {
         my $add_modifier = "add_${modifier_type}_method_modifier";
         my $modifiers    = $role->{"${modifier_type}_method_modifiers"};
 
@@ -169,7 +222,7 @@ sub _apply_modifiers{
 sub _append_roles{
     my($role, $class, $args) = @_;
 
-    my $roles = $class->isa('Mouse::Meta::Class') ? $class->roles : $class->get_roles;
+    my $roles = ($args->{_to} eq 'class') ? $class->roles : $class->get_roles;
 
     foreach my $r($role, @{$role->get_roles}){
         if(!$class->does_role($r->name)){
@@ -181,23 +234,26 @@ sub _append_roles{
 
 # Moose uses Application::ToInstance, Application::ToClass, Application::ToRole
 sub apply {
-    my($self, $class, %args) = @_;
+    my $self      = shift;
+    my $applicant = shift;
 
-    if ($class->isa('Mouse::Object')) {
-        not_supported 'Application::ToInstance';
-    }
+    my $args = $self->_canonicalize_apply_args($applicant, @_);
 
-    $self->_check_required_methods($class, \%args);
-    $self->_apply_methods($class, \%args);
-    $self->_apply_attributes($class, \%args);
-    $self->_apply_modifiers($class, \%args);
-    $self->_append_roles($class, \%args);
+    $self->_check_required_methods($applicant, $args);
+    $self->_apply_methods($applicant, $args);
+    $self->_apply_attributes($applicant, $args);
+    $self->_apply_modifiers($applicant, $args);
+    $self->_append_roles($applicant, $args);
     return;
 }
 
 sub combine_apply {
     my(undef, $class, @roles) = @_;
 
+    if($class->isa('Mouse::Object')){
+        not_supported 'Application::ToInstance';
+    }
+
     # check conflicting
     my %method_provided;
     my @method_conflicts;
@@ -282,6 +338,8 @@ sub combine_apply {
 
         my $role = $role_name->meta;
 
+        $args = $role->_canonicalize_apply_args($class, %{$args});
+
         $role->_check_required_methods($class, $args, @roles);
         $role->_apply_methods($class, $args);
         $role->_apply_attributes($class, $args);
diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index f9f2181..da769b5 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -27,13 +27,13 @@ our %EXPORT_TAGS = (
 # Moose::Util compatible utilities
 
 sub find_meta{
-    return Mouse::Module::class_of( $_[0] );
+    return Mouse::Meta::Module::class_of( $_[0] );
 }
 
 sub does_role{
     my ($class_or_obj, $role) = @_;
 
-    my $meta = Mouse::Module::class_of($class_or_obj);
+    my $meta = Mouse::Meta::Module::class_of($class_or_obj);
 
     return 0 unless defined $meta;
     return 1 if $meta->does_role($role);
diff --git a/lib/Mouse/Util/TypeConstraints.pm b/lib/Mouse/Util/TypeConstraints.pm
index 8df17ea..a012e9d 100644
--- a/lib/Mouse/Util/TypeConstraints.pm
+++ b/lib/Mouse/Util/TypeConstraints.pm
@@ -103,8 +103,20 @@ sub type {
 }
 
 sub subtype {
-    my $pkg = caller(0);
-    my($name, %conf) = @_;
+    my $pkg = caller;
+
+    my $name;
+    my %conf;
+
+    if(@_ % 2){ # odd number of arguments
+        $name = shift;
+        %conf = @_;
+    }
+    else{
+        %conf = @_;
+        $name = $conf{name} || '__ANON__';
+    }
+
     if ($TYPE{$name} && $TYPE_SOURCE{$name} ne $pkg) {
         Carp::croak "The type constraint '$name' has already been created in $TYPE_SOURCE{$name} and cannot be created again in $pkg";
     };
diff --git a/t/030_roles/004_role_composition_errors.t b/t/030_roles/004_role_composition_errors.t
new file mode 100644
index 0000000..837af9f
--- /dev/null
+++ b/t/030_roles/004_role_composition_errors.t
@@ -0,0 +1,157 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 14;
+use Test::Exception;
+
+
+
+{
+
+    package Foo::Role;
+    use Mouse::Role;
+
+    requires 'foo';
+}
+
+is_deeply(
+    [ sort Foo::Role->meta->get_required_method_list ],
+    ['foo'],
+    '... the Foo::Role has a required method (foo)'
+);
+
+# classes which does not implement required method
+{
+
+    package Foo::Class;
+    use Mouse;
+
+    ::dies_ok { with('Foo::Role') }
+        '... no foo method implemented by Foo::Class';
+}
+
+# class which does implement required method
+{
+
+    package Bar::Class;
+    use Mouse;
+
+    ::dies_ok { with('Foo::Class') }
+        '... cannot consume a class, it must be a role';
+    ::lives_ok { with('Foo::Role') }
+        '... has a foo method implemented by Bar::Class';
+
+    sub foo {'Bar::Class::foo'}
+}
+
+# role which does implement required method
+{
+
+    package Bar::Role;
+    use Mouse::Role;
+
+    ::lives_ok { with('Foo::Role') }
+        '... has a foo method implemented by Bar::Role';
+
+    sub foo {'Bar::Role::foo'}
+}
+
+is_deeply(
+    [ sort Bar::Role->meta->get_required_method_list ],
+    [],
+    '... the Bar::Role has not inherited the required method from Foo::Role'
+);
+
+# role which does not implement required method
+{
+
+    package Baz::Role;
+    use Mouse::Role;
+
+    ::lives_ok { with('Foo::Role') }
+        '... no foo method implemented by Baz::Role';
+}
+
+is_deeply(
+    [ sort Baz::Role->meta->get_required_method_list ],
+    ['foo'],
+    '... the Baz::Role has inherited the required method from Foo::Role'
+);
+
+# classes which does not implement required method
+{
+
+    package Baz::Class;
+    use Mouse;
+
+    ::dies_ok { with('Baz::Role') }
+        '... no foo method implemented by Baz::Class2';
+}
+
+# class which does implement required method
+{
+
+    package Baz::Class2;
+    use Mouse;
+
+    ::lives_ok { with('Baz::Role') }
+        '... has a foo method implemented by Baz::Class2';
+
+    sub foo {'Baz::Class2::foo'}
+}
+
+
+{
+    package Quux::Role;
+    use Mouse::Role;
+
+    requires qw( meth1 meth2 meth3 meth4 );
+}
+
+# RT #41119
+{
+
+    package Quux::Class;
+    use Mouse;
+
+    ::throws_ok { with('Quux::Role') }
+        qr/\Q'Quux::Role' requires the methods 'meth1', 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class'/,
+        'exception mentions all the missing required methods at once';
+}
+
+{
+    package Quux::Class2;
+    use Mouse;
+
+    sub meth1 { }
+
+    ::throws_ok { with('Quux::Role') }
+        qr/'Quux::Role' requires the methods 'meth2', 'meth3', and 'meth4' to be implemented by 'Quux::Class2'/,
+        'exception mentions all the missing required methods at once, but not the one that exists';
+}
+
+{
+    package Quux::Class3;
+    use Mouse;
+
+    has 'meth1' => ( is => 'ro' );
+    has 'meth2' => ( is => 'ro' );
+
+    ::throws_ok { with('Quux::Role') }
+        qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class3'/,
+        'exception mentions all the missing methods at once, but not the accessors';
+}
+
+{
+    package Quux::Class4;
+    use Mouse;
+
+    sub meth1 { }
+    has 'meth2' => ( is => 'ro' );
+
+    ::throws_ok { with('Quux::Role') }
+        qr/'Quux::Role' requires the methods 'meth3' and 'meth4' to be implemented by 'Quux::Class4'/,
+        'exception mentions all the require methods that are accessors at once, as well as missing methods, but not the one that exists';
+}
diff --git a/t/030_roles/034_create_role.t b/t/030_roles/034_create_role.t
new file mode 100644
index 0000000..25645d7
--- /dev/null
+++ b/t/030_roles/034_create_role.t
@@ -0,0 +1,32 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Mouse ();
+
+my $role = Mouse::Meta::Role->create(
+    'MyItem::Role::Equipment',
+    attributes => {
+        is_worn => {
+            is => 'rw',
+            isa => 'Bool',
+        },
+    },
+    methods => {
+        remove => sub { shift->is_worn(0) },
+    },
+);
+
+my $class = Mouse::Meta::Class->create('MyItem::Armor::Helmet' =>
+    roles => ['MyItem::Role::Equipment'],
+);
+
+my $visored = $class->new_object(is_worn => 0);
+ok(!$visored->is_worn, "attribute, accessor was consumed");
+$visored->is_worn(1);
+ok($visored->is_worn, "accessor was consumed");
+$visored->remove;
+ok(!$visored->is_worn, "method was consumed");
+
+ok(!$role->is_anon_role, "the role is not anonymous");
+
diff --git a/t/030_roles/035_anonymous_roles.t b/t/030_roles/035_anonymous_roles.t
new file mode 100644
index 0000000..08428df
--- /dev/null
+++ b/t/030_roles/035_anonymous_roles.t
@@ -0,0 +1,35 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 7;
+use Mouse ();
+
+my $role = Mouse::Meta::Role->create_anon_role(
+    attributes => {
+        is_worn => {
+            is => 'rw',
+            isa => 'Bool',
+        },
+    },
+    methods => {
+        remove => sub { shift->is_worn(0) },
+    },
+);
+
+my $class = Mouse::Meta::Class->create('MyItem::Armor::Helmet');
+$role->apply($class);
+# XXX: Mouse::Util::apply_all_roles doesn't cope with references yet
+
+my $visored = $class->new_object(is_worn => 0);
+ok(!$visored->is_worn, "attribute, accessor was consumed");
+$visored->is_worn(1);
+ok($visored->is_worn, "accessor was consumed");
+$visored->remove;
+ok(!$visored->is_worn, "method was consumed");
+
+like($role->name, qr/::__ANON__::/, "the role name (is " . $role->name . ")");
+ok($role->is_anon_role, "the role knows it's anonymous");
+
+ok(Mouse::Util::is_class_loaded(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes is_class_loaded");
+ok(Mouse::Util::find_meta(Mouse::Meta::Role->create_anon_role->name), "creating an anonymous role satisifes class_of");
+
diff --git a/t/030_roles/036_free_anonymous_roles.t b/t/030_roles/036_free_anonymous_roles.t
new file mode 100644
index 0000000..7429765
--- /dev/null
+++ b/t/030_roles/036_free_anonymous_roles.t
@@ -0,0 +1,34 @@
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use Mouse ();
+use Scalar::Util 'weaken';
+
+my $weak;
+my $name;
+do {
+    my $anon_class;
+
+    do {
+        my $role = Mouse::Meta::Role->create_anon_role(
+            methods => {
+                improperly_freed => sub { 1 },
+            },
+        );
+        weaken($weak = $role);
+
+        $name = $role->name;
+
+        $anon_class = Mouse::Meta::Class->create_anon_class(
+            roles => [ $role->name ],
+        );
+    };
+
+    ok($weak, "we still have the role metaclass because the anonymous class that consumed it is still alive");
+    ok($name->can('improperly_freed'), "we have not blown away the role's symbol table");
+};
+
+ok(!$weak, "the role metaclass is freed after its last reference (from a consuming anonymous class) is freed");
+
+ok(!$name->can('improperly_freed'), "we blew away the role's symbol table entries");
diff --git a/t/030_roles/failing/012_method_exclusion_in_composition.t b/t/030_roles/failing/012_method_exclusion_in_composition.t
index d852b17..f678d2c 100644
--- a/t/030_roles/failing/012_method_exclusion_in_composition.t
+++ b/t/030_roles/failing/012_method_exclusion_in_composition.t
@@ -39,7 +39,7 @@ ok(My::OtherRole->meta->has_method($_), "we have a $_ method") for qw(foo bar ba
 
 ok(!My::OtherRole->meta->requires_method('foo'), '... and the &foo method is not required');
 ok(My::OtherRole->meta->requires_method('bar'), '... and the &bar method is required');
-
+use Data::Dumper; print Dumper(My::OtherRole->meta->{required_methods});
 {
     package Foo::Role;
     use Mouse::Role;
diff --git a/t/030_roles/failing/037_create_role_subclass.t b/t/030_roles/failing/037_create_role_subclass.t
index 11e9105..d794e12 100644
--- a/t/030_roles/failing/037_create_role_subclass.t
+++ b/t/030_roles/failing/037_create_role_subclass.t
@@ -19,6 +19,7 @@ do {
 };
 
 my $role = My::Meta::Role->create_anon_role;
+#use Data::Dumper; $Data::Dumper::Deparse = 1; print Dumper $role->can('test_serial');
 is($role->test_serial, 1, "default value for the serial attribute");
 
 my $nine_role = My::Meta::Role->create_anon_role(test_serial => 9);
diff --git a/t/200_examples/001_example.t b/t/200_examples/001_example.t
new file mode 100644
index 0000000..b4606c4
--- /dev/null
+++ b/t/200_examples/001_example.t
@@ -0,0 +1,128 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+use Test::Exception;
+
+
+
+## Roles
+
+{
+    package Constraint;
+    use Mouse::Role;
+
+    has 'value' => (isa => 'Num', is => 'ro');
+
+    around 'validate' => sub {
+        my $c = shift;
+        my ($self, $field) = @_;
+        return undef if $c->($self, $self->validation_value($field));
+        return $self->error_message;
+    };
+
+    sub validation_value {
+        my ($self, $field) = @_;
+        return $field;
+    }
+
+    sub error_message { confess "Abstract method!" }
+
+    package Constraint::OnLength;
+    use Mouse::Role;
+
+    has 'units' => (isa => 'Str', is => 'ro');
+
+    override 'validation_value' => sub {
+        return length(super());
+    };
+
+    override 'error_message' => sub {
+        my $self = shift;
+        return super() . ' ' . $self->units;
+    };
+
+}
+
+## Classes
+
+{
+    package Constraint::AtLeast;
+    use Mouse;
+
+    with 'Constraint';
+
+    sub validate {
+        my ($self, $field) = @_;
+        ($field >= $self->value);
+    }
+
+    sub error_message { 'must be at least ' . (shift)->value; }
+
+    package Constraint::NoMoreThan;
+    use Mouse;
+
+    with 'Constraint';
+
+    sub validate {
+        my ($self, $field) = @_;
+        ($field <= $self->value);
+    }
+
+    sub error_message { 'must be no more than ' . (shift)->value; }
+
+    package Constraint::LengthNoMoreThan;
+    use Mouse;
+
+    extends 'Constraint::NoMoreThan';
+       with 'Constraint::OnLength';
+
+    package Constraint::LengthAtLeast;
+    use Mouse;
+
+    extends 'Constraint::AtLeast';
+       with 'Constraint::OnLength';
+}
+
+my $no_more_than_10 = Constraint::NoMoreThan->new(value => 10);
+isa_ok($no_more_than_10, 'Constraint::NoMoreThan');
+
+ok($no_more_than_10->does('Constraint'), '... Constraint::NoMoreThan does Constraint');
+
+ok(!defined($no_more_than_10->validate(1)), '... validated correctly');
+is($no_more_than_10->validate(11), 'must be no more than 10', '... validation failed correctly');
+
+my $at_least_10 = Constraint::AtLeast->new(value => 10);
+isa_ok($at_least_10, 'Constraint::AtLeast');
+
+ok($at_least_10->does('Constraint'), '... Constraint::AtLeast does Constraint');
+
+ok(!defined($at_least_10->validate(11)), '... validated correctly');
+is($at_least_10->validate(1), 'must be at least 10', '... validation failed correctly');
+
+# onlength
+
+my $no_more_than_10_chars = Constraint::LengthNoMoreThan->new(value => 10, units => 'chars');
+isa_ok($no_more_than_10_chars, 'Constraint::LengthNoMoreThan');
+isa_ok($no_more_than_10_chars, 'Constraint::NoMoreThan');
+
+ok($no_more_than_10_chars->does('Constraint'), '... Constraint::LengthNoMoreThan does Constraint');
+ok($no_more_than_10_chars->does('Constraint::OnLength'), '... Constraint::LengthNoMoreThan does Constraint::OnLength');
+
+ok(!defined($no_more_than_10_chars->validate('foo')), '... validated correctly');
+is($no_more_than_10_chars->validate('foooooooooo'),
+    'must be no more than 10 chars',
+    '... validation failed correctly');
+
+my $at_least_10_chars = Constraint::LengthAtLeast->new(value => 10, units => 'chars');
+isa_ok($at_least_10_chars, 'Constraint::LengthAtLeast');
+isa_ok($at_least_10_chars, 'Constraint::AtLeast');
+
+ok($at_least_10_chars->does('Constraint'), '... Constraint::LengthAtLeast does Constraint');
+ok($at_least_10_chars->does('Constraint::OnLength'), '... Constraint::LengthAtLeast does Constraint::OnLength');
+
+ok(!defined($at_least_10_chars->validate('barrrrrrrrr')), '... validated correctly');
+is($at_least_10_chars->validate('bar'), 'must be at least 10 chars', '... validation failed correctly');
+
diff --git a/t/200_examples/003_example.t b/t/200_examples/003_example.t
new file mode 100644
index 0000000..879fc3b
--- /dev/null
+++ b/t/200_examples/003_example.t
@@ -0,0 +1,163 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 30;
+use Test::Exception;
+
+sub U {
+    my $f = shift;
+    sub { $f->($f, @_) };
+}
+
+sub Y {
+    my $f = shift;
+    U(sub { my $h = shift; sub { $f->(U($h)->())->(@_) } })->();
+}
+
+{
+    package List;
+    use Mouse::Role;
+
+    has '_list' => (
+        is       => 'ro',
+        isa      => 'ArrayRef',
+        init_arg => '::',
+        default  => sub { [] }
+    );
+
+    sub head { (shift)->_list->[0] }
+    sub tail {
+        my $self = shift;
+        (ref $self)->new(
+            '::' => [
+                @{$self->_list}[1 .. $#{$self->_list}]
+            ]
+        );
+    }
+
+    sub print {
+        join ", " => @{$_[0]->_list};
+    }
+
+    package List::Immutable;
+    use Mouse::Role;
+
+    requires 'head';
+    requires 'tail';
+
+    sub is_empty { not defined ($_[0]->head) }
+
+    sub length {
+        my $self = shift;
+        (::Y(sub {
+            my $redo = shift;
+            sub {
+                my ($list, $acc) = @_;
+                return $acc if $list->is_empty;
+                $redo->($list->tail, $acc + 1);
+            }
+        }))->($self, 0);
+    }
+
+    sub apply {
+        my ($self, $function) = @_;
+        (::Y(sub {
+            my $redo = shift;
+            sub {
+                my ($list, $func, $acc) = @_;
+                return (ref $list)->new('::' => $acc)
+                    if $list->is_empty;
+                $redo->(
+                    $list->tail,
+                    $func,
+                    [ @{$acc}, $func->($list->head) ]
+                );
+            }
+        }))->($self, $function, []);
+    }
+
+    package My::List1;
+    use Mouse;
+
+    ::lives_ok {
+        with 'List', 'List::Immutable';
+    } '... successfully composed roles together';
+
+    package My::List2;
+    use Mouse;
+
+    ::lives_ok {
+        with 'List::Immutable', 'List';
+    } '... successfully composed roles together';
+
+}
+
+{
+    my $coll = My::List1->new;
+    isa_ok($coll, 'My::List1');
+
+    ok($coll->does('List'), '... $coll does List');
+    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+    ok($coll->is_empty, '... we have an empty collection');
+    is($coll->length, 0, '... we have a length of 1 for the collection');
+}
+
+{
+    my $coll = My::List2->new;
+    isa_ok($coll, 'My::List2');
+
+    ok($coll->does('List'), '... $coll does List');
+    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+    ok($coll->is_empty, '... we have an empty collection');
+    is($coll->length, 0, '... we have a length of 1 for the collection');
+}
+
+{
+    my $coll = My::List1->new('::' => [ 1 .. 10 ]);
+    isa_ok($coll, 'My::List1');
+
+    ok($coll->does('List'), '... $coll does List');
+    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+    ok(!$coll->is_empty, '... we do not have an empty collection');
+    is($coll->length, 10, '... we have a length of 10 for the collection');
+
+    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
+
+    my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
+    isa_ok($coll2, 'My::List1');
+
+    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
+    is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
+}
+
+{
+    my $coll = My::List2->new('::' => [ 1 .. 10 ]);
+    isa_ok($coll, 'My::List2');
+
+    ok($coll->does('List'), '... $coll does List');
+    ok($coll->does('List::Immutable'), '... $coll does List::Immutable');
+
+    ok(!$coll->is_empty, '... we do not have an empty collection');
+    is($coll->length, 10, '... we have a length of 10 for the collection');
+
+    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... got the right printed value');
+
+    my $coll2 = $coll->apply(sub { $_[0] * $_[0] });
+    isa_ok($coll2, 'My::List2');
+
+    is($coll->print, '1, 2, 3, 4, 5, 6, 7, 8, 9, 10', '... original is still the same');
+    is($coll2->print, '1, 4, 9, 16, 25, 36, 49, 64, 81, 100', '... new collection is changed');
+}
+
+
+
+
+
+
+
+
diff --git a/t/200_examples/004_example_w_DCS.t b/t/200_examples/004_example_w_DCS.t
new file mode 100644
index 0000000..00e8dce
--- /dev/null
+++ b/t/200_examples/004_example_w_DCS.t
@@ -0,0 +1,92 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests how well Mouse type constraints
+play with Declare::Constraints::Simple.
+
+Pretty well if I do say so myself :)
+
+=cut
+
+BEGIN {
+    eval "use Declare::Constraints::Simple;";
+    plan skip_all => "Declare::Constraints::Simple is required for this test" if $@;
+    plan tests => 9;
+}
+
+use Test::Exception;
+
+{
+    package Foo;
+    use Mouse;
+    use Mouse::Util::TypeConstraints;
+    use Declare::Constraints::Simple -All;
+
+    # define your own type ...
+    type( 'HashOfArrayOfObjects',
+        where => IsHashRef(
+            -keys   => HasLength,
+            -values => IsArrayRef(IsObject)
+        )
+    );
+
+    has 'bar' => (
+        is  => 'rw',
+        isa => 'HashOfArrayOfObjects',
+    );
+
+    # inline the constraints as anon-subtypes
+    has 'baz' => (
+        is  => 'rw',
+        isa => subtype( as => 'ArrayRef', where => IsArrayRef(IsInt) ),
+    );
+
+    package Bar;
+    use Mouse;
+}
+
+my $hash_of_arrays_of_objs = {
+   foo1 => [ Bar->new ],
+   foo2 => [ Bar->new, Bar->new ],
+};
+
+my $array_of_ints = [ 1 .. 10 ];
+
+my $foo;
+lives_ok {
+    $foo = Foo->new(
+       'bar' => $hash_of_arrays_of_objs,
+       'baz' => $array_of_ints,
+    );
+} '... construction succeeded';
+isa_ok($foo, 'Foo');
+
+is_deeply($foo->bar, $hash_of_arrays_of_objs, '... got our value correctly');
+is_deeply($foo->baz, $array_of_ints, '... got our value correctly');
+
+dies_ok {
+    $foo->bar([]);
+} '... validation failed correctly';
+
+dies_ok {
+    $foo->bar({ foo => 3 });
+} '... validation failed correctly';
+
+dies_ok {
+    $foo->bar({ foo => [ 1, 2, 3 ] });
+} '... validation failed correctly';
+
+
+dies_ok {
+    $foo->baz([ "foo" ]);
+} '... validation failed correctly';
+
+dies_ok {
+    $foo->baz({});
+} '... validation failed correctly';
diff --git a/t/200_examples/005_example_w_TestDeep.t b/t/200_examples/005_example_w_TestDeep.t
new file mode 100644
index 0000000..604b78f
--- /dev/null
+++ b/t/200_examples/005_example_w_TestDeep.t
@@ -0,0 +1,78 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+=pod
+
+This tests how well Mouse type constraints
+play with Test::Deep.
+
+Its not as pretty as Declare::Constraints::Simple,
+but it is not completely horrid either.
+
+=cut
+
+BEGIN {
+    eval "use Test::Deep;";
+    plan skip_all => "Test::Deep is required for this test" if $@;
+    plan tests => 5;
+}
+
+use Test::Exception;
+
+{
+    package Foo;
+    use Mouse;
+    use Mouse::Util::TypeConstraints;
+
+    use Test::Deep qw[
+        eq_deeply array_each subhashof ignore
+    ];
+
+    # define your own type ...
+    type 'ArrayOfHashOfBarsAndRandomNumbers'
+        => where {
+            eq_deeply($_,
+                array_each(
+                    subhashof({
+                        bar           => Test::Deep::isa('Bar'),
+                        random_number => ignore()
+                    })
+                )
+            )
+        };
+
+    has 'bar' => (
+        is  => 'rw',
+        isa => 'ArrayOfHashOfBarsAndRandomNumbers',
+    );
+
+    package Bar;
+    use Mouse;
+}
+
+my $array_of_hashes = [
+    { bar => Bar->new, random_number => 10 },
+    { bar => Bar->new },
+];
+
+my $foo;
+lives_ok {
+    $foo = Foo->new('bar' => $array_of_hashes);
+} '... construction succeeded';
+isa_ok($foo, 'Foo');
+
+is_deeply($foo->bar, $array_of_hashes, '... got our value correctly');
+
+dies_ok {
+    $foo->bar({});
+} '... validation failed correctly';
+
+dies_ok {
+    $foo->bar([{ foo => 3 }]);
+} '... validation failed correctly';
+
+
diff --git a/t/200_examples/007_Child_Parent_attr_inherit.t b/t/200_examples/007_Child_Parent_attr_inherit.t
new file mode 100644
index 0000000..e41a568
--- /dev/null
+++ b/t/200_examples/007_Child_Parent_attr_inherit.t
@@ -0,0 +1,136 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 23;
+
+=pod
+
+Some examples of triggers and how they can
+be used to manage parent-child relationships.
+
+=cut
+
+{
+
+    package Parent;
+    use Mouse;
+
+    has 'last_name' => (
+        is      => 'rw',
+        isa     => 'Str',
+        trigger => sub {
+            my $self = shift;
+
+            # if the parents last-name changes
+            # then so do all the childrens
+            foreach my $child ( @{ $self->children } ) {
+                $child->last_name( $self->last_name );
+            }
+        }
+    );
+
+    has 'children' =>
+        ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
+}
+{
+
+    package Child;
+    use Mouse;
+
+    has 'parent' => (
+        is       => 'rw',
+        isa      => 'Parent',
+        required => 1,
+        trigger  => sub {
+            my $self = shift;
+
+            # if the parent is changed,..
+            # make sure we update
+            $self->last_name( $self->parent->last_name );
+        }
+    );
+
+    has 'last_name' => (
+        is      => 'rw',
+        isa     => 'Str',
+        lazy    => 1,
+        default => sub { (shift)->parent->last_name }
+    );
+
+}
+
+my $parent = Parent->new( last_name => 'Smith' );
+isa_ok( $parent, 'Parent' );
+
+is( $parent->last_name, 'Smith',
+    '... the parent has the last name we expected' );
+
+$parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] );
+
+foreach my $child ( @{ $parent->children } ) {
+    is( $child->last_name, $parent->last_name,
+              '... parent and child have the same last name ('
+            . $parent->last_name
+            . ')' );
+}
+
+$parent->last_name('Jones');
+is( $parent->last_name, 'Jones', '... the parent has the new last name' );
+
+foreach my $child ( @{ $parent->children } ) {
+    is( $child->last_name, $parent->last_name,
+              '... parent and child have the same last name ('
+            . $parent->last_name
+            . ')' );
+}
+
+# make a new parent
+
+my $parent2 = Parent->new( last_name => 'Brown' );
+isa_ok( $parent2, 'Parent' );
+
+# orphan the child
+
+my $orphan = pop @{ $parent->children };
+
+# and then the new parent adopts it
+
+$orphan->parent($parent2);
+
+foreach my $child ( @{ $parent->children } ) {
+    is( $child->last_name, $parent->last_name,
+              '... parent and child have the same last name ('
+            . $parent->last_name
+            . ')' );
+}
+
+isnt( $orphan->last_name, $parent->last_name,
+          '... the orphan child does not have the same last name anymore ('
+        . $parent2->last_name
+        . ')' );
+is( $orphan->last_name, $parent2->last_name,
+          '... parent2 and orphan child have the same last name ('
+        . $parent2->last_name
+        . ')' );
+
+# make sure that changes still will not propagate
+
+$parent->last_name('Miller');
+is( $parent->last_name, 'Miller',
+    '... the parent has the new last name (again)' );
+
+foreach my $child ( @{ $parent->children } ) {
+    is( $child->last_name, $parent->last_name,
+              '... parent and child have the same last name ('
+            . $parent->last_name
+            . ')' );
+}
+
+isnt( $orphan->last_name, $parent->last_name,
+    '... the orphan child is not affected by changes in the parent anymore' );
+is( $orphan->last_name, $parent2->last_name,
+          '... parent2 and orphan child have the same last name ('
+        . $parent2->last_name
+        . ')' );
diff --git a/t/200_examples/008_record_set_iterator.t b/t/200_examples/008_record_set_iterator.t
new file mode 100644
index 0000000..aebe61c
--- /dev/null
+++ b/t/200_examples/008_record_set_iterator.t
@@ -0,0 +1,127 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+use Test::Exception;
+
+
+
+{
+    package Record;
+    use Mouse;
+
+    has 'first_name' => (is => 'ro', isa => 'Str');
+    has 'last_name'  => (is => 'ro', isa => 'Str');
+
+    package RecordSet;
+    use Mouse;
+
+    has 'data' => (
+        is      => 'ro',
+        isa     => 'ArrayRef[Record]',
+        default => sub { [] },
+    );
+
+    has 'index' => (
+        is      => 'rw',
+        isa     => 'Int',
+        default => sub { 0 },
+    );
+
+    sub next {
+        my $self = shift;
+        my $i = $self->index;
+        $self->index($i + 1);
+        return $self->data->[$i];
+    }
+
+    package RecordSetIterator;
+    use Mouse;
+
+    has 'record_set' => (
+        is  => 'rw',
+        isa => 'RecordSet',
+    );
+
+    # list the fields you want to
+    # fetch from the current record
+    my @fields = Record->meta->get_attribute_list;
+
+    has 'current_record' => (
+        is      => 'rw',
+        isa     => 'Record',
+        lazy    => 1,
+        default => sub {
+            my $self = shift;
+            $self->record_set->next() # grab the first one
+        },
+        trigger => sub {
+            my $self = shift;
+            # whenever this attribute is
+            # updated, it will clear all
+            # the fields for you.
+            $self->$_() for map { '_clear_' . $_ } @fields;
+        }
+    );
+
+    # define the attributes
+    # for all the fields.
+    for my $field (@fields) {
+        has $field => (
+            is      => 'ro',
+            isa     => 'Any',
+            lazy    => 1,
+            default => sub {
+                my $self = shift;
+                # fetch the value from
+                # the current record
+                $self->current_record->$field();
+            },
+            # make sure they have a clearer ..
+            clearer => ('_clear_' . $field)
+        );
+    }
+
+    sub get_next_record {
+        my $self = shift;
+        $self->current_record($self->record_set->next());
+    }
+}
+
+my $rs = RecordSet->new(
+    data => [
+        Record->new(first_name => 'Bill', last_name => 'Smith'),
+        Record->new(first_name => 'Bob', last_name => 'Jones'),
+        Record->new(first_name => 'Jim', last_name => 'Johnson'),
+    ]
+);
+isa_ok($rs, 'RecordSet');
+
+my $rsi = RecordSetIterator->new(record_set => $rs);
+isa_ok($rsi, 'RecordSetIterator');
+
+is($rsi->first_name, 'Bill', '... got the right first name');
+is($rsi->last_name, 'Smith', '... got the right last name');
+
+$rsi->get_next_record;
+
+is($rsi->first_name, 'Bob', '... got the right first name');
+is($rsi->last_name, 'Jones', '... got the right last name');
+
+$rsi->get_next_record;
+
+is($rsi->first_name, 'Jim', '... got the right first name');
+is($rsi->last_name, 'Johnson', '... got the right last name');
+
+
+
+
+
+
+
+
+
+
+
diff --git a/t/400_mouse_util/002_mouse_util_does_role.t b/t/400_mouse_util/002_mouse_util_does_role.t
new file mode 100644
index 0000000..5447418
--- /dev/null
+++ b/t/400_mouse_util/002_mouse_util_does_role.t
@@ -0,0 +1,81 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+BEGIN {
+    use_ok('Mouse::Util', ':all');
+}
+
+{
+  package Foo;
+
+  use Mouse::Role;
+}
+
+{
+  package Bar;
+
+  use Mouse;
+
+  with qw/Foo/;
+}
+
+{
+  package Baz;
+
+  use Mouse;
+}
+
+{
+  package Quux;
+
+  use metaclass;
+}
+
+{
+  package Foo::Foo;
+
+  use Mouse::Role;
+
+  with 'Foo';
+}
+
+# Classes
+
+ok(does_role('Bar', 'Foo'), '... Bar does Foo');
+
+ok(!does_role('Baz', 'Foo'), '... Baz doesnt do Foo');
+
+# Objects
+
+my $bar = Bar->new;
+
+ok(does_role($bar, 'Foo'), '... $bar does Foo');
+
+my $baz = Baz->new;
+
+ok(!does_role($baz, 'Foo'), '... $baz doesnt do Foo');
+
+# Invalid values
+
+ok(!does_role(undef,'Foo'), '... undef doesnt do Foo');
+
+ok(!does_role(1,'Foo'), '... 1 doesnt do Foo');
+
+# non Mouse metaclass
+
+ok(!does_role('Quux', 'Foo'), '... Quux doesnt do Foo (does not die tho)');
+
+# TODO: make the below work, maybe?
+
+# Self
+
+#ok(does_role('Foo', 'Foo'), '... Foo does do Foo');
+
+# sub-Roles
+
+#ok(does_role('Foo::Foo', 'Foo'), '... Foo::Foo does do Foo');
+
diff --git a/t/lib/Test/Mouse.pm b/t/lib/Test/Mouse.pm
index 83a5ca0..14f20ef 100644
--- a/t/lib/Test/Mouse.pm
+++ b/t/lib/Test/Mouse.pm
@@ -2,6 +2,7 @@ package Test::Mouse;
 
 use strict;
 use warnings;
+use Carp qw(croak);
 use Mouse::Util qw(find_meta does_role);
 
 use base qw(Test::Builder::Module);
@@ -24,6 +25,9 @@ sub meta_ok ($;$) {
 sub does_ok ($$;$) {
     my ($class_or_obj, $does, $message) = @_;
 
+    if(!defined $does){
+        croak "You must pass a role name";
+    }
     $message ||= "The object does $does";
 
     if (does_ok($class_or_obj)) {