File Coverage

blib/lib/Class/Classless/C3.pm

Criterion	Covered	Total	%
statement	134	152	88.1
branch	46	66	69.7
condition	10	19	52.6
subroutine	23	28	82.1
pod	6	6	100.0
total	219	271	80.8

package Class::Classless::C3;
use 5.006;
use strict;
use warnings;
our $VERSION = '1.00';

use Algorithm::C3;

# set this to a scalar ref for tracing
our $trace;

# the root object
our $ROOT;

# for caching results from Algorithm::C3::merge
our %c3cache;

# Class::Classless::C3->new( ['name', method=>sub, ... ] )
# $classless->new( [ 'name', method => sub, ... ] )
# name recommended
sub new
{
	my $parent = shift;
	my $class = ref $parent || $parent;
	my $self = bless {}, $class;
	# Meta class is not subclassable this way....
	$self->{_meta} = Class::Classless::C3::Meta->new();
	$self->meta->parent(ref $parent ? $parent : $ROOT);
	my $name = shift;
	$self->meta->name($name);
	$self->meta->addmethod( splice(@_,0,2) ) while @_;
	$self->init($name,@_);
	return $self;
}

$ROOT = bless {}, 'Class::Classless::C3';
$ROOT->{_meta} = Class::Classless::C3::Meta->new();
$ROOT->meta->name('ROOT');
$ROOT->meta->addmethod( init => sub {} );


sub meta
{
	return $_[0]->{_meta};
}

our $AUTOLOAD;
# top level call
sub AUTOLOAD
{
	my $self = $_[0];
	my $sub = $self->can($AUTOLOAD) or
		die("cannot call method ".($AUTOLOAD =~ m/([^:]*)$/g)[0]." on ".(ref($self)?$self->{_meta}->{name}:"'$self'"));
	$$trace .= "called ".$self->{_meta}->name."->".($AUTOLOAD =~ m/([^:]*)$/g)[0]." (@_[1..$#_])\n" if ref $trace eq 'SCALAR';
	goto $sub;
}

# inherited call
sub NEXT
{
	my $self = $_[0];
	my $class;
	my $method;
	my $level = 1;
	my $caller;
	# caller is subname-ed to instance-name::method-name
	while ($caller = (caller($level++))[3]) {
		($class,$method) = ($caller =~ m/^(.*)::([^:]+)$/s);
		last unless $method =~ m/^(\(eval\)|__ANON__|DB::.*)$/;
	}
	# need to start from parent of owner of current method
	my $sub = $self->can($method,from=>$class);
	return unless $sub;	# do not die on NEXT
	$$trace .= "NEXT $method from $class\n" if ref $trace eq 'SCALAR';
	goto $sub;
}

sub VERSION
{
	# stub
}

sub isa
{
	my $self = shift;
	my $what = shift;

	my $c3 = $c3cache{$self->{_meta}->{name}} ||= [
		Algorithm::C3::merge( $self,
			sub { @{ $_[0]->{_meta}->{parents} } },
		)];
	if (ref $what) {
		return grep($_ eq $what, @$c3) ? 1 : 0;
	} else {
		return grep($_->{_meta}->{name} eq $what, @$c3) ? 1 : 0;
	}
}

# this is here to avoid calling can('DESTROY') after meta is gone
sub DESTROY
{
}

sub can
{
	my $self = shift;
	my $method = shift;
	$method =~ s/^.*:://;
	my $from = $_[0] && $_[0] eq 'from' ? $_[1] : undef;

	if (!$self->{_meta}) { warn("cannot can '$method' without meta"); }
	my $c3 = $c3cache{$self->{_meta}->{name}} ||= [
		Algorithm::C3::merge( $self,
			sub { @{ $_[0]->{_meta}->{parents} } },
		)];
	my $sub;
	for my $o ( @$c3 ) {
		if ($from) {
			next if $o->{_meta}->{name} ne $from;
			undef $from;
			next;
		}
		if (ref $o && $o->{_meta}) {
			$sub = $o->{_meta}->{methods}->{$method};
			return $sub if $sub;
			# for optional autoload-like behavior
			if (ref $Class::Classless::C3::autoload eq 'CODE') {
				$sub = $Class::Classless::C3::autoload->($o,$method);
				return $sub if $sub;
			}
		} else {
			$sub = UNIVERSAL::can($o,$method);
			return $sub if $sub;
		}
	}
	# catch methods defined in Class::Classless::C3
	$sub = UNIVERSAL::can($self,$method);
	return $sub if $sub;

	return undef;
}

$Class::Classless::C3::autoload ||= '';


package # hide from pause
	Class::Classless::C3::Meta;
use Sub::Name;

$Class::Classless::C3::Meta::uid = 0;

sub new
{
	my $object = shift;
	my $class = ref $object || $object;
	my $self = bless {}, $class;
	$self->init(@_);
	return $self;
}

sub init
{
	my $self = shift;
	$self->{parents} = [];
}

sub name
{
	my $self = shift;
	if (@_) {
		$self->purge_c3cache if $self->{name};
		my $name = shift;
		$self->{name} = $name;
		unless ($self->{name}) {
			$self->{name} = 'x_'.++$Class::Classless::C3::Meta::uid;
		}
		subname $name.'::'.$_ => $self->{methods}->{$_} for keys %{$self->{methods}};
		$self->purge_c3cache;
	}
	return $self->{name};
}

sub parent
{
	my $self = shift;
	if (@_) {
		# clear any isa caching
		$self->purge_c3cache if @{$self->{parents}};
		my $par = shift;
		die("called parent with nonref '$par'") unless ref $par;
		$self->{parents} = [$par];
	}
	return $self->{parents}->[0];
}

sub parents
{
	my $self = shift;
	if (@_) {
		$self->purge_c3cache if $self->{parents};
		if (ref $_[0] eq 'ARRAY') {
			$self->{parents} = [@{$_[0]}];
		} else {
			$self->{parents} = [@_];
		}
	}
	# return a copy of the array, so they cannot change our copy
	# we need to clear the c3cache if our copy changes
	return @{$self->{parents}};
}

sub addparent
{
	my $self = shift;
	my $newp = shift;
	return unless $newp;
	$self->purge_c3cache;
	# maybe this should unshift???
	push @{ $self->{parents} }, $newp;
}

sub addmethod
{
	my $self = shift;
	my($name,$sub) = @_;
	my $fullname = $self->{name}.'::'.$name;
	$self->{methods}->{$name} = subname $fullname => $sub;
}

sub delmethod
{
	my $self = shift;
	my($name) = @_;
	delete $self->{methods}->{$name};
}

sub clone
{
}

# creates a Classless object from an existing package
sub declassify
{
	my $class = shift;
	my $self = Class::Classless::C3->new($class);

	no strict 'refs';
	my $symtable = \%{$class.'::'};
	for my $sym ( keys %$symtable ) {
		next if $sym =~ m/^(AUTOLOAD|NEXT|can|isa|VERSION|meta|new)$/;
		my $sub = *{$symtable->{$sym}}{CODE};
		if (defined $sub) {
			$self->meta->addmethod($sym => $sub);
			delete ${$class.'::'}{$sym};  #deletes all glob-parts
		}
	}
	return $self;
}

# clear any c3cache entries which contain this object
# (called when an object's parents change or object's name changes)
sub purge_c3cache
{
	my $self = shift;
	my $who = shift || $self->{name};
	for my $k (keys %Class::Classless::C3::c3cache) {
		if (grep $who eq $_->{_meta}->{name}, @{ $Class::Classless::C3::c3cache{$k} }) {
			delete $Class::Classless::C3::c3cache{$k};
		}
	}
}

sub show_c3cache  # for debugging
{
	my $self = shift;
	return join ',',
		map { $_->meta->name }
		@{ $Class::Classless::C3::c3cache{$self->{name}} };
}


1;
__END__