407
+ − 1 package IMPL::Code::BasePropertyImplementor;
+ − 2 use strict;
+ − 3
+ − 4 use IMPL::Const qw(:prop :access);
+ − 5 use Scalar::Util qw(looks_like_number);
+ − 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;',
+ − 10 CodeCustomGetAccessor => '$this->$get(@_);',
+ − 11 CodeCustomSetAccessor => '$this->$set(@_);',
+ − 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
+ − 43 return $spec if ref($spec);
+ − 44
+ − 45 if (looks_like_number($spec)) {
+ − 46 return {
+ − 47 get => $spec & PROP_GET,
+ − 48 set => $spec & PROP_SET,
+ − 49 isList => $spec & PROP_LIST,
+ − 50 ownerSet => (($spec & PROP_OWNERSET) == PROP_OWNERSET),
+ − 51 direct => $spec & PROP_DIRECT
+ − 52 };
421
+ − 53 } elsif ($spec =~ /^(\*)?(ro?)?(w)?$/) {
411
+ − 54 return {
+ − 55 get => $2 ? 1 : 0,
417
+ − 56 set => 1,
+ − 57 ownerSet => not($3),
411
+ − 58 direct => $1 ? 1 : 0
+ − 59 };
407
+ − 60 } else {
421
+ − 61 die IMPL::Exception->new("Invalid property specification","$spec");
407
+ − 62 }
+ − 63 }
+ − 64
+ − 65 sub CreateFactoryId {
+ − 66 my ($self, $spec) = @_;
+ − 67
+ − 68 join( '',
+ − 69 map(
+ − 70 ($_
+ − 71 ? ( _isCustom($_)
+ − 72 ? 'x'
+ − 73 : 's')
+ − 74 : '_'),
+ − 75 @$spec{qw(get set)}
+ − 76 ),
+ − 77 $spec->{access} || ACCESS_PUBLIC,
+ − 78 $spec->{validator} ? 'v' : '_',
+ − 79 $spec->{isList} ? 'l' : '_',
+ − 80 $spec->{ownerSet} ? 'o' : '_'
+ − 81 );
+ − 82 }
+ − 83
+ − 84 sub _isCustom {
+ − 85 ref($_[0]) eq 'CODE' || not(ref($_[0]) || looks_like_number($_[0]));
+ − 86 }
+ − 87
+ − 88 sub CreateFactory {
+ − 89 my ($self,$spec) = @_;
+ − 90
+ − 91 return $self->CreateFactoryImpl(
+ − 92 ($spec->{get}
+ − 93 ? ( _isCustom($spec->{get})
+ − 94 ? $self->CodeCustomGetAccessor
+ − 95 : ($spec->{isList}
+ − 96 ? $self->CodeGetListAccessor
+ − 97 : $self->CodeGetAccessor
+ − 98 )
+ − 99 )
+ − 100 : $self->CodeNoGetAccessor
+ − 101 ),
+ − 102 ($spec->{set}
+ − 103 ? ( _isCustom($spec->{set})
+ − 104 ? $self->CodeCustomSetAccessor
+ − 105 : ($spec->{isList}
+ − 106 ? $self->CodeSetListAccessor
+ − 107 : $self->CodeSetAccessor
+ − 108 )
+ − 109 )
+ − 110 : $self->CodeNoSetAccessor
+ − 111 ),
+ − 112 $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '',
+ − 113 $spec->{validator} ? $self->CodeValidator : '',
+ − 114 $spec->{ownerSet} ? $self->CodeOwnerCheck : ''
+ − 115 );
+ − 116 }
+ − 117
+ − 118 sub CreateFactoryImpl {
+ − 119 my ($self,$codeGet,$codeSet,$codeAccessCheck,$codeValidator,$codeOwnerCheck) = @_;
+ − 120
+ − 121 my $strParams = join(',',$self->factoryParams);
+ − 122
+ − 123 my $factory = <<FACTORY;
+ − 124
+ − 125 sub {
+ − 126 my ($strParams) = \@_;
+ − 127 return sub {
+ − 128 my \$this = shift;
+ − 129 $codeAccessCheck
+ − 130 if (\@_) {
+ − 131 $codeOwnerCheck
+ − 132 $codeValidator
+ − 133 $codeSet
+ − 134 } else {
+ − 135 $codeGet
+ − 136 }
+ − 137 }
+ − 138 }
+ − 139 FACTORY
+ − 140
+ − 141 return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") );
+ − 142 }
+ − 143
+ − 144
+ − 145 1;
+ − 146
+ − 147 __END__
+ − 148
+ − 149 =pod
+ − 150
+ − 151 =head1 NAME
+ − 152
+ − 153 C<IMPL::Code::BasePropertyImplementor> набор впомогательныйх статических методов
+ − 154 для генерации свойств.
+ − 155
+ − 156 =cut