|
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 };
|
|
411
|
53 } elsif ($spec =~ /(\*)?(r)?(w)?/) {
|
|
|
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 {
|
|
411
|
61 return 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 |
