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";
  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 }
  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 #
  71 our %MRO;
  72
  73 # use these for debugging ...
  74 sub _dump_MRO_table { %MRO }
  75 our $TURN_OFF_C3 = 0;
  76
  77 # state tracking for initialize()/uninitialize()
  78 our $_initialized = 0;
  79
  80 sub 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';
  85
  86     return if $TURN_OFF_C3;
  87     mro::set_mro_c3($class) if $C3_IN_CORE;
  88
  89     # make a note to calculate $class
  90     # during INIT phase
  91     $MRO{$class} = undef unless exists $MRO{$class};
  92 }
  93
  94 ## initializers
  95
  96 sub initialize {
  97     %next::METHOD_CACHE = ();
  98     # why bother if we don't have anything ...
  99     return unless keys %MRO;
 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;
 111     }
 112 }
 113
 114 sub uninitialize {
 115     # why bother if we don't have anything ...
 116     %next::METHOD_CACHE = ();
 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     }
 125 }
 126
 127 sub reinitialize { goto &initialize }
 128
 129 ## functions for applying C3 to classes
 130
 131 sub _calculate_method_dispatch_tables {
 132     return if $C3_IN_CORE;
 133     my %merge_cache;
 134     foreach my $class (keys %MRO) {
 135         _calculate_method_dispatch_table($class, \%merge_cache);
 136     }
 137 }
 138
 139 sub _calculate_method_dispatch_table {
 140     return if $C3_IN_CORE;
 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
 171 sub _apply_method_dispatch_tables {
 172     return if $C3_IN_CORE;
 173     foreach my $class (keys %MRO) {
 174         _apply_method_dispatch_table($class);
 175     }
 176 }
 177
 178 sub _apply_method_dispatch_table {
 179     return if $C3_IN_CORE;
 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
 189 sub _remove_method_dispatch_tables {
 190     return if $C3_IN_CORE;
 191     foreach my $class (keys %MRO) {
 192         _remove_method_dispatch_table($class);
 193     }
 194 }
 195
 196 sub _remove_method_dispatch_table {
 197     return if $C3_IN_CORE;
 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
 210 sub calculateMRO {
 211     my ($class, $merge_cache) = @_;
 212
 213     return @{mro::get_mro_linear_c3($class)} if $C3_IN_CORE;
 214
 215     return Algorithm::C3::merge($class, sub {
 216         no strict 'refs';
 217         @{$_[0] . '::ISA'};
 218     }, $merge_cache);
 219 }
 220
 221 package  # hide me from PAUSE
 222     next;
 223
 224 use strict;
 225 use warnings;
 226
 227 use Scalar::Util 'blessed';
 228
 229 our $VERSION = '0.06';
 230
 231 our %METHOD_CACHE;
 232
 233 sub method {
 234     my $self     = $_[0];
 235     my $class    = blessed($self) || $self;
 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     }
 247
 248     my $method;
 249
 250     my $caller   = join '::' => @label;
 251
 252     $method = $METHOD_CACHE{"$class|$caller|$label"} ||= do {
 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         }
 268
 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
 279 sub can { method($_[0]) }
 280
 281 package  # hide me from PAUSE
 282     maybe::next;
 283
 284 use strict;
 285 use warnings;
 286
 287 our $VERSION = '0.02';
 288
 289 sub method { (next::method($_[0]) || return)->(@_) }
 290
 291 1;