Mercurial > pub > Impl

comparison Lib/IMPL/Class/Meta.pm @ 209:a8db61d0ed33

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
IMPL::Class::Meta refactoring
author cin
date Mon, 28 May 2012 19:58:56 +0400
parents 4d0e1962161c
children 47f77e6409f7
comparison
equal deleted inserted replaced
208:3d433a977e3b 209:a8db61d0ed33
1 package IMPL::Class::Meta; 1 package IMPL::Class::Meta;
2 use strict; 2 use strict;
3 3
4 use Carp qw(carp);
4 use IMPL::clone qw(clone); 5 use IMPL::clone qw(clone);
5 6
6 my %class_meta; 7 my %class_meta;
7 my %class_data; 8 my %class_data;
8 9
9 sub set_meta { 10 sub SetMeta {
10 my ($class,$meta_data) = @_; 11 my ($class,$meta_data) = @_;
11 $class = ref $class if ref $class; 12 $class = ref $class if ref $class;
12 13
13 # тут нельзя использовать стандартное исключение, поскольку для него используется 14 # тут нельзя использовать стандартное исключение, поскольку для него используется
14 # класс IMPL::Object::Accessor, который наследуется от текущего класса 15 # класс IMPL::Object::Accessor, который наследуется от текущего класса
15 die "The meta_data parameter should be an object" if not ref $meta_data; 16 die "The meta_data parameter should be an object" if not ref $meta_data;
16 17
17 push @{$class_meta{$class}{ref $meta_data}},$meta_data; 18 push @{$class_meta{$class}{ref $meta_data}},$meta_data;
18 } 19 }
19 20
20 sub get_meta { 21 sub set_meta {
22 goto &SetMeta;
23 }
24
25 sub GetMeta {
21 my ($class,$meta_class,$predicate,$deep) = @_; 26 my ($class,$meta_class,$predicate,$deep) = @_;
22 $class = ref $class if ref $class; 27 $class = ref $class if ref $class;
23 no strict 'refs'; 28 no strict 'refs';
24 my @result; 29 my @result;
25 30
33 push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) ); 38 push @result, map( @{$class_meta{$class}{$_} || []}, grep( $_->isa($meta_class), keys %{$class_meta{$class} || {}} ) );
34 } 39 }
35 wantarray ? @result : \@result; 40 wantarray ? @result : \@result;
36 } 41 }
37 42
43 sub get_meta {
44 goto &GetMeta;
45 }
46
38 sub class_data { 47 sub class_data {
39 my $class = shift; 48 my $class = shift;
40 $class = ref $class || $class; 49 $class = ref $class || $class;
50
51 carp 'The method is obsolete, use static_accessor($name,$value,\'clone\') instead';
41 52
42 if (@_ > 1) { 53 if (@_ > 1) {
43 my ($name,$value) = @_; 54 my ($name,$value) = @_;
44 return $class_data{$class}{$name} = $value; 55 return $class_data{$class}{$name} = $value;
45 } else { 56 } else {
56 } 67 }
57 } 68 }
58 } 69 }
59 70
60 sub static_accessor { 71 sub static_accessor {
61 my ($class,$name,$value) = @_; 72 my ($class,$name,$value,$clone) = @_;
62 $class = ref $class || $class; 73 $class = ref $class || $class;
63 74
64 no strict 'refs'; 75 no strict 'refs';
65 76
66 *{"${class}::${name}"} = sub { 77 *{"${class}::${name}"} = sub {
67 if (@_ > 1) { 78 my $self = shift;
68 my $self = shift; 79
69 $self = ref $self || $self; 80 if (@_ > 0) {
81 $self = ref $self || $self;
70 82
71 if ($class ne $self) { 83 if ($class ne $self) {
72 $self->static_accessor( $name => $_[0]); # define own class data 84 $self->static_accessor( $name => $_[0] ); # define own class data
73 } else { 85 } else {
74 $value = $_[0]; 86 $value = $_[0];
75 } 87 }
76 } else { 88 } else {
77 $value; 89 ($clone and $class ne $self)
90 ? $self->static_accessor($name => clone($value),$clone)
91 : $value and $value ;
78 } 92 }
79 }; 93 };
80 $value 94 $value
81 }; 95 };
82 96
150 164
151 Существует возможность выборки метаданных с учетом унаследованных от базовых классов 165 Существует возможность выборки метаданных с учетом унаследованных от базовых классов
152 166
153 =head1 MEMBERS 167 =head1 MEMBERS
154 168
155 =over 169 =head2 C<set_meta($meta_data)>
156
157 =item C<set_meta($meta_data)>
158 170
159 Добавляет метаданные C<$meta_data> к классу. 171 Добавляет метаданные C<$meta_data> к классу.
160 172
161 =item C<get_meta($meta_class,$predicate,$deep)> 173 =head2 C<get_meta($meta_class,$predicate,$deep)>
162 174
163 Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения 175 Выбирает метаданные типа C<$meta_class> и его наследников, с возможностью фильтрации и получения
164 метаданных базовых классов. 176 метаданных базовых классов.
165 177
166 =over 178 =over
199 211
200 Осуществлять поиск по базовым классам. 212 Осуществлять поиск по базовым классам.
201 213
202 =back 214 =back
203 215
204 =item C<class_data($name,$new_value)> 216 =head2 C<static_accessor($name[,$value[,$clone]])>
205 217
206 В отличии от метаданных, C<class_data> не накапливает информацию, 218 Создает статическое свойство с именем C<$name> и начальным значением C<$value>.
207 а хранит только один экземпляр для одного ключа C<$name>. 219
208 220 Параметр C<$clone> контролирует то, как наследуются значения, если требуется каждому классу обеспечить
209 Если новое значение не задано, то осуществляется выборка сохраненного, 221 свое уникальное значение, то при первом обращении оно будет клонировано, по умолчанию клонирование не
210 если текущий класс не имеет сохраненного значения, то оно ищется в базовых 222 происходит.
211 классах, затем копия найденного значения сохраняется в текущем классе и
212 возвращается наружу. Это позволяет базовым классам задавать значение по-умолчанию,
213 которые могут быть изменены или заменены субклассами.
214 223
215 =begin code 224 =begin code
216 225
217 package Foo; 226 package Foo;
218 use parent qw(IMPL::Class::Meta); 227 use parent qw(IMPL::Class::Meta);
219 228
220 __PACKAGE__->class_data( info => { version => 1 } ); # will be default for all subclasses 229 __PACKAGE__->static_accessor( info => { version => 1 } );
221
222 sub say_version {
223 my ($self) = @_;
224
225 print $self->class_data('info')->{version};
226 }
227 230
228 package Bar; 231 package Bar;
229 use parent qw(Foo); 232 use parent qw(Foo);
230 233
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
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;
252 use parent qw(IMPL::Class::Meta);
253
254 __PACKAGE__->static_accessor( info => { version => 1 } );
255
256 package Bar;
257 use parent qw(Foo);
258
259 __PACKAGE__->info->{language} = 'English'; # Foo->info->{language} will become 'English' to!!! 234 __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. 235 __PACKAGE__->info({language => 'English'}); # will define own 'info' but will loose original data.
261 236
262 =end code 237 =end code
263
264
265 =back
266 238
267 =cut 239 =cut