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

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(<<ERROR);
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__

=pod

=head1 NAME

Class::Mixer - Arrange class hierarchy based on dependency rules

=head1 SYNOPSIS

    package Base;
    use Class::Mixer;
    sub x { 'Base::x' }

    package Main;
    use Class::Mixer before => 'Base';
    sub x { 'Main::x' }

    my $obj = Main->new();
    print "@Main::ISA\n";  # prints "Base Class::Mixer"

    package Mixin;
    use Class::Mixer before => 'Base', after => 'Main';
    sub x { 'Mixin::x' }

    package NewMain; 
    use Class::Mixer isa => 'Main', requires => 'Mixin';
    sub x { 'NewMain::x' }
 
    my $obj = NewMain->new();
    print "@NewMain::ISA\n";  # prints "Main Mixin Base Class::Mixer"

=head1 DESCRIPTION

This module is designed to solve a problem which occurs when using inheritance
to mixin behaviors into a class hierarchy.  The dependencies between a large
number of mixin modules may be complex, making it tricky to get the base 
classes to inherit in the right order.  

Then if you have class Main which gets the inheritance right, and you want
to add a class Mixin which needs to go in the middle of the 
inheritance, you cannot simply do C<package NewMain; use base qw(Main Mixin);>
because Mixin will be put at the end of the inheritance chain.

Also, if you have a class Foo::Better which enhances the Foo behavior,
the same problem occurs trying to mixin Foo::Better.  And it is even worse
if some classes have done C<use base 'Foo';> to try to enforce the correct
hierarchy.

This module solves the problems by implementing a dependency-based hierarchy.
You declare the relations between the classes, and an order of inheritance
which will support those relations is determined automatically.

It combines functions from base and Class::C3 to do its job.
It will C<require> the given classes (unless optional) similar to C<use base>.
And it attempts to force c3 semantices, so you should
do C<< $self->method::next >> instead of C<SUPER> for inheritance.

=head1 Inheritance rules

When you design your classes, instead of doing C<use base> or C<our @ISA>,
do something like the following:

    package Example;
    use Class::Mixer before => 'BaseClass', 'OtherClass',
                     after => 'SoAndSoClass',
                     isa => 'PreviousExample',
                     requires => 'OtherBehavior',
                     optional => 'OtherClass';

The Class::Mixer class provides a basic new() method, which will call init(), 
which your classes can override.

The actual inheritance is computed for a class the first time new() is called.

The inheritance rules are described here:


=head2 B<before>

The 'before' rule means this package must occur before some other
class in the method dispatch order, which means that if they both define
the same method, this class will be invoked before the other.
In the inheritance hierarchy, this class should be a descendant of the other.

This is essentially the same as what you would get if you did C<use base>
instead.  Which you can, by the way.

If no rule type is given, e.g. C<use Class::Mixer 'BaseClass';>
then the before rule is assumed.

=head2 B<after>

The 'after' rule means this package must occur after some other
class in the method dispatch order.
The other class will usually be a descendant of this one.
This is best if used rarely, but it is nice when it is necessary.

It is essentially the same as doing C<< before => 'this', optional => 'this' >>
in the other class.

=head2 B<isa>

The 'isa' rule establishes a very strong isa relationship between classes.
All the classes are related by C<@ISA>, of course, but this 'isa' means that
the particular behaviors implements by the classes are the same, and that
this one enhances the other.  

The classes are kept together as close as possible in the computed hierarchy,
and all rules which were applied to the other class will be applied to this
class as well.

=head2 B<requires>

The 'requires' rule says that this class needs the behavior from some other
class, but the inheritance order is not important.  Usually this is because
the two classes do not share any methods.

=head2 B<optional>

The 'optional' rule doesn't affect the class hierarchy.  It simply makes
the class not complain if the other class is not there.  

This is useful when we want to say, "I do not really need this other class,
but IF someone else does, I should be before (or after) the other class."

=head1 BUGS and TODO

Probably.

"optional" isn't fully implemented yet.

TODO?: implement a 'nota' rule, to prevent someone from putting this
class in the same hierarchy as another.

=head1 Why not Traits?

Traits are complementary to inheritance, and do not address situations where
one module needs to extend another by extending/wrapping/inheriting 
the same method.  Traits are more concerned with properly adding new
methods to a class, while Class::Mixer tries to solve some problems
with complex mixin-style inheritance trees.

For example, I have a C<write> method, and several optional behaviors
which happen when C<write> is called, such as an Index behavior and
an VersionControl behavior.  These will both override the C<write> method
and call the parent method before or after they do what they need to do.
But this violates the flattening property of traits.  
The C<write> method in Index and VersionControl are not conflicting; 
they need to inherit, perhaps in a specific order, so that
both with be called.

It may be that what I am actually describing is event-based, because write
is the event, and the behaviors are various things which need to happen
when that event occurs.  None of the event systems I have looked at have
contraints to allow ordering the behaviors relative to each other, so
even if I setup an event model, I would still need the solution which
Class::Mixer provides.

=head1 SEE ALSO

L<Class::C3>

L<base>

The snide comments in L<mixin> probably apply to this module as well.

=head1 AUTHOR

John Williams, E<lt>smailliw@gmail.comE<gt>

=head1 COPYRIGHT AND LICENCE

Copyright (c) 2009 by John Williams

This library is free software; you can redistribute it and/or modify it 
under the same terms as Perl itself.

=cut

