|
49
|
1 package IMPL::Class::Meta;
|
|
|
2 use strict;
|
|
|
3
|
|
90
|
4 use Storable qw(dclone);
|
|
|
5
|
|
49
|
6 my %class_meta;
|
|
90
|
7 my %class_data;
|
|
49
|
8
|
|
|
9 sub set_meta {
|
|
|
10 my ($class,$meta_data) = @_;
|
|
|
11 $class = ref $class if ref $class;
|
|
|
12
|
|
|
13 # тут нельзя использовать стандартное исключение, поскольку для него используется
|
|
|
14 # класс IMPL::Object::Accessor, который наследуется от текущего класса
|
|
|
15 die "The meta_data parameter should be an object" if not ref $meta_data;
|
|
|
16
|
|
|
17 push @{$class_meta{$class}{ref $meta_data}},$meta_data;
|
|
|
18 }
|
|
|
19
|
|
|
20 sub get_meta {
|
|
|
21 my ($class,$meta_class,$predicate,$deep) = @_;
|
|
|
22 $class = ref $class if ref $class;
|
|
|
23 no strict 'refs';
|
|
|
24 my @result;
|
|
|
25
|
|
|
26 if ($deep) {
|
|
|
27 @result = map { $_->can('get_meta') ? $_->get_meta($meta_class,$predicate,$deep) : () } @{$class.'::ISA'};
|
|
|
28 }
|
|
|
29
|
|
|
30 if ($predicate) {
|
|
|
31 push @result,grep( &$predicate($_), map( @{$class_meta{$class}{$_}}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ) );
|
|
|
32 } else {
|
|
|
33 push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) );
|
|
|
34 }
|
|
|
35 wantarray ? @result : \@result;
|
|
|
36 }
|
|
|
37
|
|
90
|
38 sub class_data {
|
|
|
39 my $class = shift;
|
|
|
40 $class = ref $class || $class;
|
|
|
41
|
|
|
42 if (@_ > 1) {
|
|
|
43 my ($name,$value) = @_;
|
|
|
44 return $class_data{$class}{$name} = $value;
|
|
|
45 } else {
|
|
|
46 my ($name) = @_;
|
|
|
47
|
|
|
48 if( exists $class_data{$class}{$name} ) {
|
|
|
49 $class_data{$class}{$name};
|
|
|
50 } else {
|
|
|
51 if ( my $value = $class->_find_class_data($name) ) {
|
|
|
52 $class_data{$class}{$name} = dclone($value);
|
|
|
53 } else {
|
|
|
54 undef;
|
|
|
55 }
|
|
|
56 }
|
|
|
57 }
|
|
|
58 }
|
|
|
59
|
|
163
|
60 sub static_accessor {
|
|
|
61 my ($class,$name,$value) = @_;
|
|
|
62 $class = ref $class || $class;
|
|
|
63
|
|
|
64 no strict 'refs';
|
|
|
65
|
|
|
66 *{"${class}::${name}"} = sub {
|
|
|
67 if (@_ > 1) {
|
|
|
68 my $self = shift;
|
|
|
69 $self = ref $self || $self;
|
|
|
70
|
|
|
71 if ($class ne $self) {
|
|
164
|
72 $self->static_accessor( $name => $_[0]); # define own class data
|
|
163
|
73 } else {
|
|
|
74 $value = $_[0];
|
|
|
75 }
|
|
|
76 } else {
|
|
|
77 $value;
|
|
|
78 }
|
|
|
79 };
|
|
|
80 $value
|
|
|
81 };
|
|
|
82
|
|
90
|
83 sub _find_class_data {
|
|
|
84 my ($class,$name) = @_;
|
|
|
85
|
|
|
86 no strict 'refs';
|
|
|
87
|
|
|
88 exists $class_data{$_}{$name} and return $class_data{$_}{$name} foreach @{"${class}::ISA"};
|
|
|
89
|
|
|
90 my $val;
|
|
153
|
91 $val = $_->can('_find_class_data') ? $_->_find_class_data($name) : undef and return $val foreach @{"${class}::ISA"};
|
|
90
|
92 }
|
|
49
|
93
|
|
|
94 1;
|
|
90
|
95
|
|
|
96 __END__
|
|
|
97
|
|
|
98 =pod
|
|
|
99
|
|
|
100 =head1 NAME
|
|
|
101
|
|
|
102 C<IMPL::Class::Meta> - информация хранимая на уровне класса.
|
|
|
103
|
|
|
104 =head1 SYNOPSIS
|
|
|
105
|
|
|
106 =begin code
|
|
|
107
|
|
|
108 package InfoMeta;
|
|
|
109
|
|
165
|
110 use parent qw(IMPL::Object IMPL::Object::Autofill);
|
|
90
|
111 use IMPL::Class::Property;
|
|
|
112
|
|
|
113 __PACKAGE__->PassThroughArgs;
|
|
|
114
|
|
|
115 BEGIN {
|
|
|
116 public property name => prop_get | owner_set;
|
|
|
117 }
|
|
|
118
|
|
|
119 package InfoExMeta;
|
|
165
|
120 use parent qw(InfoMeta);
|
|
90
|
121
|
|
|
122 __PACKAGE__->PassThroughArgs;
|
|
|
123
|
|
|
124 BEGIN {
|
|
|
125 public property description => prop_all;
|
|
|
126 }
|
|
|
127
|
|
|
128 package Foo;
|
|
|
129
|
|
|
130 __PACKAGE__->set_meta(new InfoMeta(name => 'info'));
|
|
|
131 __PACKAGE__->set_meta(new InfoExMeta(name => 'infoEx', description => 'extended info' ));
|
|
|
132
|
|
|
133 package main;
|
|
|
134
|
|
|
135 # get all InfoMeta, InfoExMeta will be included, becouse it's derived from InfoMeta
|
|
|
136 my @info = Foo->get_meta('InfoMeta'); # will get two objects, 'info' and 'infoEx';
|
|
|
137
|
|
|
138 # get all InfoExMeta meta
|
|
|
139 @info = Foo->get_meta('InfoExMeta'); # will get only 'infoEx'
|
|
|
140
|
|
|
141 # get filtered meta
|
|
|
142 @info = Foo->get_meta('InfoMeta', sub { $_->name eq 'info'} ); # will get only 'info'
|
|
|
143
|
|
|
144 =end code
|
|
|
145
|
|
|
146 =head1 DESCRIPTION
|
|
|
147
|
|
|
148 Позвоялет расширять информацию о типах (класса) при помощи метаданных, метаданными являются любые объекты,
|
|
|
149 притом выборка метаданных приоизводится по их типу (классу), что позволяет выбрать все однотипные метаданные.
|
|
|
150
|
|
|
151 Существует возможность выборки метаданных с учетом унаследованных от базовых классов
|
|
|
152
|
|
|
153 =head1 MEMBERS
|
|
|
154
|
|
|
155 =over
|
|
|
156
|
|
|
157 =item C<set_meta($meta_data)>
|
|
|
158
|
|
|
159 Добавляет метаданные C<$meta_data> к классу.
|
|
|
160
|
|
|
161 =item C<get_meta($meta_class,$predicate,$deep)>
|
|
|
162
|
|
|
163 Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения
|
|
|
164 метаданных базовых классов.
|
|
|
165
|
|
|
166 =over
|
|
|
167
|
|
|
168 =item C<$meta_class>
|
|
|
169
|
|
|
170 Тип метаданных
|
|
|
171
|
|
|
172 =item C<$predicate>
|
|
|
173
|
|
|
174 Подпрограмма, которая будет вызываться для каждых найденных метаданных и на основе результата
|
|
|
175 ее выполнения метаданные будут включены в результат или нет. Получеат в качестве параметра
|
|
|
176 объект с метаданными, возвращает C<true> - включить метаданные в результа, C<false> - пропустить
|
|
|
177 метаданные как не подходящие. Также переменная C<$_> ссылается на текущий объект с метаданными.
|
|
|
178
|
|
|
179 =begin code
|
|
|
180
|
|
|
181 my @info = Foo->get_meta(
|
|
|
182 'InfoMeta',
|
|
|
183 sub { ref $_ eq 'InfoMeta'}, # exclude subclasses ('InfoExMeta')
|
|
|
184 1 # deep search
|
|
|
185 );
|
|
|
186
|
|
|
187 my @info = Foo->get_meta(
|
|
|
188 'InfoMeta',
|
|
|
189 sub {
|
|
|
190 my $item = shift;
|
|
|
191 ref $item eq 'InfoMeta' # exclude subclasses ('InfoExMeta')
|
|
|
192 },
|
|
|
193 1 # deep search
|
|
|
194 );
|
|
|
195
|
|
|
196 =end code
|
|
|
197
|
|
|
198 =item C<$deep>
|
|
|
199
|
|
|
200 Осуществлять поиск по базовым классам.
|
|
|
201
|
|
|
202 =back
|
|
|
203
|
|
|
204 =item C<class_data($name,$new_value)>
|
|
|
205
|
|
|
206 В отличии от метаданных, C<class_data> не накапливает информацию,
|
|
|
207 а хранит только один экземпляр для одного ключа C<$name>.
|
|
|
208
|
|
|
209 Если новое значение не задано, то осуществляется выборка сохраненного,
|
|
|
210 если текущий класс не имеет сохраненного значения, то оно ищется в базовых
|
|
|
211 классах, затем копия найденного значения сохраняется в текущем классе и
|
|
|
212 возвращается наружу. Это позволяет базовым классам задавать значение по-умолчанию,
|
|
|
213 которые могут быть изменены или заменены субклассами.
|
|
|
214
|
|
|
215 =begin code
|
|
|
216
|
|
|
217 package Foo;
|
|
165
|
218 use parent qw(IMPL::Class::Meta);
|
|
90
|
219
|
|
|
220 __PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses
|
|
|
221
|
|
|
222 sub say_version {
|
|
|
223 my ($self) = @_;
|
|
|
224
|
|
111
|
225 print $self->class_data('info')->{version};
|
|
90
|
226 }
|
|
|
227
|
|
|
228 package Bar;
|
|
165
|
229 use parent qw(Foo);
|
|
90
|
230
|
|
|
231 __PACKAGE__->class_data('info')->{ language } = 'English';
|
|
|
232
|
|
|
233 package main;
|
|
|
234
|
|
|
235 Foo->class_data('info')->{version} = 2;
|
|
|
236 Bar->say_version; # will print '1';
|
|
|
237 Foo->say_version; # will print '2';
|
|
|
238
|
|
163
|
239 =end code
|
|
|
240
|
|
|
241 =item C<static_accessor($name[,$value])>
|
|
|
242
|
|
|
243 Создает статическое свойство с именем C<$name> и начальным значением C<$value>.
|
|
|
244
|
|
|
245 Использование данного свойство аналогично использованию C<class_data>, за исключением
|
|
|
246 того, что C<class_data> гарантирует, что наследник обладает собственной копией данных,
|
|
|
247 изменение которых не коснется ни базового класса, ни соседей.
|
|
|
248
|
|
|
249 =begin code
|
|
|
250
|
|
|
251 package Foo;
|
|
165
|
252 use parent qw(IMPL::Class::Meta);
|
|
163
|
253
|
|
|
254 __PACKAGE__->static_accessor( info => { version => 1 } );
|
|
|
255
|
|
|
256 package Bar;
|
|
165
|
257 use parent qw(Foo);
|
|
163
|
258
|
|
|
259 __PACKAGE__->info->{language} = 'English'; # Foo->info->{language} will become 'English' to!!!
|
|
|
260 __PACKAGE__->info({language => 'English'}); # will define own 'info' but will loose original data.
|
|
|
261
|
|
|
262 =end code
|
|
|
263
|
|
90
|
264
|
|
|
265 =back
|
|
|
266
|
|
|
267 =cut
|
