package IMPL::declare;
use strict;

use Scalar::Util qw(set_prototype);
use Carp qw(carp);

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} || {};
	
	while( my ($alias, $class) = each %$aliases ) {
		my $c = _require($class);
        
        *{"${caller}::$alias"} = set_prototype(sub {
            $c
        }, '');
    }
    
    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 ) {
    		$class = $aliases->{$class} || _require($class);
    		
    		push @isa,$class;
    		$ctor{$class} = $mapper;
    	}
    } elsif (ref $base eq 'HASH' ) {
    	while ( my ($class,$mapper) = each %$base ) {
    		$class = $aliases->{$class} || _require($class);
    		
    		push @isa,$class;
    		$ctor{$class} = $mapper;
    	}
    }
    
    *{"${caller}::CTOR"} = \%ctor;
    *{"${caller}::ISA"} = \@isa;
}

sub _require {
	my ($class) = @_;
	
	if (not $class =~ s/^-//) {
		(my $file = $class) =~ s/::|'/\//g;
		require "$file.pm";
	}
	$class;
}


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