10 Class::C3::XS - The XS implementation of Class::C3
14 This is the XS implementation of L<Class::C3>. The main L<Class::C3> package will
15 first attempt to load L<Class::C3::XS>, and then failing that, will fall back to
16 L<Class::C3::PurePerl>. Do 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';
44 # this is our global stash of both
45 # MRO's and method dispatch tables
46 # the structure basically looks like
50 # MRO => [ <class precendence list> ],
52 # orig => <original location of method>,
53 # code => \&<ref to original method>
55 # has_overload_fallback => (1 | 0)
60 # use these for debugging ...
61 sub _dump_MRO_table { %MRO }
64 # state tracking for initialize()/uninitialize()
65 our $_initialized = 0;
69 # skip if the caller is main::
70 # since that is clearly not relevant
71 return if $class eq 'main';
72 return if $TURN_OFF_C3;
73 # make a note to calculate $class
75 $MRO{$class} = undef unless exists $MRO{$class};
81 # why bother if we don't have anything ...
82 return unless keys %MRO;
85 $MRO{$_} = undef foreach keys %MRO;
87 _calculate_method_dispatch_tables();
88 _apply_method_dispatch_tables();
89 %next::METHOD_CACHE = ();
94 # why bother if we don't have anything ...
95 return unless keys %MRO;
96 _remove_method_dispatch_tables();
97 %next::METHOD_CACHE = ();
101 sub reinitialize { goto &initialize }
103 ## functions for applying C3 to classes
105 sub _calculate_method_dispatch_tables {
107 foreach my $class (keys %MRO) {
108 _calculate_method_dispatch_table($class, \%merge_cache);
112 sub _calculate_method_dispatch_table {
113 my ($class, $merge_cache) = @_;
115 my @MRO = calculateMRO($class, $merge_cache);
116 $MRO{$class} = { MRO => \@MRO };
117 my $has_overload_fallback = 0;
120 # we do @MRO[1 .. $#MRO] here because it
121 # makes no sense to interogate the class
122 # which you are calculating for.
123 foreach my $local (@MRO[1 .. $#MRO]) {
124 # if overload has tagged this module to
125 # have use "fallback", then we want to
127 $has_overload_fallback = ${"${local}::()"}
128 if defined ${"${local}::()"};
129 foreach my $method (grep { defined &{"${local}::$_"} } keys %{"${local}::"}) {
130 # skip if already overriden in local class
131 next unless !defined *{"${class}::$method"}{CODE};
132 $methods{$method} = {
133 orig => "${local}::$method",
134 code => \&{"${local}::$method"}
135 } unless exists $methods{$method};
138 # now stash them in our %MRO table
139 $MRO{$class}->{methods} = \%methods;
140 $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
143 sub _apply_method_dispatch_tables {
144 foreach my $class (keys %MRO) {
145 _apply_method_dispatch_table($class);
149 sub _apply_method_dispatch_table {
152 ${"${class}::()"} = $MRO{$class}->{has_overload_fallback}
153 if $MRO{$class}->{has_overload_fallback};
154 foreach my $method (keys %{$MRO{$class}->{methods}}) {
155 *{"${class}::$method"} = $MRO{$class}->{methods}->{$method}->{code};
159 sub _remove_method_dispatch_tables {
160 foreach my $class (keys %MRO) {
161 _remove_method_dispatch_table($class);
165 sub _remove_method_dispatch_table {
168 delete ${"${class}::"}{"()"} if $MRO{$class}->{has_overload_fallback};
169 foreach my $method (keys %{$MRO{$class}->{methods}}) {
170 delete ${"${class}::"}{$method}
171 if defined *{"${class}::${method}"}{CODE} &&
172 (*{"${class}::${method}"}{CODE} eq $MRO{$class}->{methods}->{$method}->{code});
176 ## functions for calculating C3 MRO
179 my ($class, $merge_cache) = @_;
180 return Algorithm::C3::merge($class, sub {
186 package # hide me from PAUSE
194 use Scalar::Util 'blessed';
199 my $indirect = caller() =~ /^(?:next|maybe::next)$/;
200 my $level = $indirect ? 2 : 1;
202 my ($method_caller, $label, @label);
203 while ($method_caller = (caller($level++))[3]) {
204 @label = (split '::', $method_caller);
207 $label eq '(eval)' ||
208 $label eq '__ANON__';
210 my $caller = join '::' => @label;
212 my $class = blessed($self) || $self;
214 my $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
216 my @MRO = Class::C3::calculateMRO($class);
219 while ($current = shift @MRO) {
220 last if $caller eq $current;
225 foreach my $class (@MRO) {
226 next if (defined $Class::C3::MRO{$class} &&
227 defined $Class::C3::MRO{$class}{methods}{$label});
228 last if (defined ($found = *{$class . '::' . $label}{CODE}));
234 return $method if $indirect;
236 die "No next::method '$label' found for $self" if !$method;
241 sub can { method($_[0]) }
243 package # hide me from PAUSE
251 sub method { (next::method($_[0]) || return)->(@_) }