package IMPL::declare;
use strict;

use Scalar::Util qw(set_prototype);
use Carp qw(carp);
use IMPL::Class::PropertyInfo();
use IMPL::Const qw(:access);
use IMPL::require();

BEGIN {
	*_require = *IMPL::require::_require;
	*_trace = *IMPL::require::_trace;
}

sub import {
	my ( $self, $args ) = @_;

	return unless $args;

	die "A hash reference is required" unless ref $args eq 'HASH';

	no strict 'refs';

	my $caller = caller;

	my $aliases = $args->{require} || {};
	
	$IMPL::require::PENDING{$caller} = 1;
	_trace("declare $caller");
	$IMPL::require::level++;

	while ( my ( $alias, $class ) = each %$aliases ) {
		_trace("$alias => $class");
		$IMPL::require::level ++;
		my $c = _require($class);

		*{"${caller}::$alias"} = set_prototype(
			sub {
				$c;
			},
			''
		);
		$IMPL::require::level --;
	}

	my $base = $args->{base} || {};

	my %ctor;
	my @isa;

	if ( ref $base eq 'ARRAY' ) {
		carp "Odd elements number in require"
		  unless scalar(@$base) % 2 == 0;
		while ( my ( $class, $mapper ) = splice @$base, 0, 2 ) {
			_trace("parent $class");
			$IMPL::require::level ++;
			$class = $aliases->{$class} || _require($class);
			$IMPL::require::level --;

			push @isa, $class;
			$ctor{$class} = $mapper;
		}
	}
	elsif ( ref $base eq 'HASH' ) {
		while ( my ( $class, $mapper ) = each %$base ) {
			_trace("parent $class");
			$IMPL::require::level ++;
			$class = $aliases->{$class} || _require($class);
			$IMPL::require::level --;

			push @isa, $class;
			$ctor{$class} = $mapper;
		}
	}
	
	*{"${caller}::CTOR"} = \%ctor;
    *{"${caller}::ISA"}  = \@isa;

	my $props = $args->{props} || [];

	if ( $props eq 'HASH' ) {
		$props = [%$props];
	}

	die "A hash or an array reference is required in the properties list"
	  unless ref $props eq 'ARRAY';

	carp "Odd elements number in properties declaration of $caller"
	  unless scalar(@$props) % 2 == 0;

	if (@$props) {
		for ( my $i = 0 ; $i < @$props - 1 ; $i = $i + 2 ) {
			my ( $prop, $spec ) = @{$props}[ $i, $i + 1 ];

			my $propInfo = IMPL::Class::PropertyInfo->new(
				{
					Name     => $prop,
					Mutators => $spec,
					Class    => $caller,
					Access   => $prop =~ /^_/
					? ACCESS_PRIVATE
					: ACCESS_PUBLIC
				}
			);
			$propInfo->Implement();
		}
	}
	
	$IMPL::require::level--;
	delete $IMPL::require::PENDING{$caller};
}

1;

__END__

=pod

=head1 NAME

C<IMPL::declare> - описывает класс

=head1 SYNOPSIS

=begin code

package My::Bar;

use IMPL::declare {
	require => {
		TFoo => 'My::Foo',
		TBox => 'My::Box'
	},
	base => {
		TFoo => '@_',
		'IMPL::Object' => undef,
	}
}

sub CreateBox {
	my ($this) = @_;
	return TBox->new($this);
}

=end code

Специальная ситрока C<@_> означает передачу параметров конструктора текущего класса конструктору
базового класса без изменений.

=head1 DESCRIPTION

Описывает текущий пакет(модуль) как класс. В качестве параметра получает ссылку на хеш,
в которой храняться метаданные для объявления класса.

=head1 METADATA

=head2 C<require>

Содержит ссылку на хеш с синонимами модулей, которые будут доступны в текушем модуле,
аналогично использованию C<IMPL::require>. Однако, если модуль не требует загрузки при
помощи C<require> нужно использовать префикс C<'-'> в его имени

=begin code

{
	require => {
		TObject => 'IMPL::Object', # will be loaded with require
		TFoo => '-My:App::Data::Foo' # will not use 'require' to load module
	}
}

=end code

=head2 C<base>

Обисывает базове классы для текущего класса. Если данный параметр - ссылка массив, то
этот массив будет превращен в массив C<@ISA>. Если данный параметр - ссылка на хеш, то
его ключи опичавют список базовых классов, а значения - преобразование параметров для
вызова базовых конструкторов.

В качестве имен базовых классов могут быть как полные имена модулей, так и назначенные
ранее псевдонимы. Использование префикса C<'-'> перед B<полным именем модуля> означает,
что модуль не требуется загружать, в случае с псевдонимами, префикс C<'-'> уже был указан
при их объявлении.

=begin code

{
    require => {
        TFoo => '-My:App::Data::Foo' # will not use 'require' to load module
    },
    base => {
    	TFoo => '@_', # pass parameters unchanged
    	'My::Base::Class' => sub { name => $_[0], data => $_[1] },  # remap parameters
    	'-My::Extentions' => undef, # do not pass any parameters
    }
}

=end code

=cut