lib/Class/C3/XS.pm

   1
   2 package Class::C3::XS;
   3
   4 our $VERSION = '0.15';
   5
   6 =pod
   7
   8 =head1 NAME
   9
  10 Class::C3::XS - The XS implementation of Class::C3
  11
  12 =head1 DESCRIPTION
  13
  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.
  17
  18 =head1 AUTHOR
  19
  20 Stevan Little, E<lt>stevan@iinteractive.comE<gt>
  21
  22 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
  23
  24 =head1 COPYRIGHT AND LICENSE
  25
  26 Copyright 2005, 2006 by Infinity Interactive, Inc.
  27
  28 L<http://www.iinteractive.com>
  29
  30 This library is free software; you can redistribute it and/or modify
  31 it under the same terms as Perl itself.
  32
  33 =cut
  34
  35 package # hide me from PAUSE
  36     Class::C3;
  37
  38 use strict;
  39 use warnings;
  40
  41 use Scalar::Util 'blessed';
  42 use Algorithm::C3;
  43
  44 # this is our global stash of both
  45 # MRO's and method dispatch tables
  46 # the structure basically looks like
  47 # this:
  48 #
  49 #   $MRO{$class} = {
  50 #      MRO => [ <class precendence list> ],
  51 #      methods => {
  52 #          orig => <original location of method>,
  53 #          code => \&<ref to original method>
  54 #      },
  55 #      has_overload_fallback => (1 | 0)
  56 #   }
  57 #
  58 our %MRO;
  59
  60 # use these for debugging ...
  61 sub _dump_MRO_table { %MRO }
  62 our $TURN_OFF_C3 = 0;
  63
  64 # state tracking for initialize()/uninitialize()
  65 our $_initialized = 0;
  66
  67 sub import {
  68     my $class = caller();
  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
  74     # during INIT phase
  75     $MRO{$class} = undef unless exists $MRO{$class};
  76 }
  77
  78 ## initializers
  79
  80 sub initialize {
  81     # why bother if we don't have anything ...
  82     return unless keys %MRO;
  83     if($_initialized) {
  84         uninitialize();
  85         $MRO{$_} = undef foreach keys %MRO;
  86     }
  87     _calculate_method_dispatch_tables();
  88     _apply_method_dispatch_tables();
  89     %next::METHOD_CACHE = ();
  90     $_initialized = 1;
  91 }
  92
  93 sub uninitialize {
  94     # why bother if we don't have anything ...
  95     return unless keys %MRO;
  96     _remove_method_dispatch_tables();
  97     %next::METHOD_CACHE = ();
  98     $_initialized = 0;
  99 }
 100
 101 sub reinitialize { goto &initialize }
 102
 103 ## functions for applying C3 to classes
 104
 105 sub _calculate_method_dispatch_tables {
 106     my %merge_cache;
 107     foreach my $class (keys %MRO) {
 108         _calculate_method_dispatch_table($class, \%merge_cache);
 109     }
 110 }
 111
 112 sub _calculate_method_dispatch_table {
 113     my ($class, $merge_cache) = @_;
 114     no strict 'refs';
 115     my @MRO = calculateMRO($class, $merge_cache);
 116     $MRO{$class} = { MRO => \@MRO };
 117     my $has_overload_fallback = 0;
 118     my %methods;
 119     # NOTE:
 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
 126         # grab that value
 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};
 136         }
 137     }
 138     # now stash them in our %MRO table
 139     $MRO{$class}->{methods} = \%methods;
 140     $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
 141 }
 142
 143 sub _apply_method_dispatch_tables {
 144     foreach my $class (keys %MRO) {
 145         _apply_method_dispatch_table($class);
 146     }
 147 }
 148
 149 sub _apply_method_dispatch_table {
 150     my $class = shift;
 151     no strict 'refs';
 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};
 156     }
 157 }
 158
 159 sub _remove_method_dispatch_tables {
 160     foreach my $class (keys %MRO) {
 161         _remove_method_dispatch_table($class);
 162     }
 163 }
 164
 165 sub _remove_method_dispatch_table {
 166     my $class = shift;
 167     no strict 'refs';
 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});
 173     }
 174 }
 175
 176 ## functions for calculating C3 MRO
 177
 178 sub calculateMRO {
 179     my ($class, $merge_cache) = @_;
 180     return Algorithm::C3::merge($class, sub {
 181         no strict 'refs';
 182         @{$_[0] . '::ISA'};
 183     }, $merge_cache);
 184 }
 185
 186 package  # hide me from PAUSE
 187     next;
 188
 189 use strict;
 190 use warnings;
 191
 192 our $VERSION = 0.15;
 193
 194 use Scalar::Util 'blessed';
 195
 196 our %METHOD_CACHE;
 197
 198 sub method {
 199     my $indirect = caller() =~ /^(?:next|maybe::next)$/;
 200     my $level = $indirect ? 2 : 1;
 201
 202     my ($method_caller, $label, @label);
 203     while ($method_caller = (caller($level++))[3]) {
 204       @label = (split '::', $method_caller);
 205       $label = pop @label;
 206       last unless
 207         $label eq '(eval)' ||
 208         $label eq '__ANON__';
 209     }
 210     my $caller   = join '::' => @label;
 211     my $self     = $_[0];
 212     my $class    = blessed($self) || $self;
 213
 214     my $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
 215
 216         my @MRO = Class::C3::calculateMRO($class);
 217
 218         my $current;
 219         while ($current = shift @MRO) {
 220             last if $caller eq $current;
 221         }
 222
 223         no strict 'refs';
 224         my $found;
 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}));
 229         }
 230
 231         $found;
 232     };
 233
 234     return $method if $indirect;
 235
 236     die "No next::method '$label' found for $self" if !$method;
 237
 238     goto &{$method};
 239 }
 240
 241 sub can { method($_[0]) }
 242
 243 package  # hide me from PAUSE
 244     maybe::next;
 245
 246 use strict;
 247 use warnings;
 248
 249 our $VERSION = 0.15;
 250
 251 sub method { (next::method($_[0]) || return)->(@_) }
 252
 253 1;