Mercurial > pub > Impl
annotate Lib/IMPL/Code/BasePropertyImplementor.pm @ 393:69a1f1508696
minor security refactoring
| author | cin |
|---|---|
| date | Fri, 14 Feb 2014 16:41:12 +0400 |
| parents | 0d63f5273307 |
| children |
| rev | line source |
|---|---|
| 277 | 1 package IMPL::Code::BasePropertyImplementor; |
| 2 use strict; | |
| 3 | |
| 4 use IMPL::Const qw(:prop :access); | |
|
381
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
5 use Scalar::Util qw(looks_like_number); |
| 277 | 6 |
| 7 use constant { | |
| 8 CodeNoGetAccessor => 'die new IMPL::Exception(\'The property is write only\',$name,$class) unless $get;', | |
| 9 CodeNoSetAccessor => 'die new IMPL::Exception(\'The property is read only\',$name,$class) unless $set;', | |
|
381
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
10 CodeCustomGetAccessor => '$this->$get(@_);', |
|
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
11 CodeCustomSetAccessor => '$this->$set(@_);', |
| 277 | 12 CodeValidator => '$this->$validator(@_);', |
| 13 CodeOwnerCheck => "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;" | |
| 14 }; | |
| 15 | |
| 16 sub CodeSetAccessor { | |
| 17 die new IMPL::Exception("Standard accessors not supported",'Set'); | |
| 18 } | |
| 19 | |
| 20 sub CodeGetAccessor { | |
| 21 die new IMPL::Exception("Standard accessors not supported",'Get'); | |
| 22 } | |
| 23 | |
| 24 sub CodeGetListAccessor { | |
| 25 die new IMPL::Exception("Standard accessors not supported",'GetList'); | |
| 26 } | |
| 27 | |
| 28 sub CodeSetListAccessor { | |
| 29 die new IMPL::Exception("Standard accessors not supported",'SetList'); | |
| 30 } | |
| 31 | |
| 32 sub factoryParams { qw($class $name $set $get $validator) }; | |
| 33 | |
| 34 our %ACCESS_CODE = ( | |
| 35 ACCESS_PUBLIC , "", | |
| 36 ACCESS_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);", | |
| 37 ACCESS_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" | |
| 38 ); | |
| 39 | |
| 40 sub NormalizeSpecification { | |
| 41 my ($this,$spec) = @_; | |
| 42 | |
| 385 | 43 return $spec if ref($spec); |
| 44 | |
| 45 if (looks_like_number($spec)) { | |
| 46 return { | |
| 277 | 47 get => $spec & PROP_GET, |
| 48 set => $spec & PROP_SET, | |
| 49 isList => $spec & PROP_LIST, | |
| 278 | 50 ownerSet => (($spec & PROP_OWNERSET) == PROP_OWNERSET), |
| 51 direct => $spec & PROP_DIRECT | |
| 385 | 52 }; |
| 53 } else { | |
| 54 return {}; | |
| 55 } | |
| 277 | 56 } |
| 57 | |
| 58 sub CreateFactoryId { | |
| 59 my ($self, $spec) = @_; | |
| 60 | |
| 61 join( '', | |
| 62 map( | |
| 278 | 63 ($_ |
|
381
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
64 ? ( _isCustom($_) |
| 277 | 65 ? 'x' |
| 278 | 66 : 's') |
| 67 : '_'), | |
| 277 | 68 @$spec{qw(get set)} |
| 69 ), | |
| 278 | 70 $spec->{access} || ACCESS_PUBLIC, |
| 277 | 71 $spec->{validator} ? 'v' : '_', |
| 72 $spec->{isList} ? 'l' : '_', | |
| 73 $spec->{ownerSet} ? 'o' : '_' | |
| 74 ); | |
| 75 } | |
| 76 | |
|
381
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
77 sub _isCustom { |
|
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
78 ref($_[0]) eq 'CODE' || not(ref($_[0]) || looks_like_number($_[0])); |
|
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
79 } |
|
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
80 |
| 277 | 81 sub CreateFactory { |
| 82 my ($self,$spec) = @_; | |
| 83 | |
| 84 return $self->CreateFactoryImpl( | |
| 278 | 85 ($spec->{get} |
|
381
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
86 ? ( _isCustom($spec->{get}) |
| 277 | 87 ? $self->CodeCustomGetAccessor |
| 278 | 88 : ($spec->{isList} |
| 89 ? $self->CodeGetListAccessor | |
| 90 : $self->CodeGetAccessor | |
| 91 ) | |
| 92 ) | |
| 93 : $self->CodeNoGetAccessor | |
| 94 ), | |
| 95 ($spec->{set} | |
|
381
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
96 ? ( _isCustom($spec->{set}) |
| 277 | 97 ? $self->CodeCustomSetAccessor |
| 278 | 98 : ($spec->{isList} |
| 99 ? $self->CodeSetListAccessor | |
| 100 : $self->CodeSetAccessor | |
| 101 ) | |
| 102 ) | |
| 103 : $self->CodeNoSetAccessor | |
| 104 ), | |
| 277 | 105 $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '', |
| 106 $spec->{validator} ? $self->CodeValidator : '', | |
| 107 $spec->{ownerSet} ? $self->CodeOwnerCheck : '' | |
| 108 ); | |
| 109 } | |
| 110 | |
| 111 sub CreateFactoryImpl { | |
| 112 my ($self,$codeGet,$codeSet,$codeAccessCheck,$codeValidator,$codeOwnerCheck) = @_; | |
| 113 | |
| 114 my $strParams = join(',',$self->factoryParams); | |
| 115 | |
| 116 my $factory = <<FACTORY; | |
| 117 | |
| 118 sub { | |
| 119 my ($strParams) = \@_; | |
|
381
ced5937ff21a
Custom getters/setters support method names in theirs definitions
cin
parents:
278
diff
changeset
|
120 return sub { |
| 277 | 121 my \$this = shift; |
| 122 $codeAccessCheck | |
| 123 if (\@_) { | |
| 124 $codeOwnerCheck | |
| 125 $codeValidator | |
| 126 $codeSet | |
| 127 } else { | |
| 128 $codeGet | |
| 129 } | |
| 130 } | |
| 131 } | |
| 132 FACTORY | |
| 133 | |
| 134 return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") ); | |
| 135 } | |
| 136 | |
| 137 | |
| 138 1; | |
| 139 | |
| 140 __END__ | |
| 141 | |
| 142 =pod | |
| 143 | |
| 144 =head1 NAME | |
| 145 | |
| 146 C<IMPL::Code::BasePropertyImplementor> набор впомогательныйх статических методов | |
| 147 для генерации свойств. | |
| 148 | |
| 149 =cut |