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

use Carp qw(carp);
use IMPL::clone qw(clone);

my %class_meta;
my %class_data;

sub SetMeta {
    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 set_meta {
	goto &SetMeta;
}

sub GetMeta {
    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 get_meta {
	goto &GetMeta;
}

sub class_data {
    my $class = shift;
    $class = ref $class || $class;
    
    carp 'The method is obsolete, use static_accessor($name,$value,\'clone\') instead';
    
    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,$inherit) = @_;
    
    $inherit ||= 'inherit';
    
    my $method = "static_accessor_$inherit";
    
    return $class->$method($name,$value);
}

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

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

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

=head2 C<set_meta($meta_data)>

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

=head2 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  

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

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

Параметр C<$inherit> контролирует то, как наследуются значения.

=over

=item * C<inherit>

По умолчанию. Означает, что если для класса не определено значение, оно будет
получено от родителя.

=item * C<clone>

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

=item * C<own>

Каждый класс имеет свое собственное значение не зависящее от того, что было
у предка. Начальное значение для этого статического свойства C<undef>.

=back

Данный метод является заглушкой, он передает управление 
C<static_accessor_inherit>, C<static_accessor_clone>, C<static_accessor_own>
соответственно. Эти методы можно вызывать явно 
C<static_accessor_*($name[,$value])>. 


=begin code

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

__PACKAGE__->static_accessor( info => { version => 1 } );
__PACKAGE__->static_accessor( mappings => { toString => \&ToString }, 'clone' );
__PACKAGE__->static_accessor( _instance => undef, 'own' );

sub ToString {
    "[object Foo]";
}

sub default {
    my ($self) = @_;
    
    $self = ref $self || $self;
    return $self->_instance ? $self->_instance : $self->_instance($self->new());
}

package Bar;
use parent qw(Foo);

__PACKAGE__->info({language => 'English', version => 2}); # will define own 'info' but will loose original data.
__PACKAGE__->mappings->{sayHello} = \&SayHello; # will not affect Foo->mappings;

package main;

my $foo = Foo->default; # will be a Foo object
my $bar = Bar->default; # will be a Bar object 

=end code

=cut