latest sync-ed up c3.patch against perl-current
[gitmo/Class-C3.git] / lib / Class / C3 / PurePerl.pm
CommitLineData
ecb0388d 1
2package Class::C3::PurePerl;
3
4our $VERSION = '0.15';
5
6=pod
7
8=head1 NAME
9
10Class::C3::PurePerl - The default pure-Perl implementation of Class::C3
11
12=head1 DESCRIPTION
13
14This is the plain pure-Perl implementation of Class::C3. The main Class::C3 package will
15first attempt to load L<Class::C3::XS>, and then failing that, will fall back to this. Do
16not use this package directly, use L<Class::C3> instead.
17
18=head1 AUTHOR
19
20Stevan Little, E<lt>stevan@iinteractive.comE<gt>
21
22Brandon L. Black, E<lt>blblack@gmail.comE<gt>
23
24=head1 COPYRIGHT AND LICENSE
25
26Copyright 2005, 2006 by Infinity Interactive, Inc.
27
28L<http://www.iinteractive.com>
29
30This library is free software; you can redistribute it and/or modify
31it under the same terms as Perl itself.
32
33=cut
34
35package # hide me from PAUSE
36 Class::C3;
37
38use strict;
39use warnings;
40
41use Scalar::Util 'blessed';
7f657ca3 42
43our $VERSION = '0.15';
44our $C3_IN_CORE;
45
46BEGIN {
47 eval "require mro";
48 if($@) {
49 eval "require Algorithm::C3";
50 die "Could not load 'mro' or 'Algorithm::C3'!" if $@;
51 }
52 else {
53 $C3_IN_CORE = 1;
54 }
55}
ecb0388d 56
57# this is our global stash of both
58# MRO's and method dispatch tables
59# the structure basically looks like
60# this:
61#
62# $MRO{$class} = {
63# MRO => [ <class precendence list> ],
64# methods => {
65# orig => <original location of method>,
66# code => \&<ref to original method>
67# },
68# has_overload_fallback => (1 | 0)
69# }
70#
71our %MRO;
72
73# use these for debugging ...
74sub _dump_MRO_table { %MRO }
75our $TURN_OFF_C3 = 0;
76
77# state tracking for initialize()/uninitialize()
78our $_initialized = 0;
79
80sub import {
81 my $class = caller();
82 # skip if the caller is main::
83 # since that is clearly not relevant
84 return if $class eq 'main';
7f657ca3 85
ecb0388d 86 return if $TURN_OFF_C3;
7f657ca3 87 mro::set_mro_c3($class) if $C3_IN_CORE;
88
ecb0388d 89 # make a note to calculate $class
90 # during INIT phase
91 $MRO{$class} = undef unless exists $MRO{$class};
92}
93
94## initializers
95
96sub initialize {
7f657ca3 97 %next::METHOD_CACHE = ();
ecb0388d 98 # why bother if we don't have anything ...
99 return unless keys %MRO;
7f657ca3 100 if($C3_IN_CORE) {
101 mro::set_mro_c3($_) for keys %MRO;
102 }
103 else {
104 if($_initialized) {
105 uninitialize();
106 $MRO{$_} = undef foreach keys %MRO;
107 }
108 _calculate_method_dispatch_tables();
109 _apply_method_dispatch_tables();
110 $_initialized = 1;
ecb0388d 111 }
ecb0388d 112}
113
114sub uninitialize {
115 # why bother if we don't have anything ...
ecb0388d 116 %next::METHOD_CACHE = ();
7f657ca3 117 return unless keys %MRO;
118 if($C3_IN_CORE) {
119 mro::set_mro_dfs($_) for keys %MRO;
120 }
121 else {
122 _remove_method_dispatch_tables();
123 $_initialized = 0;
124 }
ecb0388d 125}
126
127sub reinitialize { goto &initialize }
128
129## functions for applying C3 to classes
130
131sub _calculate_method_dispatch_tables {
7f657ca3 132 return if $C3_IN_CORE;
ecb0388d 133 my %merge_cache;
134 foreach my $class (keys %MRO) {
135 _calculate_method_dispatch_table($class, \%merge_cache);
136 }
137}
138
139sub _calculate_method_dispatch_table {
7f657ca3 140 return if $C3_IN_CORE;
ecb0388d 141 my ($class, $merge_cache) = @_;
142 no strict 'refs';
143 my @MRO = calculateMRO($class, $merge_cache);
144 $MRO{$class} = { MRO => \@MRO };
145 my $has_overload_fallback = 0;
146 my %methods;
147 # NOTE:
148 # we do @MRO[1 .. $#MRO] here because it
149 # makes no sense to interogate the class
150 # which you are calculating for.
151 foreach my $local (@MRO[1 .. $#MRO]) {
152 # if overload has tagged this module to
153 # have use "fallback", then we want to
154 # grab that value
155 $has_overload_fallback = ${"${local}::()"}
156 if defined ${"${local}::()"};
157 foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
158 # skip if already overriden in local class
159 next unless !defined *{"${class}::$method"}{CODE};
160 $methods{$method} = {
161 orig => "${local}::$method",
162 code => \&{"${local}::$method"}
163 } unless exists $methods{$method};
164 }
165 }
166 # now stash them in our %MRO table
167 $MRO{$class}->{methods} = \%methods;
168 $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
169}
170
171sub _apply_method_dispatch_tables {
7f657ca3 172 return if $C3_IN_CORE;
ecb0388d 173 foreach my $class (keys %MRO) {
174 _apply_method_dispatch_table($class);
175 }
176}
177
178sub _apply_method_dispatch_table {
7f657ca3 179 return if $C3_IN_CORE;
ecb0388d 180 my $class = shift;
181 no strict 'refs';
182 ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
183 if $MRO{$class}->{has_overload_fallback};
184 foreach my $method (keys %{$MRO{$class}->{methods}}) {
185 *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
186 }
187}
188
189sub _remove_method_dispatch_tables {
7f657ca3 190 return if $C3_IN_CORE;
ecb0388d 191 foreach my $class (keys %MRO) {
192 _remove_method_dispatch_table($class);
193 }
194}
195
196sub _remove_method_dispatch_table {
7f657ca3 197 return if $C3_IN_CORE;
ecb0388d 198 my $class = shift;
199 no strict 'refs';
200 delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
201 foreach my $method (keys %{$MRO{$class}->{methods}}) {
202 delete ${"${class}::"}{$method}
203 if defined *{"${class}::${method}"}{CODE} &&
204 (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
205 }
206}
207
208## functions for calculating C3 MRO
209
210sub calculateMRO {
211 my ($class, $merge_cache) = @_;
7f657ca3 212
213 return @{mro::get_mro_linear_c3($class)} if $C3_IN_CORE;
214
ecb0388d 215 return Algorithm::C3::merge($class, sub {
216 no strict 'refs';
217 @{$_[0] . '::ISA'};
218 }, $merge_cache);
219}
220
221package # hide me from PAUSE
222 next;
223
224use strict;
225use warnings;
226
ecb0388d 227use Scalar::Util 'blessed';
228
7f657ca3 229our $VERSION = '0.06';
230
ecb0388d 231our %METHOD_CACHE;
232
233sub method {
7f657ca3 234 my $self = $_[0];
235 my $class = blessed($self) || $self;
ecb0388d 236 my $indirect = caller() =~ /^(?:next|maybe::next)$/;
237 my $level = $indirect ? 2 : 1;
238
239 my ($method_caller, $label, @label);
240 while ($method_caller = (caller($level++))[3]) {
241 @label = (split '::', $method_caller);
242 $label = pop @label;
243 last unless
244 $label eq '(eval)' ||
245 $label eq '__ANON__';
246 }
7f657ca3 247
248 my $method;
249
ecb0388d 250 my $caller = join '::' => @label;
ecb0388d 251
7f657ca3 252 $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
ecb0388d 253
254 my @MRO = Class::C3::calculateMRO($class);
255
256 my $current;
257 while ($current = shift @MRO) {
258 last if $caller eq $current;
259 }
260
261 no strict 'refs';
262 my $found;
263 foreach my $class (@MRO) {
264 next if (defined $Class::C3::MRO{$class} &&
265 defined $Class::C3::MRO{$class}{methods}{$label});
266 last if (defined ($found = *{$class . '::' . $label}{CODE}));
267 }
7f657ca3 268
ecb0388d 269 $found;
270 };
271
272 return $method if $indirect;
273
274 die "No next::method '$label' found for $self" if !$method;
275
276 goto &{$method};
277}
278
279sub can { method($_[0]) }
280
281package # hide me from PAUSE
282 maybe::next;
283
284use strict;
285use warnings;
286
7f657ca3 287our $VERSION = '0.02';
ecb0388d 288
289sub method { (next::method($_[0]) || return)->(@_) }
290
2911;