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