From: Stevan Little <stevan.little@iinteractive.com>
Date: Tue, 9 May 2006 16:53:20 +0000 (+0000)
Subject: roles
X-Git-Tag: 0_09_03~32
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=db1ab48de75becfef64963d235e88e663e2daaa2;p=gitmo%2FMoose.git

roles
---

diff --git a/Changes b/Changes
index 1835254..7f06643 100644
--- a/Changes
+++ b/Changes
@@ -3,7 +3,8 @@ Revision history for Perl extension Moose
 0.06
     * Moose 
       - refactored the keyword exports
-        - 'with' now checks Role validaity
+        - 'with' now checks Role validaity and 
+          accepts more than one Role at a time
         - 'extends' makes metaclass adjustments as 
            needed to ensure metaclass compatability
           
@@ -11,7 +12,7 @@ Revision history for Perl extension Moose
       - added the 'enum' keyword for simple 
         string enumerations which can be used as 
         type constraints
-        - see example of usage in t/008_basic.t
+        - see example of usage in t/202_example.t
         
     * Moose::Object
       - more careful checking of params to new()
@@ -32,6 +33,7 @@ Revision history for Perl extension Moose
       - (still somewhat) experimental delegation support 
         with the 'handles' option
         - added several tests for this
+        - no docs for this yet
 
 0.05 Thurs. April 27, 2006
     * Moose
diff --git a/MANIFEST b/MANIFEST
index a1d433d..115aede 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -17,18 +17,18 @@ lib/Moose/Cookbook/Recipe5.pod
 lib/Moose/Cookbook/Recipe6.pod
 lib/Moose/Meta/Attribute.pm
 lib/Moose/Meta/Class.pm
+lib/Moose/Meta/Instance.pm
 lib/Moose/Meta/Role.pm
 lib/Moose/Meta/TypeCoercion.pm
 lib/Moose/Meta/TypeConstraint.pm
 lib/Moose/Util/TypeConstraints.pm
 t/000_load.t
-t/001_basic.t
-t/002_basic.t
-t/003_basic.t
-t/004_basic.t
-t/005_basic.t
-t/006_basic.t
-t/007_basic.t
+t/001_recipe.t
+t/002_recipe.t
+t/003_recipe.t
+t/004_recipe.t
+t/005_recipe.t
+t/006_recipe.t
 t/010_basic_class_setup.t
 t/011_require_superclasses.t
 t/012_super_and_override.t
@@ -36,11 +36,19 @@ t/013_inner_and_augment.t
 t/014_override_augment_inner_super.t
 t/015_override_and_foreign_classes.t
 t/020_foreign_inheritence.t
+t/021_moose_w_metaclass.t
+t/022_moose_respects_base.t
+t/023_moose_respects_type_constraints.t
 t/030_attribute_reader_generation.t
 t/031_attribute_writer_generation.t
 t/032_attribute_accessor_generation.t
 t/033_attribute_triggers.t
 t/034_attribute_does.t
+t/035_attribute_required.t
+t/036_attribute_custom_metaclass.t
+t/037_attribute_type_unions.t
+t/038_attribute_inherited_slot_specs.t
+t/039_attribute_delegation.t
 t/040_meta_role.t
 t/041_role.t
 t/042_apply_role.t
@@ -52,10 +60,15 @@ t/053_util_find_type_constraint.t
 t/054_util_type_coercion.t
 t/055_util_type_reloading.t
 t/056_util_more_type_coercion.t
+t/057_union_types.t
+t/060_moose_for_meta.t
+t/070_more_attr_delegation.t
 t/100_subtype_quote_bug.t
 t/101_subtype_conflict_bug.t
 t/102_Moose_Object_error.t
 t/103_subclass_use_base_bug.t
+t/201_example.t
+t/202_example.t
 t/pod.t
 t/pod_coverage.t
 t/lib/Bar.pm
diff --git a/README b/README
index 8d766bd..1b845be 100644
--- a/README
+++ b/README
@@ -1,4 +1,4 @@
-Moose version 0.05
+Moose version 0.06
 ===========================
 
 See the individual module documentation for more information
diff --git a/TODO b/TODO
index c5c7173..6f953dd 100644
--- a/TODO
+++ b/TODO
@@ -17,16 +17,19 @@ Mostly just for Roles
 
 - inherited slot specs
 
-[10:49] stevan	does can be added to,.. but not changed
+'does' can be added to,.. but not changed
+(need type unions for this)
 
 - proxy attributes
 
-[15:49] 	stevan	you want a proxied attribute
-[15:49] 	stevan	which looks like an attribute, 
-                    talks like an attribute, smells 
-                    like an attribute,.. but if you 
-                    look behind the curtain,.. its 
-                    over there.. in that other object
+a proxied attribute is an attribute
+which looks like an attribute, 
+talks like an attribute, smells 
+like an attribute,.. but if you 
+look behind the curtain,.. its 
+over there.. in that other object
+
+(... probably be a custom metaclass)
 
 - compile time extends
 
diff --git a/lib/Moose.pm b/lib/Moose.pm
index a7541ba..3e3ff10 100644
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -4,7 +4,7 @@ package Moose;
 use strict;
 use warnings;
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 use Scalar::Util 'blessed', 'reftype';
 use Carp         'confess';
@@ -107,11 +107,19 @@ use Moose::Util::TypeConstraints;
         with => sub {
             my $class = $CALLER;
             return subname 'Moose::with' => sub {
-                my ($role) = @_;
-                _load_all_classes($role);
-                ($role->can('meta') && $role->meta->isa('Moose::Meta::Role'))
-                    || confess "You can only consume roles, $role is not a Moose role";
-                $role->meta->apply($class->meta);
+                my (@roles) = @_;
+                _load_all_classes(@roles);
+                ($_->can('meta') && $_->meta->isa('Moose::Meta::Role'))
+                    || confess "You can only consume roles, $_ is not a Moose role"
+                        foreach @roles;
+                if (scalar @roles == 1) {
+                    $roles[0]->meta->apply($class->meta);
+                }
+                else {
+                    Moose::Meta::Role->combine(
+                        map { $_->meta } @roles
+                    )->apply($class->meta);
+                }
             };
         },
         has => sub {
@@ -544,7 +552,9 @@ to cpan-RT.
 
 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 
-Christian Hansen
+Christian Hansen E<lt>chansen@cpan.orgE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.orgE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
diff --git a/lib/Moose/Cookbook/Recipe1.pod b/lib/Moose/Cookbook/Recipe1.pod
index 07be5cc..0e5fac8 100644
--- a/lib/Moose/Cookbook/Recipe1.pod
+++ b/lib/Moose/Cookbook/Recipe1.pod
@@ -178,7 +178,7 @@ not recognize.
 
 From here on, you can use C<$point> and C<$point3d> just as you would 
 any other Perl 5 object. For a more detailed example of what can be 
-done, you can refer to the F<t/001_basic.t> test file.
+done, you can refer to the F<t/001_recipe.t> test file.
 
 =head1 CONCLUSION
 
diff --git a/lib/Moose/Cookbook/Recipe2.pod b/lib/Moose/Cookbook/Recipe2.pod
index 3039604..6648416 100644
--- a/lib/Moose/Cookbook/Recipe2.pod
+++ b/lib/Moose/Cookbook/Recipe2.pod
@@ -160,7 +160,7 @@ normal process, here is an example:
   					     );
 
 And as with the first recipe, a more in-depth example of using 
-these classes can be found in the F<t/002_basic.t> test file.
+these classes can be found in the F<t/002_recipe.t> test file.
 
 =head1 CONCLUSION
 
diff --git a/lib/Moose/Cookbook/Recipe3.pod b/lib/Moose/Cookbook/Recipe3.pod
index 97d1a9d..512da32 100644
--- a/lib/Moose/Cookbook/Recipe3.pod
+++ b/lib/Moose/Cookbook/Recipe3.pod
@@ -202,7 +202,7 @@ only requirement is that the wrappee be created before the wrapper
 
 Now, as with all the other recipes, you can go about using 
 B<BinaryTree> like any other Perl 5 class. A more detailed example of 
-usage can be found in F<t/003_basic.t>.
+usage can be found in F<t/003_recipe.t>.
 
 =head1 CONCLUSION
 
diff --git a/lib/Moose/Cookbook/Recipe4.pod b/lib/Moose/Cookbook/Recipe4.pod
index 644de4f..944a737 100644
--- a/lib/Moose/Cookbook/Recipe4.pod
+++ b/lib/Moose/Cookbook/Recipe4.pod
@@ -259,7 +259,7 @@ And thats about it.
 
 Once again, as with all the other recipes, you can go about using 
 these classes like any other Perl 5 class. A more detailed example of 
-usage can be found in F<t/004_basic.t>.
+usage can be found in F<t/004_recipe.t>.
 
 =head1 CONCLUSION
 
diff --git a/lib/Moose/Meta/Attribute.pm b/lib/Moose/Meta/Attribute.pm
index fffe5e7..596f8a6 100644
--- a/lib/Moose/Meta/Attribute.pm
+++ b/lib/Moose/Meta/Attribute.pm
@@ -7,7 +7,7 @@ use warnings;
 use Scalar::Util 'blessed', 'weaken', 'reftype';
 use Carp         'confess';
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 use Moose::Util::TypeConstraints ();
 
diff --git a/lib/Moose/Meta/Class.pm b/lib/Moose/Meta/Class.pm
index 5b0a8e5..1d44826 100644
--- a/lib/Moose/Meta/Class.pm
+++ b/lib/Moose/Meta/Class.pm
@@ -9,7 +9,7 @@ use Class::MOP;
 use Carp         'confess';
 use Scalar::Util 'weaken', 'blessed', 'reftype';
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 use base 'Class::MOP::Class';
 
diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm
index 82d0400..a39a0ce 100644
--- a/lib/Moose/Meta/Role.pm
+++ b/lib/Moose/Meta/Role.pm
@@ -72,7 +72,8 @@ sub new {
     $options{':role_meta'} = Moose::Meta::Class->initialize(
         $options{role_name},
         ':method_metaclass' => 'Moose::Meta::Role::Method'
-    );
+    ) unless defined $options{':role_meta'} && 
+             $options{':role_meta'}->isa('Moose::Meta::Class');
     my $self = $class->meta->new_object(%options);
     return $self;
 }
@@ -116,6 +117,14 @@ sub requires_method {
     exists $self->get_required_methods_map->{$method_name} ? 1 : 0;
 }
 
+sub _clean_up_required_methods {
+    my $self = shift;
+    foreach my $method ($self->get_required_method_list) {
+        delete $self->get_required_methods_map->{$method}
+            if $self->has_method($method);
+    } 
+}
+
 ## methods
 
 # NOTE:
@@ -254,23 +263,62 @@ sub apply {
     }    
     
     foreach my $attribute_name ($self->get_attribute_list) {
-        # skip it if it has one already
-        next if $other->has_attribute($attribute_name);
-        # add it, although it could be overriden 
-        $other->add_attribute(
-            $attribute_name,
-            %{$self->get_attribute($attribute_name)}
-        );
+        # it if it has one already
+        if ($other->has_attribute($attribute_name)) {
+            # see if we are being composed  
+            # into a role or not
+            if ($other->isa('Moose::Meta::Role')) {
+                # all attribute conflicts between roles 
+                # result in an immediate fatal error 
+                confess "Role '" . $self->name . "' has encountered an attribute conflict " . 
+                        "during composition. This is fatal error and cannot be disambiguated.";
+            }
+            else {
+                # but if this is a class, we 
+                # can safely skip adding the 
+                # attribute to the class
+                next;
+            }
+        }
+        else {
+            # add it, although it could be overriden 
+            $other->add_attribute(
+                $attribute_name,
+                %{$self->get_attribute($attribute_name)}
+            );
+        }
     }
     
     foreach my $method_name ($self->get_method_list) {
-        # skip it if it has one already
-        next if $other->has_method($method_name);
-        # add it, although it could be overriden 
-        $other->alias_method(
-            $method_name,
-            $self->get_method($method_name)
-        );
+        # it if it has one already
+        if ($other->has_method($method_name)) {
+            # see if we are composing into a role
+            if ($other->isa('Moose::Meta::Role')) { 
+                # method conflicts between roles result 
+                # in the method becoming a requirement
+                $other->add_required_methods($method_name);
+                # NOTE:
+                # we have to remove the method from our 
+                # role, if this is being called from combine()
+                # which means the meta is an anon class
+                # this *may* cause problems later, but it 
+                # is probably fairly safe to assume that 
+                # anon classes will only be used internally
+                # or by people who know what they are doing
+                $other->_role_meta->remove_method($method_name)
+                    if $other->_role_meta->name =~ /__ANON__/;
+            }
+            else {
+                next;
+            }
+        }
+        else {
+            # add it, although it could be overriden 
+            $other->alias_method(
+                $method_name,
+                $self->get_method($method_name)
+            );
+        }
     }    
     
     foreach my $method_name ($self->get_method_modifier_list('override')) {
@@ -308,6 +356,26 @@ sub apply {
     $other->add_role($self);
 }
 
+sub combine {
+    my ($class, @roles) = @_;
+    
+    my $combined = $class->new(
+        ':role_meta' => Moose::Meta::Class->create_anon_class()
+    );
+    
+    foreach my $role (@roles) {
+        $role->apply($combined);
+    }
+    
+    $combined->_clean_up_required_methods;
+
+    #warn ">>> req-methods: " . (join ", " => $combined->get_required_method_list) . "\n";    
+    #warn ">>>     methods: " . (join ", " => $combined->get_method_list) . "\n";
+    #warn ">>>       attrs: " . (join ", " => $combined->get_attribute_list) . "\n";    
+    
+    return $combined;
+}
+
 package Moose::Meta::Role::Method;
 
 use strict;
@@ -344,6 +412,8 @@ probably not that much really).
 
 =item B<apply>
 
+=item B<combine>
+
 =back
 
 =over 4
diff --git a/lib/Moose/Object.pm b/lib/Moose/Object.pm
index fe407ea..ababe71 100644
--- a/lib/Moose/Object.pm
+++ b/lib/Moose/Object.pm
@@ -9,7 +9,7 @@ use metaclass 'Moose::Meta::Class';
 
 use Carp 'confess';
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 sub new {
     my $class  = shift;
diff --git a/lib/Moose/Role.pm b/lib/Moose/Role.pm
index aa27617..94d70f3 100644
--- a/lib/Moose/Role.pm
+++ b/lib/Moose/Role.pm
@@ -225,7 +225,7 @@ to cpan-RT.
 
 Stevan Little E<lt>stevan@iinteractive.comE<gt>
 
-Christian Hansen
+Christian Hansen E<lt>chansen@cpan.orgE<gt>
 
 =head1 COPYRIGHT AND LICENSE
 
diff --git a/lib/Moose/Util/TypeConstraints.pm b/lib/Moose/Util/TypeConstraints.pm
index 68ed3ee..2c47e0d 100644
--- a/lib/Moose/Util/TypeConstraints.pm
+++ b/lib/Moose/Util/TypeConstraints.pm
@@ -7,7 +7,7 @@ use warnings;
 use Carp         'confess';
 use Scalar::Util 'blessed';
 
-our $VERSION = '0.05';
+our $VERSION = '0.06';
 
 use Moose::Meta::TypeConstraint;
 use Moose::Meta::TypeCoercion;
diff --git a/t/044_basic_role_composition.t b/t/044_basic_role_composition.t
new file mode 100644
index 0000000..91f91a3
--- /dev/null
+++ b/t/044_basic_role_composition.t
@@ -0,0 +1,262 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+use Test::Exception;
+
+BEGIN {
+    use_ok('Moose');
+    use_ok('Moose::Role');    
+}
+
+=pod
+
+Mutually recursive roles.
+
+=cut
+
+{
+    package Role::Foo;
+    use strict;
+    use warnings;
+    use Moose::Role;
+
+    requires 'foo';
+    
+    sub bar { 'Role::Foo::bar' }
+    
+    package Role::Bar;
+    use strict;
+    use warnings;
+    use Moose::Role;
+    
+    requires 'bar';
+    
+    sub foo { 'Role::Bar::foo' }    
+}
+
+{
+    package My::Test1;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'Role::Foo', 'Role::Bar';
+    } '... our mutually recursive roles combine okay';
+    
+    package My::Test2;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'Role::Bar', 'Role::Foo';
+    } '... our mutually recursive roles combine okay (no matter what order)';    
+}
+
+my $test1 = My::Test1->new;
+isa_ok($test1, 'My::Test1');
+
+ok($test1->does('Role::Foo'), '... $test1 does Role::Foo');
+ok($test1->does('Role::Bar'), '... $test1 does Role::Bar');
+
+can_ok($test1, 'foo');
+can_ok($test1, 'bar');
+
+is($test1->foo, 'Role::Bar::foo', '... $test1->foo worked');
+is($test1->bar, 'Role::Foo::bar', '... $test1->bar worked');
+
+my $test2 = My::Test2->new;
+isa_ok($test2, 'My::Test2');
+
+ok($test2->does('Role::Foo'), '... $test2 does Role::Foo');
+ok($test2->does('Role::Bar'), '... $test2 does Role::Bar');
+
+can_ok($test2, 'foo');
+can_ok($test2, 'bar');
+
+is($test2->foo, 'Role::Bar::foo', '... $test2->foo worked');
+is($test2->bar, 'Role::Foo::bar', '... $test2->bar worked');
+
+# check some meta-stuff
+
+ok(Role::Foo->meta->has_method('bar'), '... it still has the bar method');
+ok(Role::Foo->meta->requires_method('foo'), '... it still has the required foo method');
+
+ok(Role::Bar->meta->has_method('foo'), '... it still has the foo method');
+ok(Role::Bar->meta->requires_method('bar'), '... it still has the required bar method');
+
+=pod
+
+Role method conflicts
+
+=cut
+
+{
+    package Role::Bling;
+    use strict;
+    use warnings;
+    use Moose::Role;
+    
+    sub bling { 'Role::Bling::bling' }
+    
+    package Role::Bling::Bling;
+    use strict;
+    use warnings;
+    use Moose::Role;
+    
+    sub bling { 'Role::Bling::Bling::bling' }    
+}
+
+{
+    package My::Test3;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::throws_ok {
+        with 'Role::Bling', 'Role::Bling::Bling';
+    } qr/requires the method \'bling\' to be implemented/, '... role methods conflicted and method was required';
+    
+    package My::Test4;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'Role::Bling';
+        with 'Role::Bling::Bling';
+    } '... role methods didnt conflict when manually combined';    
+    
+    package My::Test5;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'Role::Bling::Bling';
+        with 'Role::Bling';
+    } '... role methods didnt conflict when manually combined (in opposite order)';    
+    
+    package My::Test6;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'Role::Bling::Bling', 'Role::Bling';
+    } '... role methods didnt conflict when manually resolved';    
+    
+    sub bling { 'My::Test6::bling' }
+}
+
+ok(!My::Test3->meta->has_method('bling'), '... we didnt get any methods in the conflict');
+ok(My::Test4->meta->has_method('bling'), '... we did get the method when manually dealt with');
+ok(My::Test5->meta->has_method('bling'), '... we did get the method when manually dealt with');
+ok(My::Test6->meta->has_method('bling'), '... we did get the method when manually dealt with');
+
+is(My::Test4->bling, 'Role::Bling::bling', '... and we got the first method that was added');
+is(My::Test5->bling, 'Role::Bling::Bling::bling', '... and we got the first method that was added');
+is(My::Test6->bling, 'My::Test6::bling', '... and we got the local method');
+
+# check how this affects role compostion
+
+{
+    package Role::Bling::Bling::Bling;
+    use strict;
+    use warnings;
+    use Moose::Role;
+    
+    with 'Role::Bling::Bling';
+    
+    sub bling { 'Role::Bling::Bling::Bling::bling' }    
+}
+
+ok(Role::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling');
+ok(Role::Bling::Bling::Bling->meta->has_method('bling'), '... still got the bling method in Role::Bling::Bling::Bling');
+
+=pod
+
+Role attribute conflicts
+
+=cut
+
+{
+    package Role::Boo;
+    use strict;
+    use warnings;
+    use Moose::Role;
+    
+    has 'ghost' => (is => 'ro', default => 'Role::Boo::ghost');
+    
+    package Role::Boo::Hoo;
+    use strict;
+    use warnings;
+    use Moose::Role;
+    
+    has 'ghost' => (is => 'ro', default => 'Role::Boo::Hoo::ghost');
+}
+
+{
+    package My::Test7;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::throws_ok {
+        with 'Role::Boo', 'Role::Boo::Hoo';
+    } qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/, 
+      '... role attrs conflicted and method was required';
+
+    package My::Test8;
+    use strict;
+    use warnings;
+    use Moose;
+
+    ::lives_ok {
+        with 'Role::Boo';
+        with 'Role::Boo::Hoo';
+    } '... role attrs didnt conflict when manually combined';
+    
+    package My::Test9;
+    use strict;
+    use warnings;
+    use Moose;
+
+    ::lives_ok {
+        with 'Role::Boo::Hoo';
+        with 'Role::Boo';
+    } '... role attrs didnt conflict when manually combined';    
+
+    package My::Test10;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    has 'ghost' => (is => 'ro', default => 'My::Test10::ghost');    
+    
+    ::throws_ok {
+        with 'Role::Boo', 'Role::Boo::Hoo';
+    } qr/Role \'Role::Boo::Hoo\' has encountered an attribute conflict/, 
+      '... role attrs conflicted and cannot be manually disambiguted';  
+
+}
+
+ok(!My::Test7->meta->has_attribute('ghost'), '... we didnt get any attributes in the conflict');
+ok(My::Test8->meta->has_attribute('ghost'), '... we did get an attributes when manually composed');
+ok(My::Test9->meta->has_attribute('ghost'), '... we did get an attributes when manually composed');
+ok(My::Test10->meta->has_attribute('ghost'), '... we did still have an attribute ghost (conflict does not mess with class)');
+
+can_ok('My::Test8', 'ghost');
+can_ok('My::Test9', 'ghost');
+can_ok('My::Test10', 'ghost');
+
+is(My::Test8->new->ghost, 'Role::Boo::ghost', '... got the expected default attr value');
+is(My::Test9->new->ghost, 'Role::Boo::Hoo::ghost', '... got the expected default attr value');
+is(My::Test10->new->ghost, 'My::Test10::ghost', '... got the expected default attr value');
+
+
+
diff --git a/t/045_role_composition_w_conflicts.t b/t/045_role_composition_w_conflicts.t
new file mode 100644
index 0000000..a7d1333
--- /dev/null
+++ b/t/045_role_composition_w_conflicts.t
@@ -0,0 +1,12 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2;
+use Test::Exception;
+
+BEGIN {  
+    use_ok('Moose');
+    use_ok('Moose::Role');
+}
\ No newline at end of file
diff --git a/t/203_example.t b/t/203_example.t
new file mode 100644
index 0000000..dac32f9
--- /dev/null
+++ b/t/203_example.t
@@ -0,0 +1,176 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 32;
+use Test::Exception;
+
+BEGIN {  
+    use_ok('Moose');
+    use_ok('Moose::Role');
+}
+
+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 strict;
+    use warnings;
+    use Moose::Role;
+    
+    has '_list' => (
+        is       => 'ro',
+        isa      => 'ArrayRef', 
+        init_arg => '::',
+        default  => sub { [] }
+    );
+    
+    sub head { (shift)->_list->[0] }
+    sub tail {
+        my $self = shift;
+        $self->new(
+            '::' => [ 
+                @{$self->_list}[1 .. $#{$self->_list}] 
+            ]
+        );
+    }  
+    
+    sub print {
+        join ", " => @{$_[0]->_list};
+    }     
+    
+    package List::Immutable;
+    use strict;
+    use warnings;
+    use Moose::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 $list->new('::' => $acc) 
+                    if $list->is_empty;
+                $redo->(
+                    $list->tail, 
+                    $func,
+                    [ @{$acc}, $func->($list->head) ]
+                );
+            }
+        }))->($self, $function, []);        
+    }
+    
+    package My::List1;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    ::lives_ok {
+        with 'List', 'List::Immutable';
+    } '... successfully composed roles together';
+    
+    package My::List2;
+    use strict;
+    use warnings;
+    use Moose;    
+    
+    ::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');     
+}
+
+
+
+
+
+
+
+