Fukurama::Class::Extends - Pragma to extend class inheritation

 package MyClass;
 use Fukurama::Class::Extends('MyParent');

package Fukurama::Class::Extends;
use Fukurama::Class::Version(0.01);
use Fukurama::Class::Rigid;
use Fukurama::Class::Carp;
use Fukurama::Class::Tree();

our $LEVEL_DISABLE				= 0;
our $LEVEL_CHECK_NONE			= 1;
our $LEVEL_CHECK_REGISTERED		= 2;
our $LEVEL_CHECK_CHILDS			= 3;
our $LEVEL_CHECK_ALL			= 4;

our $CHECK_LEVEL = $LEVEL_CHECK_CHILDS;

my $REGISTER = {};
my $ERRORS = {};

# void
my $BUILD_HANDLER = sub {
	my $classname = $_[0];
	my $classdef = $_[1];
	
	my $inheritation_paths = Fukurama::Class::Tree->get_inheritation_path($classname);
	$classdef->{'extends'} = $inheritation_paths if(scalar(@$inheritation_paths));
	return;
};
# void
my $CHECK_HANDLER = sub {
	my $classname = $_[0];
	my $classdef = $_[1];
	
	my $paths = $classdef->{'extends'};
	return if(ref($paths) ne 'ARRAY' || !__PACKAGE__->_check_this_class($classname, $paths));
	
	my $parent_path_subs = [];
	foreach my $path (@$paths) {
		my $path_subs = __PACKAGE__->_get_all_subs_for_classpath($path);
		push(@$parent_path_subs, {
			subs	=> $path_subs,
			path	=> $path,
		});
	}
	my $all_subs = {};
	foreach my $entry (@$parent_path_subs) {
		foreach my $subname (keys(%{$entry->{'subs'}})) {
			if($all_subs->{$subname} && !__PACKAGE__->_is_same_sub($subname, $entry->{'subs'}->{$subname}, $all_subs->{$subname}->{'subs'}->{$subname})) {
				my $other_entry = $all_subs->{$subname};
				my $ident = "$classname\::$entry->{'subs'}->{$subname}";
				next if($ERRORS->{$ident});
				_carp("Multi-inheritation-warning for class '$classname':\n" .
					"  > sub '$subname' is defined twice in parent-classes\n" .
					"  > '$entry->{'subs'}->{$subname}' and '$other_entry->{'subs'}->{$subname}'\n" .
					"    > inheritation-path for '$entry->{'subs'}->{$subname}':\n" .
					"        $classname > " . join(' > ', @{$entry->{'path'}}) . "\n" .
					"    > inheritation-path for '$other_entry->{'subs'}->{$subname}':\n" .
					"        $classname > " . join(' > ', @{$other_entry->{'path'}}) . "\n", 1);
				$ERRORS->{$ident} = 1;
			}
			$all_subs->{$subname} = $entry;
		}
	}
	return;
};
# AUTOMAGIC void
sub import {
	my $class = $_[0];
	my $parent = $_[1];
	
	my ($child) = caller(0);
	local $Carp::CarpLevel = $Carp::CarpLevel + 1;
	$class->extends($child, $parent);
	return undef;
}
# void
sub extends {
	my $class = $_[0];
	my $child = $_[1];
	my $parent = $_[2];
	my $import_depth = $_[3] || 0;
	
	local $SIG{'__DIE__'} = sub {};
	
	no strict 'refs';
	
	if($CHECK_LEVEL > $LEVEL_DISABLE) {
		if(!%{"$child\::"} && eval("use $parent();return 1")) {
			_croak($@, $import_depth);
		}
	}
	if(!eval("package $child;use base qw($parent);return 1") || $@) {
		_croak("Can't extend class '$parent' in child class '$child':\n$@", $import_depth);
	}
	
	return if($CHECK_LEVEL == $LEVEL_DISABLE);
	$REGISTER->{$child} = 1;
	$class->register_class_tree();
	return;
}
# STATIC void
sub register_class_tree {
	my $class = $_[0];
	
	Fukurama::Class::Tree->register_build_handler($BUILD_HANDLER);
	Fukurama::Class::Tree->register_check_handler($CHECK_HANDLER);
	return;
}
# STATIC boolean
sub _check_this_class {
	my $class = $_[0];
	my $classname = $_[1];
	my $paths = $_[2];
	
	return 1 if($CHECK_LEVEL == $LEVEL_CHECK_ALL);
	return 0 if($CHECK_LEVEL == $LEVEL_CHECK_NONE);
	
	return 1 if($REGISTER->{$classname});
	return 0 if($CHECK_LEVEL == $LEVEL_CHECK_REGISTERED);
	
	if($CHECK_LEVEL == $LEVEL_CHECK_CHILDS) {
		foreach my $path (@$paths) {
			foreach my $path_class (@$path) {
				return 1 if($REGISTER->{$path_class});
			}
		}
	}
	return 0;
}
# boolean
sub _is_same_sub {
	my $class = $_[0];
	my $subname = $_[1];
	my $first_class = $_[2];
	my $second_class = $_[3];
	
	no strict 'refs';
	
	return 1 if(*{$first_class . '::' . $subname}{'CODE'} == *{$second_class . '::' . $subname}{'CODE'});
	return 0;
}
# hashref
sub _get_all_subs_for_classpath {
	my $class = $_[0];
	my $path = $_[1];
	
	my $path_subs = {};
	foreach my $parent (@$path) {
		foreach my $subname (Fukurama::Class::Tree->get_class_subs($parent)) {
			$path_subs->{$subname} ||= $parent;
		}
	}
	return $path_subs;
}
# void
sub run_check {
	my $class = $_[0];
	my $type = $_[1];
	
	$type = 'MANUAL' if(!defined($type));
	Fukurama::Class::Tree->run_check('CHECK') if($CHECK_LEVEL > $LEVEL_DISABLE);
	return;
}

no warnings 'void'; # avoid 'Too late to run CHECK/INIT block'

# AUTOMAGIC void
CHECK {
	__PACKAGE__->run_check('CHECK');
}
# AUTOMAGIC void
END {
	__PACKAGE__->run_check('END');
}
1;