making the init_arg even more silly
[gitmo/Class-MOP.git] / examples / C3MethodDispatchOrder.pod
CommitLineData
f3f5bd34 1
2package # hide from PAUSE
3 C3MethodDispatchOrder;
4
5use strict;
6use warnings;
7
8use Carp 'confess';
9use Algorithm::C3;
10
2f6d5412 11our $VERSION = '0.03';
f3f5bd34 12
13use base 'Class::MOP::Class';
14
96ceced8 15my $_find_method = sub {
f3f5bd34 16 my ($class, $method) = @_;
17 foreach my $super ($class->class_precedence_list) {
18 return $super->meta->get_method($method)
19 if $super->meta->has_method($method);
20 }
21};
22
a4258ffd 23C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub {
24 my $cont = shift;
25 my $meta = $cont->(@_);
f3f5bd34 26 $meta->add_method('AUTOLOAD' => sub {
27 my $meta = $_[0]->meta;
28 my $method_name;
29 {
30 no strict 'refs';
31 my $label = ${$meta->name . '::AUTOLOAD'};
32 $method_name = (split /\:\:/ => $label)[-1];
33 }
96ceced8 34 my $method = $_find_method->($meta, $method_name);
f3f5bd34 35 (defined $method) || confess "Method ($method_name) not found";
36 goto &$method;
2f6d5412 37 }) unless $meta->has_method('AUTOLOAD');
f3f5bd34 38 $meta->add_method('can' => sub {
96ceced8 39 $_find_method->($_[0]->meta, $_[1]);
6d5355c3 40 }) unless $meta->has_method('can');
a4258ffd 41 return $meta;
42});
f3f5bd34 43
44sub superclasses {
45 my $self = shift;
6d5355c3 46
58d75218 47 $self->add_package_symbol('@SUPERS' => [])
48 unless $self->has_package_symbol('@SUPERS');
6d5355c3 49
f3f5bd34 50 if (@_) {
51 my @supers = @_;
58d75218 52 @{$self->get_package_symbol('@SUPERS')} = @supers;
f3f5bd34 53 }
58d75218 54 @{$self->get_package_symbol('@SUPERS')};
f3f5bd34 55}
56
57sub class_precedence_list {
58 my $self = shift;
59 return map {
60 $_->name;
61 } Algorithm::C3::merge($self, sub {
62 my $class = shift;
63 map { $_->meta } $class->superclasses;
64 });
65}
66
671;
68
69__END__
70
71=pod
72
73=head1 NAME
74
75C3MethodDispatchOrder - An example attribute metaclass for changing to C3 method dispatch order
76
77=head1 SYNOPSIS
78
79 # a classic diamond inheritence graph
80 #
81 # <A>
82 # / \
83 # <B> <C>
84 # \ /
85 # <D>
86
87 package A;
88 use metaclass 'C3MethodDispatchOrder';
89
90 sub hello { return "Hello from A" }
91
92 package B;
93 use metaclass 'C3MethodDispatchOrder';
94 B->meta->superclasses('A');
95
96 package C;
97 use metaclass 'C3MethodDispatchOrder';
98 C->meta->superclasses('A');
99
100 sub hello { return "Hello from C" }
101
102 package D;
103 use metaclass 'C3MethodDispatchOrder';
104 D->meta->superclasses('B', 'C');
105
106 print join ", " => D->meta->class_precedence_list; # prints C3 order D, B, C, A
107
108 # later in other code ...
109
110 print D->hello; # print 'Hello from C' instead of the normal 'Hello from A'
111
112=head1 DESCRIPTION
113
1c020571 114This is an example of how you could change the method dispatch order of a
115class using L<Class::MOP>. Using the L<Algorithm::C3> module, this repleces
116the normal depth-first left-to-right perl dispatch order with the C3 method
117dispatch order (see the L<Algorithm::C3> or L<Class::C3> docs for more
118information about this).
119
120This example could be used as a template for other method dispatch orders
121as well, all that is required is to write a the C<class_precedence_list> method
122which will return a linearized list of classes to dispatch along.
123
1a09d9cc 124=head1 AUTHORS
f3f5bd34 125
126Stevan Little E<lt>stevan@iinteractive.comE<gt>
127
1a09d9cc 128Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
129
f3f5bd34 130=head1 COPYRIGHT AND LICENSE
131
132Copyright 2006 by Infinity Interactive, Inc.
133
134L<http://www.iinteractive.com>
135
136This library is free software; you can redistribute it and/or modify
137it under the same terms as Perl itself.
138
139=cut