|
407
|
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
|
