# HG changeset patch
# User wizard
# Date 1272237003 -14400
# Node ID dc1da0389db718a48a11cc3fff2d05bf411f6bca
# Parent  3d1f584aea608a42b394da85b936d2e459a31b6f
Small improvements in the abstract object class
Added support for a class data, documentation
Additional tests for the new functionality

diff -r 3d1f584aea60 -r dc1da0389db7 Lib/IMPL/Class/Meta.pm
--- 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
diff -r 3d1f584aea60 -r dc1da0389db7 Lib/IMPL/Object/Abstract.pm
--- 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;
diff -r 3d1f584aea60 -r dc1da0389db7 Lib/IMPL/Serialization/XmlFormatter.pm
--- 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;
 }
 
diff -r 3d1f584aea60 -r dc1da0389db7 _test/Test/Class/Meta.pm
--- /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;
diff -r 3d1f584aea60 -r dc1da0389db7 _test/object.t
--- a/_test/object.t	Wed Apr 21 17:39:45 2010 +0400
+++ b/_test/object.t	Mon Apr 26 03:10:03 2010 +0400
@@ -7,6 +7,7 @@
 use IMPL::Test::TAPListener;
 
 my $plan = new IMPL::Test::Plan qw(
+	Test::Class::Meta
     Test::Object::Common
     Test::Object::List
 );