Mercurial > pub > Impl
view Lib/IMPL/Class/Meta.pm @ 290:7b0dad6117d5
*TTView: fixed memory leak
author | sergey |
---|---|
date | Wed, 20 Feb 2013 17:24:57 +0400 |
parents | c6d0f889ef87 |
children | 7c784144d2f1 |
line wrap: on
line source
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 ($deep) { @result = map { $_->can('GetMeta') ? $_->GetMeta($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