Mercurial > pub > Impl

comparison Lib/IMPL/Class/Meta.pm @ 90:dc1da0389db7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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 16ada169ca75
children 6c25ea91c985
comparison
equal deleted inserted replaced
89:3d1f584aea60 90:dc1da0389db7
1 package IMPL::Class::Meta; 1 package IMPL::Class::Meta;
2 use strict; 2 use strict;
3 3
4 use Class::Data::Inheritable;
5 use Storable qw(dclone);
6
4 my %class_meta; 7 my %class_meta;
8 my %class_data;
5 9
6 sub set_meta { 10 sub set_meta {
7 my ($class,$meta_data) = @_; 11 my ($class,$meta_data) = @_;
8 $class = ref $class if ref $class; 12 $class = ref $class if ref $class;
9 13
30 push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ); 34 push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) );
31 } 35 }
32 wantarray ? @result : \@result; 36 wantarray ? @result : \@result;
33 } 37 }
34 38
39 sub class_data {
40 my $class = shift;
41 $class = ref $class || $class;
42
43 if (@_ > 1) {
44 my ($name,$value) = @_;
45 return $class_data{$class}{$name} = $value;
46 } else {
47 my ($name) = @_;
48
49 if( exists $class_data{$class}{$name} ) {
50 $class_data{$class}{$name};
51 } else {
52 if ( my $value = $class->_find_class_data($name) ) {
53 $class_data{$class}{$name} = dclone($value);
54 } else {
55 undef;
56 }
57 }
58 }
59 }
60
61 sub _find_class_data {
62 my ($class,$name) = @_;
63
64 no strict 'refs';
65
66 exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"};
67
68 my $val;
69 $val = $_->_find_class_data($name) and return $val foreach @{"${class}::ISA"};
70 }
71
72 1;
73
74 __END__
75
35 =pod 76 =pod
36 __PACKAGE_->set_meta($metaObject); 77
37 __PACKAGE_->get_meta('MyMetaClass',sub { 78 =head1 NAME
38 my ($item) = @_; 79
39 $item->Name eq 'Something' ? 1 : 0 80 C<IMPL::Class::Meta> - информация хранимая на уровне класса.
40 } ); 81
82 =head1 SYNOPSIS
83
84 =begin code
85
86 package InfoMeta;
87
88 use base qw(IMPL::Object IMPL::Object::Autofill);
89 use IMPL::Class::Property;
90
91 __PACKAGE__->PassThroughArgs;
92
93 BEGIN {
94 public property name => prop_get | owner_set;
95 }
96
97 package InfoExMeta;
98 use base qw(InfoMeta);
99
100 __PACKAGE__->PassThroughArgs;
101
102 BEGIN {
103 public property description => prop_all;
104 }
105
106 package Foo;
107
108 __PACKAGE__->set_meta(new InfoMeta(name => 'info'));
109 __PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' ));
110
111 package main;
112
113 # get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta
114 my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx';
115
116 # get all InfoExMeta meta
117 @info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx'
118
119 # get filtered meta
120 @info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info'
121
122 =end code
123
124 =head1 DESCRIPTION
125
126 Позвоялет расширять информацию о типах (класса) при помощи метаданных, метаданными являются любые объекты,
127 притом выборка метаданных приоизводится по их типу (классу), что позволяет выбрать все однотипные метаданные.
128
129 Существует возможность выборки метаданных с учетом унаследованных от базовых классов
130
131 =head1 MEMBERS
132
133 =over
134
135 =item C<set_meta($meta_data)>
136
137 Добавляет метаданные C<$meta_data> к классу.
138
139 =item C<get_meta($meta_class,$predicate,$deep)>
140
141 Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения
142 метаданных базовых классов.
143
144 =over
145
146 =item C<$meta_class>
147
148 Тип метаданных
149
150 =item C<$predicate>
151
152 Подпрограмма, которая будет вызываться для каждых найденных метаданных и на основе результата
153 ее выполнения метаданные будут включены в результат или нет. Получеат в качестве параметра
154 объект с метаданными, возвращает C<true> - включить метаданные в результа, C<false> - пропустить
155 метаданные как не подходящие. Также переменная C<$_> ссылается на текущий объект с метаданными.
156
157 =begin code
158
159 my @info = Foo->get_meta(
160 'InfoMeta',
161 sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta')
162 1 # deep search
163 );
164
165 my @info = Foo->get_meta(
166 'InfoMeta',
167 sub {
168 my $item = shift;
169 ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta')
170 },
171 1 # deep search
172 );
173
174 =end code
175
176 =item C<$deep>
177
178 Осуществлять поиск по базовым классам.
179
180 =back
181
182 =item C<class_data($name,$new_value)>
183
184 В отличии от метаданных, C<class_data> не накапливает информацию,
185 а хранит только один экземпляр для одного ключа C<$name>.
186
187 Если новое значение не задано, то осуществляется выборка сохраненного,
188 если текущий класс не имеет сохраненного значения, то оно ищется в базовых
189 классах, затем копия найденного значения сохраняется в текущем классе и
190 возвращается наружу. Это позволяет базовым классам задавать значение по-умолчанию,
191 которые могут быть изменены или заменены субклассами.
192
193 =begin code
194
195 package Foo;
196 use base qw(IMPL::Class::Meta);
197
198 __PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses
199
200 sub say_version {
201 my ($self) = @_;
202
203 print $self->class_data(info)->{version};
204 }
205
206 package Bar;
207 use base qw(Foo);
208
209 __PACKAGE__->class_data('info')->{ language } = 'English';
210
211 package main;
212
213 Foo->class_data('info')->{version} = 2;
214 Bar->say_version; # will print '1';
215 Foo->say_version; # will print '2';
216
217 =end code
218
219 =back
220
41 =cut 221 =cut
42
43 1;