From: Stevan Little <stevan.little@iinteractive.com>
Date: Thu, 23 Mar 2006 19:38:15 +0000 (+0000)
Subject: inner-augment-super-override
X-Git-Tag: 0_05~64
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b6fe348f5448b52cad0f52ecdb52fa18af054323;p=gitmo%2FMoose.git

inner-augment-super-override
---

diff --git a/MANIFEST b/MANIFEST
index 3dc5618..d90b814 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -21,6 +21,8 @@ t/005_basic.t
 t/006_basic.t
 t/010_basic_class_setup.t
 t/011_require_superclasses.t
+t/012_super_and_override.t
+t/013_inner_and_augment.t
 t/020_foreign_inheritence.t
 t/050_util_type_constraints.t
 t/051_util_type_constraints_export.t
diff --git a/lib/Moose.pm b/lib/Moose.pm
index 5ae01f6..58d431d 100644
--- a/lib/Moose.pm
+++ b/lib/Moose.pm
@@ -115,6 +115,36 @@ sub import {
 		my $code = pop @_;
 		$meta->add_around_method_modifier($_, $code) for @_;	
 	});	
+	
+	$meta->alias_method('super' => subname 'Moose::super' => sub {});
+	$meta->alias_method('override' => subname 'Moose::override' => sub {
+	    my ($name, $method) = @_;
+	    my $super = $meta->find_next_method_by_name($name);
+	    (defined $super)
+	        || confess "You cannot override '$name' because it has no super method";
+	    $meta->add_method($name => sub {
+	        my @args = @_;
+            no strict   'refs';
+            no warnings 'redefine';
+            local *{$meta->name . '::super'} = sub { $super->(@args) };
+	        return $method->(@args);
+	    });
+	});		
+	
+	$meta->alias_method('inner' => subname 'Moose::inner' => sub {});
+	$meta->alias_method('augment' => subname 'Moose::augment' => sub {
+	    my ($name, $method) = @_;
+	    my $super = $meta->find_next_method_by_name($name);
+	    (defined $super)
+	        || confess "You cannot augment '$name' because it has no super method";
+	    $meta->add_method($name => sub {
+	        my @args = @_;
+            no strict   'refs';
+            no warnings 'redefine';
+            local *{$super->package_name . '::inner'} = sub { $method->(@args) };
+	        return $super->(@args);
+	    });
+	});	
 
 	# make sure they inherit from Moose::Object
 	$meta->superclasses('Moose::Object')
diff --git a/t/004_basic.t b/t/004_basic.t
index 7471289..4dd9fa3 100644
--- a/t/004_basic.t
+++ b/t/004_basic.t
@@ -94,6 +94,11 @@ BEGIN {
     
     has 'title'   => (is => 'rw', isa => 'Str');
     has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1);  
+    
+    override 'full_name' => sub {
+        my $self = shift;
+        super() . ', ' . $self->title
+    };
 }
 
 my $ii;
@@ -156,7 +161,7 @@ is($ii->employees->[0]->first_name, 'Jeremy', '... got the right first name');
 is($ii->employees->[0]->last_name, 'Shao', '... got the right last name');
 ok(!$ii->employees->[0]->has_middle_initial, '... no middle initial');
 is($ii->employees->[0]->middle_initial, undef, '... got the right middle initial value');
-is($ii->employees->[0]->full_name, 'Jeremy Shao', '... got the right full name');
+is($ii->employees->[0]->full_name, 'Jeremy Shao, President / Senior Consultant', '... got the right full name');
 is($ii->employees->[0]->title, 'President / Senior Consultant', '... got the right title');
 is($ii->employees->[0]->company, $ii, '... got the right company');
 ok(isweak($ii->employees->[0]->{company}), '... the company is a weak-ref');
@@ -174,7 +179,7 @@ is($ii->employees->[1]->first_name, 'Tommy', '... got the right first name');
 is($ii->employees->[1]->last_name, 'Lee', '... got the right last name');
 ok(!$ii->employees->[1]->has_middle_initial, '... no middle initial');
 is($ii->employees->[1]->middle_initial, undef, '... got the right middle initial value');
-is($ii->employees->[1]->full_name, 'Tommy Lee', '... got the right full name');
+is($ii->employees->[1]->full_name, 'Tommy Lee, Vice President / Senior Developer', '... got the right full name');
 is($ii->employees->[1]->title, 'Vice President / Senior Developer', '... got the right title');
 is($ii->employees->[1]->company, $ii, '... got the right company');
 ok(isweak($ii->employees->[1]->{company}), '... the company is a weak-ref');
@@ -192,7 +197,7 @@ is($ii->employees->[2]->first_name, 'Stevan', '... got the right first name');
 is($ii->employees->[2]->last_name, 'Little', '... got the right last name');
 ok($ii->employees->[2]->has_middle_initial, '... got middle initial');
 is($ii->employees->[2]->middle_initial, 'C', '... got the right middle initial value');
-is($ii->employees->[2]->full_name, 'Stevan C. Little', '... got the right full name');
+is($ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer', '... got the right full name');
 is($ii->employees->[2]->title, 'Senior Developer', '... got the right title');
 is($ii->employees->[2]->company, $ii, '... got the right company');
 ok(isweak($ii->employees->[2]->{company}), '... the company is a weak-ref');
@@ -210,7 +215,7 @@ is($ii->employees->[3]->first_name, 'Rob', '... got the right first name');
 is($ii->employees->[3]->last_name, 'Kinyon', '... got the right last name');
 ok(!$ii->employees->[3]->has_middle_initial, '... got middle initial');
 is($ii->employees->[3]->middle_initial, undef, '... got the right middle initial value');
-is($ii->employees->[3]->full_name, 'Rob Kinyon', '... got the right full name');
+is($ii->employees->[3]->full_name, 'Rob Kinyon, Developer', '... got the right full name');
 is($ii->employees->[3]->title, 'Developer', '... got the right title');
 is($ii->employees->[3]->company, $ii, '... got the right company');
 ok(isweak($ii->employees->[3]->{company}), '... the company is a weak-ref');
diff --git a/t/012_super_and_override.t b/t/012_super_and_override.t
new file mode 100644
index 0000000..a58e3b9
--- /dev/null
+++ b/t/012_super_and_override.t
@@ -0,0 +1,48 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+BEGIN {
+    use_ok('Moose');           
+}
+
+{
+    package Foo;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    sub foo { 'Foo::foo' }
+    sub bar { 'Foo::bar' }    
+    sub baz { 'Foo::baz' }
+    
+    package Bar;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    extends 'Foo';
+    
+    override bar => sub { 'Bar::bar -> ' . super() };   
+    
+    package Baz;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    extends 'Bar';
+    
+    override baz => sub { 'Baz::baz -> ' . super() }; 
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+is($baz->foo(), 'Foo::foo', '... got the right value from &foo');
+is($baz->bar(), 'Bar::bar -> Foo::bar', '... got the right value from &bar');
+is($baz->baz(), 'Baz::baz -> Foo::baz', '... got the right value from &baz');
diff --git a/t/013_inner_and_augment.t b/t/013_inner_and_augment.t
new file mode 100644
index 0000000..15a73a5
--- /dev/null
+++ b/t/013_inner_and_augment.t
@@ -0,0 +1,51 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 7;
+
+BEGIN {
+    use_ok('Moose');           
+}
+
+{
+    package Foo;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    sub foo { 'Foo::foo(' . inner() . ')' }
+    sub bar { 'Foo::bar(' . inner() . ')' }    
+    sub baz { 'Foo::baz(' . inner() . ')' }        
+    
+    package Bar;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    extends 'Foo';
+    
+    augment foo => sub { 'Bar::foo(' . inner() . ')' };   
+    augment bar => sub { 'Bar::bar' };       
+    
+    package Baz;
+    use strict;
+    use warnings;
+    use Moose;
+    
+    extends 'Bar';
+    
+    augment foo => sub { 'Baz::foo' }; 
+    augment baz => sub { 'Baz::baz' };       
+}
+
+my $baz = Baz->new();
+isa_ok($baz, 'Baz');
+isa_ok($baz, 'Bar');
+isa_ok($baz, 'Foo');
+
+is($baz->foo(), 'Foo::foo(Bar::foo(Baz::foo))', '... got the right value from &foo');
+is($baz->bar(), 'Foo::bar(Bar::bar)', '... got the right value from &bar');
+is($baz->baz(), 'Foo::baz(Baz::baz)', '... got the right value from &baz');
+