--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/IMPL/Class/Meta.pm	Fri Sep 04 19:40:23 2015 +0300
@@ -0,0 +1,344 @@
+package IMPL::Class::Meta;
+use strict;
+
+use Carp qw(carp confess);
+use IMPL::clone qw(clone);
+
+my %class_meta;
+my %class_data;
+
+sub SetMeta {
+    my ($class,$meta_data) = @_;
+    $class = ref $class || $class;
+    
+    # тут нельзя использовать стандартное исключение, поскольку для него используется
+    # класс IMPL::Object::Accessor, который наследуется от текущего класса
+    confess "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 ($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} || {}} ) );
+    }
+    
+    if ($deep) {
+        push @result, map { $_->can('GetMeta') ? $_->GetMeta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'};
+    }
+    
+    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