package IMPL::Class::Meta;
use strict;

use IMPL::clone qw(clone);

my %class_meta;
my %class_data;

sub set_meta {
    my ($class,$meta_data) = @_;
    $class = ref $class if ref $class;
    
    # тут нельзя использовать стандартное исключение, поскольку для него используется
    # класс IMPL::Object::Accessor, который наследуется от текущего класса
    die "The meta_data parameter should be an object" if not ref $meta_data;
    
    push @{$class_meta{$class}{ref $meta_data}},$meta_data;
}

sub get_meta {
    my ($class,$meta_class,$predicate,$deep) = @_;
    $class = ref $class if ref $class;
    no strict 'refs';
    my @result;
    
    if ($deep) {
        @result = map { $_->can('get_meta') ? $_->get_meta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'};
    }
    
    if ($predicate) {
        push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) );
    } else {
        push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) );
    }
    wantarray ? @result : \@result;
}

sub class_data {
	my $class = shift;
	$class = ref $class || $class;
	
	if (@_ > 1) {
		my ($name,$value) = @_;
		return $class_data{$class}{$name} = $value;
	} else {
		my ($name) = @_;
		
		if( exists $class_data{$class}{$name} ) {
			$class_data{$class}{$name};
		} else {
			if ( my $value = $class->_find_class_data($name) ) {
				$class_data{$class}{$name} = clone($value);
			} else {
				undef;
			}
		}
	}
}

sub static_accessor {
	my ($class,$name,$value) = @_;
	$class = ref $class || $class;
	
	no strict 'refs';
	
	*{"${class}::${name}"} = sub {
		if (@_ > 1) {
			my $self = shift;
			$self = ref $self || $self;
			
			if ($class ne $self) {
				$self->static_accessor( $name => $_[0]); # define own class data
			} else {
				$value = $_[0];
			}
		} else {
			$value;
		}
	};
	$value
};

sub _find_class_data {
	my ($class,$name) = @_;
	
	no strict 'refs';
	
	exists $class_data{$_}{$name} and return $class_data{$_}{$name}	foreach @{"${class}::ISA"};
		
	my $val;
	$val = $_->can('_find_class_data') ? $_->_find_class_data($name) : undef and return $val foreach @{"${class}::ISA"}; 
}

1;

__END__

=pod

=head1 NAME

C<IMPL::Class::Meta> - информация хранимая на уровне класса.

=head1 SYNOPSIS

=begin code

package InfoMeta;

use parent qw(IMPL::Object IMPL::Object::Autofill);
use IMPL::Class::Property;

__PACKAGE__->PassThroughArgs;

BEGIN {
	public property name => prop_get | owner_set;
}

package InfoExMeta;
use parent qw(InfoMeta);

__PACKAGE__->PassThroughArgs;

BEGIN {
	public property description => prop_all;
}

package Foo;

__PACKAGE__->set_meta(new InfoMeta(name => 'info'));
__PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' ));

package main;

# get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta
my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx';

# get all InfoExMeta meta
@info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx'

# get filtered meta
@info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info' 

=end code

=head1 DESCRIPTION

Позвоялет расширять информацию о типах (класса) при помощи метаданных, метаданными являются любые объекты,
притом выборка метаданных приоизводится по их типу (классу), что позволяет выбрать все однотипные метаданные.

Существует возможность выборки метаданных с учетом унаследованных от базовых классов

=head1 MEMBERS

=over

=item C<set_meta($meta_data)>

Добавляет метаданные C<$meta_data> к классу.

=item C<get_meta($meta_class,$predicate,$deep)>

Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения
метаданных базовых классов.

=over

=item C<$meta_class>

Тип метаданных

=item C<$predicate>

Подпрограмма, которая будет вызываться для каждых найденных метаданных и на основе результата
ее выполнения метаданные будут включены в результат или нет. Получеат в качестве параметра
объект с метаданными, возвращает C<true> - включить метаданные в результа, C<false> - пропустить
метаданные как не подходящие. Также переменная C<$_> ссылается на текущий объект с метаданными.

=begin code

my @info = Foo->get_meta(
	'InfoMeta',
	sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta')
	1 # deep search
);

my @info = Foo->get_meta(
	'InfoMeta',
	sub {
		my $item = shift;
		ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta')
	}, 
	1 # deep search
);

=end code 
 
=item C<$deep>

Осуществлять поиск по базовым классам.

=back  

=item C<class_data($name,$new_value)>

В отличии от метаданных, C<class_data> не накапливает информацию,
а хранит только один экземпляр для одного ключа C<$name>.

Если новое значение не задано, то осуществляется выборка сохраненного,
если текущий класс не имеет сохраненного значения, то оно ищется в базовых
классах, затем копия найденного значения сохраняется в текущем классе и
возвращается наружу. Это позволяет базовым классам задавать значение по-умолчанию,
которые могут быть изменены или заменены субклассами.

=begin code

package Foo;
use parent qw(IMPL::Class::Meta);

__PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses

sub say_version {
	my ($self) = @_;
	
	print $self->class_data('info')->{version};
}

package Bar;
use parent qw(Foo);

__PACKAGE__->class_data('info')->{ language } = 'English';

package main;

Foo->class_data('info')->{version} = 2;
Bar->say_version; # will print '1';
Foo->say_version; # will print '2';

=end code 

=item C<static_accessor($name[,$value])>

Создает статическое свойство с именем C<$name> и начальным значением C<$value>.

Использование данного свойство аналогично использованию C<class_data>, за исключением
того, что C<class_data> гарантирует, что наследник обладает собственной копией данных,
изменение которых не коснется ни базового класса, ни соседей.

=begin code

package Foo;
use parent qw(IMPL::Class::Meta);

__PACKAGE__->static_accessor( info => { version => 1 } );

package Bar;
use parent qw(Foo);

__PACKAGE__->info->{language} = 'English'; # Foo->info->{language} will become 'English' to!!!
__PACKAGE__->info({language => 'English'}); # will define own 'info' but will loose original data.

=end code
 

=back

=cut