File Coverage

blib/lib/Class/AutoloadCAN.pm

Criterion	Covered	Total	%
statement	62	63	98.4
branch	23	26	88.4
condition	2	3	66.6
subroutine	9	9	100.0
pod	0	2	0.0
total	96	103	93.2

package Class::AutoloadCAN;
$VERSION = 0.03;
use strict;
no strict 'refs';
use vars qw($AUTOLOAD);

my %base_install;

sub import {
  shift;  # Get rid of class
  @_ = scalar caller unless @_;
  for (@_) {
    # For giggles and grins, archaic compatibility.  This should work with
    # Perl 5.003.  (Untested.)
    my $class = $_;
    $base_install{$class}++;
    *{"$class\::AUTOLOAD"} = sub {
      my $method = _can($AUTOLOAD, @_);
      if ($method) {
        return &$method;
      }
      my ($package, $file, $line) = caller;
      my $where = qq(package "$class" at $file line $line.);
      if ($AUTOLOAD =~ /(.*)::([^:]+)/) {
        my $package = $1;
        my $method = $2;
	die qq(Can't locate object method "$method" via package "$package" at $where\n);
      }
      else {
        die qq(AUTOLOAD saw no \$AUTOLOAD after $where\n);
      }
    };
  }
}

# The arguments have been rearranged here.  That is for the promise I made
# that you can do anything with this strategy that you can with AUTOLOAD.
# I even support the case where you've AUTOLOADed calling an autoloaded
# function directly without arguments.
sub _can {
  my ($method, @args) = @_;
  my $self = $args[0];

  my %checked;
  # Need to reset these on the off chance that people are dynamically
  # changing @ISA.  Right behaviour over speed...
  reset_installed();

  my $base_class = ref($self) || $self;
  $method =~ s/'/::/g;
  if ($method =~ /^(.*)::([^:]+)/) {
    $base_class = $1;
    $method = $2;
  }
  my %seen;
  my @classes = ($base_class, 'UNIVERSAL');
  while (@classes) {
    my $class = shift @classes;
    next if $seen{$class}++;


    if (my $CAN = *{"$class\::CAN"}{CODE}) {
      # Need to figure out whether I pay attention to CAN.
      # I probably do - I'm only called if you inherit from
      # someone who does, but I might have gone past where I
      # was installed to, in which case I can prune the
      # inheritance tree slightly.
      next unless installed($class);
      my $sub = $CAN->($base_class, $method, @args);
      return $sub if $sub;
    }

    unshift @classes, @{"$class\::ISA"};

  }
};

local $^W;
my $original_can = \&UNIVERSAL::can;
*UNIVERSAL::can = sub {
  my $sub = $original_can->(@_[0,1]);
  return $sub if $sub;
  _can(@_[1,0,2..$#_]);
};

# These hashes track which classes I'm paying attention to CAN in.
my %installed;
my %not_installed;
my %testing_install;
sub reset_installed {
  %installed = %base_install;
  %not_installed = %testing_install = ();
}

# This function takes a class and sets %installed or %not_installed
# appropriately for that class;
sub installed {
  my $base_class = shift;
  return 1 if $installed{$base_class};
  return if $not_installed{$base_class};
  return if $testing_install{$base_class}++; # Avoid infinite recursion.
  my @classes = (@{"$base_class\::ISA"}, 'UNIVERSAL');
  foreach (@classes) {
    # For giggles and grins, archaic compatibility.  This should work with
    # Perl 5.003.  (Untested.)
    my $class = $_;
    return $installed{$base_class} = 1
      if installed($class);
  }
  $not_installed{$base_class} = 1;
  return;
}

1;

__END__