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