File Coverage

blib/lib/Class/Mixer.pm

Criterion	Covered	Total	%
statement	177	190	93.1
branch	48	64	75.0
condition	12	22	54.5
subroutine	16	16	100.0
pod	0	6	0.0
total	253	298	84.9

package Class::Mixer;
use strict;
use Class::C3;
use base;
our $VERSION = '0.52';

sub new
{
	my $class = shift;
	$class = ref $class if ref $class;
	$Class::Mixer::DEBUG ||= 0;

	$class->remix_class;

	my $self = bless {},$class;
	$self->init(@_) if $self->can('init');
	return $self;
}


# this will remix the class the first time it is instantiated,
# after that, the class is considered closed.
sub remix_class
{
	my $self = shift;
	my $class = ref $self || $self;
	no strict 'refs';
	return if ${"$class\::REMIX"};

	${"$class\::REMIX"} = 1;
	@{"$class\::WASA"} = @{"$class\::ISA"};

	if ($Class::Mixer::DEBUG) {
		print "REMIXING $class...\n";
		my @classes = Class::C3::calculateMRO($class);
		print "before: @classes\n";
	}

	my $con = {}; # constraints
	$self->remix_collect($class,$con);

	if ($Class::Mixer::DEBUG > 2) {
		require Data::Dumper;
		$Data::Dumper::Sortkeys = 1;
		print Data::Dumper::Dumper($con);
	}

	$self->mixdown($con);
	print qq{\@$class\::ISA = @{"$class\::ISA"}\n} if $Class::Mixer::DEBUG > 1;

	Class::C3::reinitialize();
	if ($Class::Mixer::DEBUG) {
		my @classes = Class::C3::calculateMRO($class);
		print "after: @classes\n";
	}
}

sub remix_collect
{
	my $self = shift;
	my $class = ref $self || $self;
	no strict 'refs';

	my $subclass = shift;
	my $con = shift;
	return if exists $con->{$subclass};
	$con->{$subclass} = {};

	my @ISA = defined(@{"$subclass\::WASA"}) ?
			@{"$subclass\::WASA"} :
			@{"$subclass\::ISA"};
	my @mixers = @{"$subclass\::MIXERS"};

	my $type = 'before';
	for my $mixer (@ISA,@mixers) {
		if ($mixer =~ m/^(before|after|isa|requires?|optional)$/) {
			$type = $mixer;
			$type = 'requires' if $type eq 'require';
			next;
		}

		$con->{$subclass}->{$type} ||= [];
		push @{$con->{$subclass}->{$type}}, $mixer;

		remix_require($mixer);
		$self->remix_collect($mixer,$con);
	}
}


# "borrowed" from base.pm
sub remix_require
{
	no strict 'refs';
	my $base = shift;

	my $vglob = ${$base.'::'}{VERSION};
	if ($vglob && *$vglob{SCALAR}) {
            ${$base.'::VERSION'} = '-1, set by Class::Mixer'
              unless defined ${$base.'::VERSION'};
        } else {
            local $SIG{__DIE__};
            eval "require $base";
            # Only ignore "Can't locate" errors from our eval require.
            # Other fatal errors (syntax etc) must be reported.
            die $@ if $@ && $@ !~ /^Can't locate .*? at \(eval /;
            unless (%{"$base\::"}) {
                require Carp;
                Carp::croak(<
Base class package "$base" is empty.
    (Perhaps you need to 'use' the module which defines that package first.)
ERROR

            }
            ${$base.'::VERSION'} = "-1, set by Class::Mixer"
              unless defined ${$base.'::VERSION'};
        }
}


sub mixdown
{
	my $self = shift;
	my $class = ref $self || $self;
	my $con = shift;
	no strict 'refs';

	my @classes = ($class, grep $_ ne $class, keys %$con);
	my @BEA = @{"$class\::ISA"};

	# isa: when A isa B,
	#      substitute A for all B's
	for my $subclass (@classes) {
		next unless $con->{$subclass}->{isa};
		for my $isa (@{$con->{$subclass}->{isa}}) {
			for my $sub2 (@classes) {
				for my $k (keys %{$con->{$sub2}}) {
					next if $k eq 'isa';
					for (@{$con->{$sub2}->{$k}}) {
						$_ = $subclass if $_ eq $isa;
					}
				}
			}
		}
	}

	for my $subclass (@classes) {
		next unless $con->{$subclass}->{optional};
		my @opt = @{$con->{$subclass}->{optional}};
		$con->{$subclass}->{optional} = {};
		for my $o (@opt) {
			$con->{$subclass}->{optional}->{$o} = 1;
		}
	}
	# after: A after B means B before A, A is optional
	for my $subclass (@classes) {
		next unless $con->{$subclass}->{after};
		for my $mixer (@{$con->{$subclass}->{after}}) {
			$con->{$mixer}->{before} ||= [];
			push @{$con->{$mixer}->{before}}, $subclass;
			$con->{$mixer}->{optional}->{$subclass} = 1;
		}
	}
	if ($Class::Mixer::DEBUG > 5) {
		print "AFTER isa and after substitutions\n";
		print Data::Dumper::Dumper($con);
	}

	# make a tree
	for my $subclass (@classes) {
		$con->{$subclass}->{node} = {
			class=>$subclass,
			isa=>[],
			bef=>[],
			req=>[],
		};
	}
	for my $subclass (@classes) {
		push @{$con->{$subclass}->{node}->{req}},
			map { $con->{$_}->{node} }
				@{$con->{$subclass}->{requires}};
		push @{$con->{$subclass}->{node}->{bef}},
			map { $con->{$_}->{node} }
				@{$con->{$subclass}->{before}};
		# isa should bind tightest
		push @{$con->{$subclass}->{node}->{isa}},
			map { $con->{$_}->{node} }
				@{$con->{$subclass}->{isa}};
			;
	}
	if ($Class::Mixer::DEBUG > 4) {
		print Data::Dumper::Dumper($con->{$class}->{node});
	}

	# reverse depth first traversal
	@BEA = depth_first_traverse($con->{$class}->{node});
	shift @BEA;  # remove self

	@{"$class\::ISA"} = @BEA;
}

sub depth_first_traverse
{
	my $node = shift;
	my $stem = shift || '';
	$stem = $stem.' '.$node->{class}.' ';
#print "$stem\n";

	# check for loops
	for (@{$node->{bef}},@{$node->{isa}}) {
		if ($stem =~ m/\s$$_{class}\s/) {
			die("inconsistent hierarchy ($stem $$_{class})");
		}
	}

	return if $node->{visited};
	$node->{visited} = 1;
	my @r;

	for (@{$node->{req}}, @{$node->{bef}}, @{$node->{isa}}) {
		unshift @r,depth_first_traverse($_,$stem);
	}
	#print $node->{class};
	#print " ";
	return $node->{class},@r;
}


# use Class::Mixer automatically adds Class::Mixer to ISA
# 	require all reference classes ala use base
#	XXX test: do not require optional classes
#	also force c3 semantics ala use Class::C3
sub import
{
	my $pkg = shift;
	return unless $pkg eq 'Class::Mixer';  # not for inheritors
	my $class = caller(0);

	# save off classes -- real work done in new()
	no strict 'refs';
	no warnings 'once';
	my @mixers = @{"$class\::MIXERS"} = @_;

	# require references classes
	my $type = 'before';
	for my $mixer (@mixers) {
		if ($mixer =~ m/^(before|after|isa|requires?|optional)$/) {
			$type = $mixer;
			$type = 'requires' if $type eq 'require';
			next;
		}

		remix_require($mixer) unless $type eq 'optional';
	}

	# force Class::Mixer into ISA, so our new() will be invoked
	push @{"$class\::ISA"}, $pkg;

	# from Class::C3::import
	if ($class ne 'main') {
		mro::set_mro($class, 'c3') if $Class::C3::C3_IN_CORE;
		$Class::C3::MRO{$class} = undef unless exists $Class::C3::MRO{$class};
	}
}

1;

__END__