|
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,
|
|
|
48 ownerSet => $spec & PROP_OWNERSET
|
|
|
49 };
|
|
|
50 }
|
|
|
51
|
|
|
52 sub CreateFactoryId {
|
|
|
53 my ($self, $spec) = @_;
|
|
|
54
|
|
|
55 join( '',
|
|
|
56 map(
|
|
|
57 $_
|
|
|
58 ? ref $_ eq 'CODE'
|
|
|
59 ? 'x'
|
|
|
60 : 's'
|
|
|
61 : '_',
|
|
|
62 @$spec{qw(get set)}
|
|
|
63 ),
|
|
|
64 $spec->{access},
|
|
|
65 $spec->{validator} ? 'v' : '_',
|
|
|
66 $spec->{isList} ? 'l' : '_',
|
|
|
67 $spec->{ownerSet} ? 'o' : '_'
|
|
|
68 );
|
|
|
69 }
|
|
|
70
|
|
|
71 sub CreateFactory {
|
|
|
72 my ($self,$spec) = @_;
|
|
|
73
|
|
|
74 return $self->CreateFactoryImpl(
|
|
|
75 $spec->{get}
|
|
|
76 ? ref $spec->{get} eq 'CODE'
|
|
|
77 ? $self->CodeCustomGetAccessor
|
|
|
78 : $spec->{isList}
|
|
|
79 ? $spec->CodeGetListAccessor
|
|
|
80 : $spec->CodeGetAccessor
|
|
|
81 : $spec->CodeNoGetAccessor,
|
|
|
82 $spec->{set}
|
|
|
83 ? ref $spec->{set} eq 'CODE'
|
|
|
84 ? $self->CodeCustomSetAccessor
|
|
|
85 : $spec->{isList}
|
|
|
86 ? $spec->CodeSetListAccessor
|
|
|
87 : $spec->CodeSetAccessor
|
|
|
88 : $spec->CodeNoSetAccessor,
|
|
|
89 $ACCESS_CODE{$spec->{access} || ACCESS_PUBLIC} || '',
|
|
|
90 $spec->{validator} ? $self->CodeValidator : '',
|
|
|
91 $spec->{ownerSet} ? $self->CodeOwnerCheck : ''
|
|
|
92 );
|
|
|
93 }
|
|
|
94
|
|
|
95 sub CreateFactoryImpl {
|
|
|
96 my ($self,$codeGet,$codeSet,$codeAccessCheck,$codeValidator,$codeOwnerCheck) = @_;
|
|
|
97
|
|
|
98 my $strParams = join(',',$self->factoryParams);
|
|
|
99
|
|
|
100 my $factory = <<FACTORY;
|
|
|
101
|
|
|
102 sub {
|
|
|
103 my ($strParams) = \@_;
|
|
|
104 my \$accessor;
|
|
|
105 \$accessor = sub {
|
|
|
106 my \$this = shift;
|
|
|
107 $codeAccessCheck
|
|
|
108 if (\@_) {
|
|
|
109 $codeOwnerCheck
|
|
|
110 $codeValidator
|
|
|
111 $codeSet
|
|
|
112 } else {
|
|
|
113 $codeGet
|
|
|
114 }
|
|
|
115 }
|
|
|
116 }
|
|
|
117 FACTORY
|
|
|
118
|
|
|
119 return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") );
|
|
|
120 }
|
|
|
121
|
|
|
122
|
|
|
123 1;
|
|
|
124
|
|
|
125 __END__
|
|
|
126
|
|
|
127 =pod
|
|
|
128
|
|
|
129 =head1 NAME
|
|
|
130
|
|
|
131 C<IMPL::Code::BasePropertyImplementor> набор впомогательныйх статических методов
|
|
|
132 для генерации свойств.
|
|
|
133
|
|
|
134 =cut |
