Mercurial > pub > Impl
annotate Lib/IMPL/Class/Property/Base.pm @ 276:8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
author | sergey |
---|---|
date | Thu, 31 Jan 2013 17:37:44 +0400 |
parents | 6253872024a4 |
children | 6585464c4664 |
rev | line source |
---|---|
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
1 package IMPL::Class::Property::Base; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
2 use strict; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
3 |
230 | 4 use IMPL::Const qw(:all); |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
5 |
60
b0c068da93ac
Lazy activation for the configuration objects (final concept)
wizard
parents:
59
diff
changeset
|
6 sub factoryParams { qw($class $name $set $get $validator) }; |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
7 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
8 my %factoryCache; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
9 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
10 my $accessor_get_no = 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;'; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
11 my $accessor_set_no = 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;'; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
12 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
13 my $custom_accessor_get = 'unshift @_, $this and goto &$get;'; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
14 my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
15 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
16 my $validator_code = '$this->$validator(@_);'; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
17 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
18 my %access_code = ( |
230 | 19 ACCESS_PUBLIC , "", |
20 ACCESS_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);", | |
21 ACCESS_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
22 ); |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
23 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
24 my $virtual_call = q( |
194 | 25 my $method = $this->can($name); |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
26 return $this->$method(@_) unless $method == $accessor or caller->isa($class); |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
27 ); |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
28 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
29 my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;"; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
30 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
31 sub GenerateAccessors { |
194 | 32 my ($self,$param,@params) = @_; |
33 | |
34 my %accessors; | |
35 | |
36 if (not ref $param) { | |
230 | 37 if ($param & PROP_LIST) { |
38 $accessors{get} = ($param & PROP_GET) ? $self->GenerateGetList(@params) : undef; | |
39 $accessors{set} = ($param & PROP_SET) ? $self->GenerateSetList(@params) : undef; | |
194 | 40 } else { |
230 | 41 $accessors{get} = ($param & PROP_GET) ? $self->GenerateGet(@params) : undef; |
42 $accessors{set} = ($param & PROP_SET) ? $self->GenerateSet(@params) : undef; | |
194 | 43 } |
230 | 44 $accessors{owner} = (($param & PROP_OWNERSET) == PROP_OWNERSET) ? $owner_check : ""; |
194 | 45 } elsif (UNIVERSAL::isa($param,'HASH')) { |
46 $accessors{get} = $param->{get} ? $custom_accessor_get : undef; | |
47 $accessors{set} = $param->{set} ? $custom_accessor_set : undef; | |
48 $accessors{owner} = ""; | |
49 } else { | |
50 die new IMPL::Exception('The unsupported accessor/mutators supplied',$param); | |
51 } | |
52 | |
53 return \%accessors; | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
54 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
55 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
56 sub GenerateSet { |
194 | 57 die new IMPL::Exception("Standard accessors not supported",'Set'); |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
58 } |
194 | 59 |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
60 sub GenerateGet { |
194 | 61 die new IMPL::Exception("Standard accessors not supported",'Get'); |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
62 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
63 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
64 sub GenerateGetList { |
194 | 65 die new IMPL::Exception("Standard accessors not supported",'GetList'); |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
66 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
67 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
68 sub GenerateSetList { |
194 | 69 my ($self) = @_; |
70 die new IMPL::Exception("Standard accessors not supported",'SetList'); | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
71 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
72 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
73 sub Make { |
194 | 74 my ($self,$propInfo) = @_; |
75 | |
76 my $key = $self->MakeFactoryKey($propInfo); | |
77 | |
78 my $factoryInfo = $factoryCache{$key}; | |
79 | |
80 unless ($factoryInfo) { | |
275 | 81 my $mutators = $self->GenerateAccessors($propInfo->mutators); |
194 | 82 $factoryInfo = { |
83 factory => $self->CreateFactory( | |
275 | 84 $access_code{ $propInfo->access }, |
85 $propInfo->attributes->{validator} ? $validator_code : "", | |
194 | 86 $mutators->{owner}, |
87 $mutators->{get} || $accessor_get_no, | |
88 $mutators->{set} || $accessor_set_no | |
89 ), | |
90 mutators => $mutators | |
91 }; | |
92 $factoryCache{$key} = $factoryInfo; | |
93 } | |
94 | |
95 { | |
96 no strict 'refs'; | |
275 | 97 *{ $propInfo->class.'::'.$propInfo->name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo)); |
194 | 98 } |
99 | |
100 my $mutators = $factoryInfo->{mutators}; | |
101 | |
102 $propInfo->canGet( $mutators->{get} ? 1 : 0 ); | |
103 $propInfo->canSet( $mutators->{set} ? 1 : 0 ); | |
104 $propInfo->ownerSet( $mutators->{owner} ); | |
105 | |
106 1; | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
107 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
108 |
230 | 109 sub Implement { |
276
8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
sergey
parents:
275
diff
changeset
|
110 my ($self, $name, $spec) = @_; |
8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
sergey
parents:
275
diff
changeset
|
111 |
8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
sergey
parents:
275
diff
changeset
|
112 { |
8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
sergey
parents:
275
diff
changeset
|
113 name => |
8a5da17d7ef9
*IMPL::Class refactoring property definition mechanism (incomplete).
sergey
parents:
275
diff
changeset
|
114 } |
230 | 115 } |
116 | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
117 # extract from property info: class, name, get_accessor, set_accessor, validator |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
118 sub RemapFactoryParams { |
194 | 119 my ($self,$propInfo) = @_; |
120 | |
275 | 121 my $mutators = $propInfo->mutators; |
122 my $class = $propInfo->class; | |
123 my $validator = $propInfo->attributes->{validator}; | |
194 | 124 |
125 die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator); | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
126 |
194 | 127 return ( |
275 | 128 $propInfo->get(qw(class name)), |
194 | 129 (ref $mutators? |
130 ($mutators->{set},$mutators->{get}) | |
131 : | |
132 (undef,undef) | |
133 ), | |
134 $validator | |
135 ); | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
136 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
137 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
138 sub MakeFactoryKey { |
194 | 139 my ($self,$propInfo) = @_; |
140 | |
275 | 141 my ($access,$mutators,$validator) = ($propInfo->get(qw(access mutators)),$propInfo->attributes->{validator}); |
194 | 142 |
143 my $implementor = ref $self || $self; | |
144 | |
145 return join ('', | |
146 $implementor, | |
147 $access, | |
148 $validator ? 'v' : 'n', | |
149 ref $mutators ? | |
150 ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0) | |
151 : | |
152 ('s',$mutators) | |
153 ); | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
154 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
155 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
156 sub CreateFactory { |
194 | 157 my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_; |
158 | |
159 my $strParams = join(',',$self->factoryParams); | |
160 | |
161 my $factory = <<FACTORY; | |
162 | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
163 sub { |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
164 my ($strParams) = \@_; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
165 my \$accessor; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
166 \$accessor = sub { |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
167 my \$this = shift; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
168 $codeAccessCheck |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
169 if (\@_) { |
194 | 170 $codeOwnerCheck |
171 $codeValidator | |
172 $codeSet | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
173 } else { |
194 | 174 $codeGet |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
175 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
176 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
177 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
178 FACTORY |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
179 |
194 | 180 return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") ); |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
181 } |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
182 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
183 1; |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
184 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
185 __END__ |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
186 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
187 =pod |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
188 |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
189 =head1 DESCRIPTION |
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
190 |
180 | 191 Базовый класс для реализации свойств. |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
192 |
180 | 193 По существу свойства состоят из двух методов для установки и получения значений. Также |
194 существует несколько вариантов доступа к свойству, и метод верификации значения. Еще | |
195 свойства могут быть виртуальными. | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
196 |
180 | 197 Для создания реализатора свойств достаточно унаследовать от этого класса и описать |
198 методы для генерации кода получения и установки значения. | |
80 | 199 |
200 =head1 MEMBERS | |
201 | |
202 =over | |
203 | |
204 =item C<Make($propertyInfo)> | |
205 | |
180 | 206 Создает свойство у класса, на основе C<$propertyInfo>, описывающего свойство. C<IMPL::Class::PropertyInfo>. |
80 | 207 |
208 =back | |
59
0f3e369553bd
Rewritten property implementation (probably become slower but more flexible)
wizard
parents:
diff
changeset
|
209 |
180 | 210 =cut |