From: Stevan Little <stevan.little@iinteractive.com>
Date: Thu, 16 Feb 2006 19:51:15 +0000 (+0000)
Subject: adding in the C3 example
X-Git-Tag: 0_12~6
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f3f5bd3405b08b20ab8719ab7670277dd732c492;p=gitmo%2FClass-MOP.git

adding in the C3 example
---

diff --git a/Changes b/Changes
index 7cadf51..40b7f76 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,9 @@
 Revision history for Perl extension Class-MOP.
 
+0.11 
+    * examples/
+      - added example of changing method dispatch order to C3
+
 0.10 Tues Feb. 14, 2006
     ** This release was mostly about writing more tests and 
        cleaning out old and dusty code, the MOP should now 
diff --git a/MANIFEST b/MANIFEST
index 05ded22..1269db0 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -11,6 +11,7 @@ examples/InsideOutClass.pod
 examples/InstanceCountingClass.pod
 examples/LazyClass.pod
 examples/Perl6Attribute.pod
+examples/C3MethodDispatchOrder.pod
 lib/metaclass.pm
 lib/Class/MOP.pm
 lib/Class/MOP/Attribute.pm
@@ -43,6 +44,7 @@ t/103_Perl6Attribute_test.t
 t/104_AttributesWithHistory_test.t
 t/105_ClassEncapsulatedAttributes_test.t
 t/106_LazyClass_test.t
+t/107_C3MethodDispatchOrder_test.t
 t/200_Class_C3_compatibility.t
 t/pod.t
 t/pod_coverage.t
diff --git a/examples/C3MethodDispatchOrder.pod b/examples/C3MethodDispatchOrder.pod
new file mode 100644
index 0000000..a04e63c
--- /dev/null
+++ b/examples/C3MethodDispatchOrder.pod
@@ -0,0 +1,124 @@
+
+package # hide from PAUSE 
+    C3MethodDispatchOrder;
+    
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Algorithm::C3;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Class';
+
+my $_find_method_in_superclass = sub {
+    my ($class, $method) = @_;
+    foreach my $super ($class->class_precedence_list) {
+        return $super->meta->get_method($method)   
+            if $super->meta->has_method($method);
+    }
+};
+
+sub initialize {
+    my $class = shift;
+    my $meta  = $class->SUPER::initialize(@_);
+    $meta->add_method('AUTOLOAD' => sub {
+        my $meta = $_[0]->meta;
+        my $method_name;
+        {
+            no strict 'refs';
+            my $label = ${$meta->name . '::AUTOLOAD'};
+            $method_name = (split /\:\:/ => $label)[-1];
+        }
+        my $method = $_find_method_in_superclass->($meta, $method_name);
+        (defined $method) || confess "Method ($method_name) not found";
+        goto &$method;
+    });
+    $meta->add_method('can' => sub {
+        $_find_method_in_superclass->($_[0]->meta, $_[1]);
+    });
+    return $meta;
+}
+
+sub superclasses {
+    my $self = shift;
+    no strict 'refs';
+    if (@_) {
+        my @supers = @_;
+        @{$self->name . '::SUPERS'} = @supers;
+    }
+    @{$self->name . '::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
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 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
\ No newline at end of file
diff --git a/t/107_C3MethodDispatchOrder_test.t b/t/107_C3MethodDispatchOrder_test.t
new file mode 100644
index 0000000..d20f306
--- /dev/null
+++ b/t/107_C3MethodDispatchOrder_test.t
@@ -0,0 +1,43 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use File::Spec;
+
+BEGIN { 
+    use_ok('Class::MOP');    
+    require_ok(File::Spec->catdir('examples', 'C3MethodDispatchOrder.pod'));
+}
+
+{
+    package Diamond_A;
+    use metaclass 'C3MethodDispatchOrder'; 
+    
+    sub hello { 'Diamond_A::hello' }
+
+    package Diamond_B;
+    use metaclass 'C3MethodDispatchOrder'; 
+    __PACKAGE__->meta->superclasses('Diamond_A'); 
+    
+    package Diamond_C;
+    use metaclass 'C3MethodDispatchOrder';     
+    __PACKAGE__->meta->superclasses('Diamond_A');     
+    
+    sub hello { 'Diamond_C::hello' }
+
+    package Diamond_D;
+    use metaclass 'C3MethodDispatchOrder';     
+    __PACKAGE__->meta->superclasses('Diamond_B', 'Diamond_C');
+}
+
+is_deeply(
+    [ Diamond_D->meta->class_precedence_list ],
+    [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ],
+    '... got the right MRO for Diamond_D');
+
+is(Diamond_D->hello, 'Diamond_C::hello', '... got the right dispatch order');
+is(Diamond_D->can('hello')->(), 'Diamond_C::hello', '... can(method) resolved itself as expected');
+
+