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