2 package Class::C3::PurePerl;
10 Class::C3::PurePerl - The default pure-Perl implementation of Class::C3
14 This is the plain pure-Perl implementation of Class::C3. The main Class::C3 package will
15 first attempt to load L<Class::C3::XS>, and then failing that, will fall back to this. Do
16 not use this package directly, use L<Class::C3> instead.
20 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
22 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
24 =head1 COPYRIGHT AND LICENSE
26 Copyright 2005, 2006 by Infinity Interactive, Inc.
28 L<http://www.iinteractive.com>
30 This library is free software; you can redistribute it and/or modify
31 it under the same terms as Perl itself.
35 package # hide me from PAUSE
41 use Scalar::Util 'blessed';
43 our $VERSION = '0.15';
47 eval "require mro"; # XXX in the future, this should be a version check
49 eval "require Algorithm::C3";
50 die "No core C3 support and could not load 'Algorithm::C3'!" if $@;
51 eval "require Class::C3::PurePerl::next";
52 die "No core C3 support and could not load 'Class::C3::PurePerl::next'!" if $@;
59 # this is our global stash of both
60 # MRO's and method dispatch tables
61 # the structure basically looks like
65 # MRO => [ <class precendence list> ],
67 # orig => <original location of method>,
68 # code => \&<ref to original method>
70 # has_overload_fallback => (1 | 0)
75 # use these for debugging ...
76 sub _dump_MRO_table { %MRO }
79 # state tracking for initialize()/uninitialize()
80 our $_initialized = 0;
84 # skip if the caller is main::
85 # since that is clearly not relevant
86 return if $class eq 'main';
88 return if $TURN_OFF_C3;
89 mro::set_mro($class, 'c3') if $C3_IN_CORE;
91 # make a note to calculate $class
93 $MRO{$class} = undef unless exists $MRO{$class};
99 %next::METHOD_CACHE = ();
100 # why bother if we don't have anything ...
101 return unless keys %MRO;
103 mro::set_mro($_, 'c3') for keys %MRO;
108 $MRO{$_} = undef foreach keys %MRO;
110 _calculate_method_dispatch_tables();
111 _apply_method_dispatch_tables();
117 # why bother if we don't have anything ...
118 %next::METHOD_CACHE = ();
119 return unless keys %MRO;
121 mro::set_mro($_, 'dfs') for keys %MRO;
124 _remove_method_dispatch_tables();
129 sub reinitialize { goto &initialize }
131 ## functions for applying C3 to classes
133 sub _calculate_method_dispatch_tables {
134 return if $C3_IN_CORE;
136 foreach my $class (keys %MRO) {
137 _calculate_method_dispatch_table($class, \%merge_cache);
141 sub _calculate_method_dispatch_table {
142 return if $C3_IN_CORE;
143 my ($class, $merge_cache) = @_;
145 my @MRO = calculateMRO($class, $merge_cache);
146 $MRO{$class} = { MRO => \@MRO };
147 my $has_overload_fallback = 0;
150 # we do @MRO[1 .. $#MRO] here because it
151 # makes no sense to interogate the class
152 # which you are calculating for.
153 foreach my $local (@MRO[1 .. $#MRO]) {
154 # if overload has tagged this module to
155 # have use "fallback", then we want to
157 $has_overload_fallback = ${"${local}::()"}
158 if defined ${"${local}::()"};
159 foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
160 # skip if already overriden in local class
161 next unless !defined *{"${class}::$method"}{CODE};
162 $methods{$method} = {
163 orig => "${local}::$method",
164 code => \&{"${local}::$method"}
165 } unless exists $methods{$method};
168 # now stash them in our %MRO table
169 $MRO{$class}->{methods} = \%methods;
170 $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
173 sub _apply_method_dispatch_tables {
174 return if $C3_IN_CORE;
175 foreach my $class (keys %MRO) {
176 _apply_method_dispatch_table($class);
180 sub _apply_method_dispatch_table {
181 return if $C3_IN_CORE;
184 ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
185 if $MRO{$class}->{has_overload_fallback};
186 foreach my $method (keys %{$MRO{$class}->{methods}}) {
187 *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
191 sub _remove_method_dispatch_tables {
192 return if $C3_IN_CORE;
193 foreach my $class (keys %MRO) {
194 _remove_method_dispatch_table($class);
198 sub _remove_method_dispatch_table {
199 return if $C3_IN_CORE;
202 delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
203 foreach my $method (keys %{$MRO{$class}->{methods}}) {
204 delete ${"${class}::"}{$method}
205 if defined *{"${class}::${method}"}{CODE} &&
206 (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
210 ## functions for calculating C3 MRO
213 my ($class, $merge_cache) = @_;
215 return @{mro::get_linear_isa($class)} if $C3_IN_CORE;
217 return Algorithm::C3::merge($class, sub {