From: Stevan Little <stevan.little@iinteractive.com>
Date: Mon, 27 Feb 2006 14:42:56 +0000 (+0000)
Subject: uploadin
X-Git-Tag: 0_20~9
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=72c210741ee3aac7aa37579b16e099d5376c62a4;p=gitmo%2FClass-MOP.git

uploadin
---

diff --git a/lib/Class/MOP/SafeMixin.pm b/lib/Class/MOP/SafeMixin.pm
index ff9dc9c..d2a7112 100644
--- a/lib/Class/MOP/SafeMixin.pm
+++ b/lib/Class/MOP/SafeMixin.pm
@@ -4,11 +4,60 @@ package Class::MOP::SafeMixin;
 use strict;
 use warnings;
 
+use Scalar::Util 'blessed';
+use Carp         'confess';
+
 our $VERSION = '0.01';
 
-sub meta { 
-    require Class::MOP::Class;
-    Class::MOP::Class->initialize(blessed($_[0]) || $_[0]);
+use base 'Class::MOP::Class';
+
+sub mixin {
+    # fetch the metaclass for the 
+    # caller and the mixin arg
+    my $metaclass = shift;
+    my $mixin     = (shift)->meta;
+    
+    # according to Scala, the 
+    # the superclass of our class
+    # must be a subclass of the 
+    # superclass of the mixin (see above)
+    my ($super_meta)  = $metaclass->superclasses();
+    my ($super_mixin) = $mixin->superclasses();  
+    ($super_meta->isa($super_mixin))
+        || confess "The superclass must extend a subclass of the superclass of the mixin"
+			if defined $super_mixin && defined $super_meta;
+    
+    # collect all the attributes
+    # and clone them so they can 
+    # associate with the new class
+    my @attributes = map { 
+        $mixin->get_attribute($_)->clone() 
+    } $mixin->get_attribute_list;                     
+    
+    my %methods = map  { 
+        my $method = $mixin->get_method($_);
+        # we want to ignore accessors since
+        # they will be created with the attrs
+        (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'))
+            ? () : ($_ => $method)
+    } $mixin->get_method_list;    
+
+    # NOTE:
+    # I assume that locally defined methods 
+    # and attributes get precedence over those
+    # from the mixin.
+
+    # add all the attributes in ....
+    foreach my $attr (@attributes) {
+        $metaclass->add_attribute($attr) 
+            unless $metaclass->has_attribute($attr->name);
+    }
+
+    # add all the methods in ....    
+    foreach my $method_name (keys %methods) {
+        $metaclass->alias_method($method_name => $methods{$method_name}) 
+            unless $metaclass->has_method($method_name);
+    }    
 }
 
 1;
diff --git a/t/300_basic_safe_mixin.t b/t/300_basic_safe_mixin.t
new file mode 100644
index 0000000..0694821
--- /dev/null
+++ b/t/300_basic_safe_mixin.t
@@ -0,0 +1,57 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+
+BEGIN {
+    use_ok('Class::MOP');
+    use_ok('Class::MOP::SafeMixin');
+}
+
+## Mixin a class without a superclass.
+{
+    package FooMixin;   
+	use metaclass;
+    sub foo { 'FooMixin::foo' }    
+
+    package Foo;
+    use metaclass 'Class::MOP::SafeMixin';
+    Foo->meta->mixin('FooMixin');
+    sub new { (shift)->meta->new_object(@_) }
+}
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+can_ok($foo, 'foo');
+is($foo->foo, 'FooMixin::foo', '... got the right value from the mixin method');
+
+## Mixin a class who shares a common ancestor
+{   
+    package Baz;
+    our @ISA = ('Foo');    
+    sub baz { 'Baz::baz' }    	
+
+    package Bar;
+    our @ISA = ('Foo');
+
+	package Foo::Bar;
+    our @ISA = ('Foo', 'Bar');	
+
+    package Foo::Bar::Baz;
+    our @ISA = ('Foo::Bar');    
+	eval { Foo::Bar::Baz->meta->mixin('Baz') };
+	::ok(!$@, '... the classes superclass must extend a subclass of the superclass of the mixins');
+}
+
+my $foo_bar_baz = Foo::Bar::Baz->new();
+isa_ok($foo_bar_baz, 'Foo::Bar::Baz');
+isa_ok($foo_bar_baz, 'Foo::Bar');
+isa_ok($foo_bar_baz, 'Foo');
+isa_ok($foo_bar_baz, 'Bar');
+
+can_ok($foo_bar_baz, 'baz');
+is($foo_bar_baz->baz(), 'Baz::baz', '... got the right value from the mixin method');
+
diff --git a/t/301_safe_mixin_decorators.t b/t/301_safe_mixin_decorators.t
new file mode 100644
index 0000000..777c318
--- /dev/null
+++ b/t/301_safe_mixin_decorators.t
@@ -0,0 +1,58 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 1;
+
+BEGIN {
+    use_ok('Class::MOP');
+    use_ok('Class::MOP::SafeMixin');
+}
+
+{
+    package FooMixin;   
+	use metaclass;
+	
+	my %cache;
+	sub MODIFY_CODE_ATTRIBUTES {
+		my ($class, $code, @attrs) = @_;
+		::diag join ", " => $code, "Attrs: ", @attrs;
+		$cache{$code} = $attrs[0];
+		return ();	
+	}	
+	
+	sub FETCH_CODE_ATTRIBUTES { $cache{$_[1]} }
+	
+    sub foo : before { 'FooMixin::foo::before -> ' }    
+    sub bar : after  { ' -> FooMixin::bar::after'  }    
+    sub baz : around { 
+		my $method = shift;
+		my ($self, @args) = @_;
+		'FooMixin::baz::around(' . $self->$method(@args) . ')'; 
+	}            
+
+    package Foo;
+    use metaclass 'Class::MOP::SafeMixin';
+
+    Foo->meta->mixin('FooMixin');
+    
+    sub new { (shift)->meta->new_object(@_) }
+    
+    sub foo { 'Foo::foo' }
+    sub bar { 'Foo::bar' }
+    sub baz { 'Foo::baz' }        
+}
+
+diag attributes::get(\&FooMixin::foo) . "\n";
+
+my $foo = Foo->new();
+isa_ok($foo, 'Foo');
+
+is($foo->foo(), 'FooMixin::foo::before -> Foo::foo', '... before method worked');
+is($foo->bar(), 'Foo::bar -> FooMixin::bar::after', '... after method worked');
+is($foo->baz(), 'FooMixin::baz::around(Foo::baz)', '... around method worked');
+
+
+
+