Mercurial > pub > Impl

comparison lib/IMPL/Class/Meta.pm @ 407:c6e90e02dd17 ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
renamed Lib->lib
author cin
date Fri, 04 Sep 2015 19:40:23 +0300
parents
children ee36115f6a34
comparison
equal deleted inserted replaced
406:f23fcb19d3c1 407:c6e90e02dd17
1 package IMPL::Class::Meta;
2 use strict;
3
4 use Carp qw(carp confess);
5 use IMPL::clone qw(clone);
6
7 my %class_meta;
8 my %class_data;
9
10 sub SetMeta {
11 my ($class,$meta_data) = @_;
12 $class = ref $class || $class;
13
14 # тут нельзя использовать стандартное исключение, поскольку для него используется
15 # класс IMPL::Object::Accessor, который наследуется от текущего класса
16 confess "The meta_data parameter should be an object" if not ref $meta_data;
17
18 push @{$class_meta{$class}{ref $meta_data}},$meta_data;
19 }
20
21 sub set_meta {
22 goto &SetMeta;
23 }
24
25 sub GetMeta {
26 my ($class,$meta_class,$predicate,$deep) = @_;
27 $class = ref $class if ref $class;
28 no strict 'refs';
29 my @result;
30
31 if ($predicate) {
32 push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) );
33 } else {
34 push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) );
35 }
36
37 if ($deep) {
38 push @result, map { $_->can('GetMeta') ? $_->GetMeta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'};
39 }
40
41 wantarray ? @result : \@result;
42 }
43
44 sub get_meta {
45 goto &GetMeta;
46 }
47
48 sub class_data {
49 my $class = shift;
50 $class = ref $class || $class;
51
52 carp 'The method is obsolete, use static_accessor($name,$value,\'clone\') instead';
53
54 if (@_ > 1) {
55 my ($name,$value) = @_;
56 return $class_data{$class}{$name} = $value;
57 } else {
58 my ($name) = @_;
59
60 if( exists $class_data{$class}{$name} ) {
61 $class_data{$class}{$name};
62 } else {
63 if ( my $value = $class->_find_class_data($name) ) {
64 $class_data{$class}{$name} = clone($value);
65 } else {
66 undef;
67 }
68 }
69 }
70 }
71
72 sub static_accessor {
73 my ($class,$name,$value,$inherit) = @_;
74
75 $inherit ||= 'inherit';
76
77 my $method = "static_accessor_$inherit";
78
79 return $class->$method($name,$value);
80 }
81
82 sub static_accessor_clone {
83 my ($class,$name,$value) = @_;
84 $class = ref $class || $class;
85
86 no strict 'refs';
87
88 *{"${class}::${name}"} = sub {
89 my $self = shift;
90
91 $self = ref $self || $self;
92
93 if (@_ > 0) {
94 if ($class ne $self) {
95 $self->static_accessor_clone( $name => $_[0] ); # define own class data
96 } else {
97 $value = $_[0];
98 }
99 } else {
100 return $self ne $class
101 ? $self->static_accessor_clone($name => clone($value))
102 : $value;
103 }
104 };
105 return $value;
106 };
107
108 sub static_accessor_inherit {
109 my ($class,$name,$value) = @_;
110
111 no strict 'refs';
112
113 *{"${class}::$name"} = sub {
114 my $self = shift;
115
116 if (@_ > 0) {
117 $self = ref $self || $self;
118
119 if ($class ne $self) {
120 $self->static_accessor_inherit( $name => $_[0] ); # define own class data
121 } else {
122 $value = $_[0];
123 }
124 } else {
125 $value ;
126 }
127 };
128 return $value;
129 }
130
131 sub static_accessor_own {
132 my ($class,$name,$value) = @_;
133
134 no strict 'refs';
135
136 *{"${class}::$name"} = sub {
137 my $self = shift;
138 $self = ref $self || $self;
139
140 if ($class ne $self) {
141 if (@_ > 0) {
142 $self->static_accessor_own( $name => $_[0] ); # define own class data
143 } else {
144 return;
145 }
146 } else {
147 if ( @_ > 0 ) {
148 $value = $_[0];
149 } else {
150 return $value;
151 }
152 }
153 };
154
155 return $value;
156 }
157
158 sub _find_class_data {
159 my ($class,$name) = @_;
160
161 no strict 'refs';
162
163 exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"};
164
165 my $val;
166 $val = $_->can('_find_class_data') ? $_->_find_class_data($name) : undef and return $val foreach @{"${class}::ISA"};
167 }
168
169 1;
170
171 __END__
172
173 =pod
174
175 =head1 NAME
176
177 C<IMPL::Class::Meta> - информация хранимая на уровне класса.
178
179 =head1 SYNOPSIS
180
181 =begin code
182
183 package InfoMeta;
184
185 use parent qw(IMPL::Object IMPL::Object::Autofill);
186 use IMPL::Class::Property;
187
188 __PACKAGE__->PassThroughArgs;
189
190 BEGIN {
191 public property name => prop_get | owner_set;
192 }
193
194 package InfoExMeta;
195 use parent qw(InfoMeta);
196
197 __PACKAGE__->PassThroughArgs;
198
199 BEGIN {
200 public property description => prop_all;
201 }
202
203 package Foo;
204
205 __PACKAGE__->set_meta(new InfoMeta(name => 'info'));
206 __PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' ));
207
208 package main;
209
210 # get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta
211 my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx';
212
213 # get all InfoExMeta meta
214 @info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx'
215
216 # get filtered meta
217 @info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info'
218
219 =end code
220
221 =head1 DESCRIPTION
222
223 Позвоялет расширять информацию о типах (класса) при помощи метаданных, метаданными являются любые объекты,
224 притом выборка метаданных приоизводится по их типу (классу), что позволяет выбрать все однотипные метаданные.
225
226 Существует возможность выборки метаданных с учетом унаследованных от базовых классов
227
228 =head1 MEMBERS
229
230 =head2 C<set_meta($meta_data)>
231
232 Добавляет метаданные C<$meta_data> к классу.
233
234 =head2 C<get_meta($meta_class,$predicate,$deep)>
235
236 Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения
237 метаданных базовых классов.
238
239 =over
240
241 =item C<$meta_class>
242
243 Тип метаданных
244
245 =item C<$predicate>
246
247 Подпрограмма, которая будет вызываться для каждых найденных метаданных и на основе результата
248 ее выполнения метаданные будут включены в результат или нет. Получеат в качестве параметра
249 объект с метаданными, возвращает C<true> - включить метаданные в результа, C<false> - пропустить
250 метаданные как не подходящие. Также переменная C<$_> ссылается на текущий объект с метаданными.
251
252 =begin code
253
254 my @info = Foo->get_meta(
255 'InfoMeta',
256 sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta')
257 1 # deep search
258 );
259
260 my @info = Foo->get_meta(
261 'InfoMeta',
262 sub {
263 my $item = shift;
264 ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta')
265 },
266 1 # deep search
267 );
268
269 =end code
270
271 =item C<$deep>
272
273 Осуществлять поиск по базовым классам.
274
275 =back
276
277 =head2 C<static_accessor($name[,$value[,$inherit]])>
278
279 Создает статическое свойство с именем C<$name> и начальным значением C<$value>.
280
281 Параметр C<$inherit> контролирует то, как наследуются значения.
282
283 =over
284
285 =item * C<inherit>
286
287 По умолчанию. Означает, что если для класса не определено значение, оно будет
288 получено от родителя.
289
290 =item * C<clone>
291
292 Если для класса не определено значение, то оно будет клонировано из
293 родительского значения при первом обращении. Полезно, когда родитель задает
294 значение по-умолчанию, которое разделяется между несколькими потомками,
295 которые модифицирю само значение (например значением является ссылка на хеш,
296 а потомки добавляют или меняют значения в этом хеше).
297
298 =item * C<own>
299
300 Каждый класс имеет свое собственное значение не зависящее от того, что было
301 у предка. Начальное значение для этого статического свойства C<undef>.
302
303 =back
304
305 Данный метод является заглушкой, он передает управление
306 C<static_accessor_inherit>, C<static_accessor_clone>, C<static_accessor_own>
307 соответственно. Эти методы можно вызывать явно
308 C<static_accessor_*($name[,$value])>.
309
310
311 =begin code
312
313 package Foo;
314 use parent qw(IMPL::Class::Meta);
315
316 __PACKAGE__->static_accessor( info => { version => 1 } );
317 __PACKAGE__->static_accessor( mappings => { toString => \&ToString }, 'clone' );
318 __PACKAGE__->static_accessor( _instance => undef, 'own' );
319
320 sub ToString {
321 "[object Foo]";
322 }
323
324 sub default {
325 my ($self) = @_;
326
327 $self = ref $self || $self;
328 return $self->_instance ? $self->_instance : $self->_instance($self->new());
329 }
330
331 package Bar;
332 use parent qw(Foo);
333
334 __PACKAGE__->info({language => 'English', version => 2}); # will define own 'info' but will loose original data.
335 __PACKAGE__->mappings->{sayHello} = \&SayHello; # will not affect Foo->mappings;
336
337 package main;
338
339 my $foo = Foo->default; # will be a Foo object
340 my $bar = Bar->default; # will be a Bar object
341
342 =end code
343
344 =cut