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 (2010-04-25) |
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;