lib/Class/C3/PurePerl.pm

   1
   2 package Class::C3::PurePerl;
   3
   4 our $VERSION = '0.15';
   5
   6 =pod
   7
   8 =head1 NAME
   9
  10 Class::C3::PurePerl - The default pure-Perl implementation of Class::C3
  11
  12 =head1 DESCRIPTION
  13
  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.
  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
  43 our $VERSION = '0.15';
  44 our $C3_IN_CORE;
  45
  46 BEGIN {
  47     eval "require mro"; # XXX in the future, this should be a version check
  48     if($@) {
  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 $@;
  53     }
  54     else {
  55         $C3_IN_CORE = 1;
  56     }
  57 }
  58
  59 # this is our global stash of both
  60 # MRO's and method dispatch tables
  61 # the structure basically looks like
  62 # this:
  63 #
  64 #   $MRO{$class} = {
  65 #      MRO => [ <class precendence list> ],
  66 #      methods => {
  67 #          orig => <original location of method>,
  68 #          code => \&<ref to original method>
  69 #      },
  70 #      has_overload_fallback => (1 | 0)
  71 #   }
  72 #
  73 our %MRO;
  74
  75 # use these for debugging ...
  76 sub _dump_MRO_table { %MRO }
  77 our $TURN_OFF_C3 = 0;
  78
  79 # state tracking for initialize()/uninitialize()
  80 our $_initialized = 0;
  81
  82 sub import {
  83     my $class = caller();
  84     # skip if the caller is main::
  85     # since that is clearly not relevant
  86     return if $class eq 'main';
  87
  88     return if $TURN_OFF_C3;
  89     mro::set_mro($class, 'c3') if $C3_IN_CORE;
  90
  91     # make a note to calculate $class
  92     # during INIT phase
  93     $MRO{$class} = undef unless exists $MRO{$class};
  94 }
  95
  96 ## initializers
  97
  98 sub initialize {
  99     %next::METHOD_CACHE = ();
 100     # why bother if we don't have anything ...
 101     return unless keys %MRO;
 102     if($C3_IN_CORE) {
 103         mro::set_mro($_, 'c3') for keys %MRO;
 104     }
 105     else {
 106         if($_initialized) {
 107             uninitialize();
 108             $MRO{$_} = undef foreach keys %MRO;
 109         }
 110         _calculate_method_dispatch_tables();
 111         _apply_method_dispatch_tables();
 112         $_initialized = 1;
 113     }
 114 }
 115
 116 sub uninitialize {
 117     # why bother if we don't have anything ...
 118     %next::METHOD_CACHE = ();
 119     return unless keys %MRO;
 120     if($C3_IN_CORE) {
 121         mro::set_mro($_, 'dfs') for keys %MRO;
 122     }
 123     else {
 124         _remove_method_dispatch_tables();
 125         $_initialized = 0;
 126     }
 127 }
 128
 129 sub reinitialize { goto &initialize }
 130
 131 ## functions for applying C3 to classes
 132
 133 sub _calculate_method_dispatch_tables {
 134     return if $C3_IN_CORE;
 135     my %merge_cache;
 136     foreach my $class (keys %MRO) {
 137         _calculate_method_dispatch_table($class, \%merge_cache);
 138     }
 139 }
 140
 141 sub _calculate_method_dispatch_table {
 142     return if $C3_IN_CORE;
 143     my ($class, $merge_cache) = @_;
 144     no strict 'refs';
 145     my @MRO = calculateMRO($class, $merge_cache);
 146     $MRO{$class} = { MRO => \@MRO };
 147     my $has_overload_fallback = 0;
 148     my %methods;
 149     # NOTE:
 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
 156         # grab that value
 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};
 166         }
 167     }
 168     # now stash them in our %MRO table
 169     $MRO{$class}->{methods} = \%methods;
 170     $MRO{$class}->{has_overload_fallback} = $has_overload_fallback;
 171 }
 172
 173 sub _apply_method_dispatch_tables {
 174     return if $C3_IN_CORE;
 175     foreach my $class (keys %MRO) {
 176         _apply_method_dispatch_table($class);
 177     }
 178 }
 179
 180 sub _apply_method_dispatch_table {
 181     return if $C3_IN_CORE;
 182     my $class = shift;
 183     no strict 'refs';
 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};
 188     }
 189 }
 190
 191 sub _remove_method_dispatch_tables {
 192     return if $C3_IN_CORE;
 193     foreach my $class (keys %MRO) {
 194         _remove_method_dispatch_table($class);
 195     }
 196 }
 197
 198 sub _remove_method_dispatch_table {
 199     return if $C3_IN_CORE;
 200     my $class = shift;
 201     no strict 'refs';
 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});
 207     }
 208 }
 209
 210 ## functions for calculating C3 MRO
 211
 212 sub calculateMRO {
 213     my ($class, $merge_cache) = @_;
 214
 215     return @{mro::get_linear_isa($class)} if $C3_IN_CORE;
 216
 217     return Algorithm::C3::merge($class, sub {
 218         no strict 'refs';
 219         @{$_[0] . '::ISA'};
 220     }, $merge_cache);
 221 }
 222
 223 1;