Mercurial > pub > Impl
changeset 90:dc1da0389db7
Small improvements in the abstract object class
Added support for a class data, documentation
Additional tests for the new functionality
| author | wizard |
|---|---|
| date | Mon, 26 Apr 2010 03:10:03 +0400 |
| parents | 3d1f584aea60 |
| children | 9cb8e730fa86 |
| files | Lib/IMPL/Class/Meta.pm Lib/IMPL/Object/Abstract.pm Lib/IMPL/Serialization/XmlFormatter.pm _test/Test/Class/Meta.pm _test/object.t |
| diffstat | 5 files changed, 273 insertions(+), 29 deletions(-) [+] |
line wrap: on
line diff
--- a/Lib/IMPL/Class/Meta.pm Wed Apr 21 17:39:45 2010 +0400 +++ b/Lib/IMPL/Class/Meta.pm Mon Apr 26 03:10:03 2010 +0400 @@ -1,7 +1,11 @@ package IMPL::Class::Meta; use strict; +use Class::Data::Inheritable; +use Storable qw(dclone); + my %class_meta; +my %class_data; sub set_meta { my ($class,$meta_data) = @_; @@ -32,12 +36,186 @@ wantarray ? @result : \@result; } -=pod -__PACKAGE_->set_meta($metaObject); -__PACKAGE_->get_meta('MyMetaClass',sub { - my ($item) = @_; - $item->Name eq 'Something' ? 1 : 0 -} ); -=cut +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} = dclone($value); + } else { + undef; + } + } + } +} + +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 = $_->_find_class_data($name) and return $val foreach @{"${class}::ISA"}; +} 1; + +__END__ + +=pod + +=head1 NAME + +C<IMPL::Class::Meta> - информация хранимая на уровне класса. + +=head1 SYNOPSIS + +=begin code + +package InfoMeta; + +use base qw(IMPL::Object IMPL::Object::Autofill); +use IMPL::Class::Property; + +__PACKAGE__->PassThroughArgs; + +BEGIN { + public property name => prop_get | owner_set; +} + +package InfoExMeta; +use base 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 base 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 base 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 + +=back + +=cut
--- a/Lib/IMPL/Object/Abstract.pm Wed Apr 21 17:39:45 2010 +0400 +++ b/Lib/IMPL/Object/Abstract.pm Mon Apr 26 03:10:03 2010 +0400 @@ -19,25 +19,25 @@ my $refCTORS = *{"${class}::CTOR"}{HASH}; foreach my $super ( @{"${class}::ISA"} ) { - my $superSequence = $cacheCTOR{$super} || cache_ctor($super); - - my $mapper = $refCTORS ? $refCTORS->{$super} : undef; - if (ref $mapper eq 'CODE') { - if ($mapper == *_pass_throgh_mapper{CODE}) { - push @sequence,@$superSequence; - } else { - push @sequence, sub { - my $this = shift; - $this->$_($mapper->(@_)) foreach @$superSequence; - }; - } - } else { - warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; - push @sequence, sub { - my $this = shift; - $this->$_() foreach @$superSequence; - }; - } + my $superSequence = $cacheCTOR{$super} || cache_ctor($super); + + my $mapper = $refCTORS ? $refCTORS->{$super} : undef; + if (ref $mapper eq 'CODE') { + if ($mapper == *_pass_throgh_mapper{CODE}) { + push @sequence,@$superSequence; + } else { + push @sequence, sub { + my $this = shift; + $this->$_($mapper->(@_)) foreach @$superSequence; + }; + } + } else { + warn "Unsupported mapper type, in '$class' for the super class '$super'" if $mapper; + push @sequence, sub { + my $this = shift; + $this->$_() foreach @$superSequence; + }; + } } push @sequence, *{"${class}::CTOR"}{CODE} if *{"${class}::CTOR"}{CODE}; @@ -46,6 +46,14 @@ return \@sequence; } +sub dump_ctor { + my ($self) = @_; + $self = ref $self || $self; + + warn "dumping $self .ctor"; + warn "$_" foreach @{$cacheCTOR{$self}||[]}; +} + sub callCTOR { my $self = shift; my $class = ref $self;
--- a/Lib/IMPL/Serialization/XmlFormatter.pm Wed Apr 21 17:39:45 2010 +0400 +++ b/Lib/IMPL/Serialization/XmlFormatter.pm Mon Apr 26 03:10:03 2010 +0400 @@ -161,9 +161,9 @@ sub Text { my ($this) = shift; - $_ = shift; - return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and /^\n*\s*\n*$/; - $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($_); + my $text = shift; + return 1 if $this->{'Non-Expat-Options'}->{'SkipWhitespace'} and $text =~ /^\n*\s*\n*$/; + $this->{'Non-Expat-Options'}->{'Handler'}->OnObjectData($text); return 1; }
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/_test/Test/Class/Meta.pm Mon Apr 26 03:10:03 2010 +0400 @@ -0,0 +1,57 @@ +use strict; + +package Test::Class::Meta; +use base qw(IMPL::Test::Unit); + +__PACKAGE__->PassThroughArgs; + +use IMPL::Test qw(test failed); + +test defineFooClassData => sub { + Foo->class_data(info => {}); +}; + +test updateFooClassData => sub { + Foo->class_data('info')->{data} = 'Foo' ; +}; + +test getFooClassData => sub { + failed "Wrong class data", "Expected: Foo", "Got: ".Foo->class_data('info')->{data} unless Foo->class_data('info')->{data} eq 'Foo'; +}; + +test getBazClassData => sub { + failed "Wrong class data", "Expected: Foo", "Got: ".Baz->class_data('info')->{data} unless Baz->class_data('info')->{data} eq 'Foo'; +}; + +test updateBarClassData => sub { + Bar->class_data('info')->{data} = 'Bar'; +}; + +test getBarClassData => sub { + failed "Wrong class data", "Expected: Bar", "Got: ".Bar->class_data('info')->{data} unless Bar->class_data('info')->{data} eq 'Bar'; +}; + +test validatetFooClassData => sub { + failed "Wrong class data", "Expected: Foo", "Got: ".Foo->class_data('info')->{data} unless Foo->class_data('info')->{data} eq 'Foo'; +}; + +test validateBazClassData => sub { + failed "Wrong class data", "Expected: Foo", "Got: ".Baz->class_data('info')->{data} unless Baz->class_data('info')->{data} eq 'Foo'; +}; + +test getwrongBazClassData => sub { + failed "Wrong class data", "Expected: undef", "Got: ".Foo->class_data( 'info2' ) if Foo->class_data( 'info2' ); +}; + + + +package Foo; +use base qw(IMPL::Class::Meta); + +package Bar; +use base qw(Foo); + +package Baz; +use base qw(Foo); + +1;