annotate Lib/IMPL/Code/BasePropertyImplementor.pm @ 368:010ceafd0c5a

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