Mercurial > pub > Impl

comparison Lib/IMPL/Class/Property/Base.pm @ 194:4d0e1962161c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Replaced tabs with spaces IMPL::Web::View - fixed document model, new features (control classes, document constructor parameters)
author cin
date Tue, 10 Apr 2012 20:08:29 +0400
parents d1676be8afcc
children 6d8092d8ce1b
comparison
equal deleted inserted replaced
193:8e8401c0aea4 194:4d0e1962161c
16 my $custom_accessor_set = 'unshift @_, $this and goto &$set;'; 16 my $custom_accessor_set = 'unshift @_, $this and goto &$set;';
17 17
18 my $validator_code = '$this->$validator(@_);'; 18 my $validator_code = '$this->$validator(@_);';
19 19
20 my %access_code = ( 20 my %access_code = (
21 IMPL::Class::Member::MOD_PUBLIC , "", 21 IMPL::Class::Member::MOD_PUBLIC , "",
22 IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);", 22 IMPL::Class::Member::MOD_PROTECTED, "die new IMPL::Exception('Can\\'t access the protected member',\$name,\$class,scalar caller) unless UNIVERSAL::isa(scalar caller,\$class);",
23 IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;" 23 IMPL::Class::Member::MOD_PRIVATE, "die new IMPL::Exception('Can\\'t access the private member',\$name,\$class,scalar caller) unless caller eq \$class;"
24 ); 24 );
25 25
26 my $virtual_call = q( 26 my $virtual_call = q(
27 my $method = $this->can($name); 27 my $method = $this->can($name);
28 return $this->$method(@_) unless $method == $accessor or caller->isa($class); 28 return $this->$method(@_) unless $method == $accessor or caller->isa($class);
29 ); 29 );
30 30
31 my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;"; 31 my $owner_check = "die new IMPL::Exception('Set accessor is restricted to the owner',\$name,\$class,scalar caller) unless caller eq \$class;";
32 32
33 sub GenerateAccessors { 33 sub GenerateAccessors {
34 my ($self,$param,@params) = @_; 34 my ($self,$param,@params) = @_;
35 35
36 my %accessors; 36 my %accessors;
37 37
38 if (not ref $param) { 38 if (not ref $param) {
39 if ($param & prop_list) { 39 if ($param & prop_list) {
40 $accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : undef; 40 $accessors{get} = ($param & prop_get) ? $self->GenerateGetList(@params) : undef;
41 $accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : undef; 41 $accessors{set} = ($param & prop_set) ? $self->GenerateSetList(@params) : undef;
42 } else { 42 } else {
43 $accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : undef; 43 $accessors{get} = ($param & prop_get) ? $self->GenerateGet(@params) : undef;
44 $accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : undef; 44 $accessors{set} = ($param & prop_set) ? $self->GenerateSet(@params) : undef;
45 } 45 }
46 $accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : ""; 46 $accessors{owner} = (($param & owner_set) == owner_set) ? $owner_check : "";
47 } elsif (UNIVERSAL::isa($param,'HASH')) { 47 } elsif (UNIVERSAL::isa($param,'HASH')) {
48 $accessors{get} = $param->{get} ? $custom_accessor_get : undef; 48 $accessors{get} = $param->{get} ? $custom_accessor_get : undef;
49 $accessors{set} = $param->{set} ? $custom_accessor_set : undef; 49 $accessors{set} = $param->{set} ? $custom_accessor_set : undef;
50 $accessors{owner} = ""; 50 $accessors{owner} = "";
51 } else { 51 } else {
52 die new IMPL::Exception('The unsupported accessor/mutators supplied',$param); 52 die new IMPL::Exception('The unsupported accessor/mutators supplied',$param);
53 } 53 }
54 54
55 return \%accessors; 55 return \%accessors;
56 } 56 }
57 57
58 sub GenerateSet { 58 sub GenerateSet {
59 die new IMPL::Exception("Standard accessors not supported",'Set'); 59 die new IMPL::Exception("Standard accessors not supported",'Set');
60 } 60 }
61 61
62 sub GenerateGet { 62 sub GenerateGet {
63 die new IMPL::Exception("Standard accessors not supported",'Get'); 63 die new IMPL::Exception("Standard accessors not supported",'Get');
64 } 64 }
65 65
66 sub GenerateGetList { 66 sub GenerateGetList {
67 die new IMPL::Exception("Standard accessors not supported",'GetList'); 67 die new IMPL::Exception("Standard accessors not supported",'GetList');
68 } 68 }
69 69
70 sub GenerateSetList { 70 sub GenerateSetList {
71 my ($self) = @_; 71 my ($self) = @_;
72 die new IMPL::Exception("Standard accessors not supported",'SetList'); 72 die new IMPL::Exception("Standard accessors not supported",'SetList');
73 } 73 }
74 74
75 sub Make { 75 sub Make {
76 my ($self,$propInfo) = @_; 76 my ($self,$propInfo) = @_;
77 77
78 my $key = $self->MakeFactoryKey($propInfo); 78 my $key = $self->MakeFactoryKey($propInfo);
79 79
80 my $factoryInfo = $factoryCache{$key}; 80 my $factoryInfo = $factoryCache{$key};
81 81
82 unless ($factoryInfo) { 82 unless ($factoryInfo) {
83 my $mutators = $self->GenerateAccessors($propInfo->Mutators); 83 my $mutators = $self->GenerateAccessors($propInfo->Mutators);
84 $factoryInfo = { 84 $factoryInfo = {
85 factory => $self->CreateFactory( 85 factory => $self->CreateFactory(
86 $access_code{ $propInfo->Access }, 86 $access_code{ $propInfo->Access },
87 $propInfo->Attributes->{validator} ? $validator_code : "", 87 $propInfo->Attributes->{validator} ? $validator_code : "",
88 $mutators->{owner}, 88 $mutators->{owner},
89 $mutators->{get} || $accessor_get_no, 89 $mutators->{get} || $accessor_get_no,
90 $mutators->{set} || $accessor_set_no 90 $mutators->{set} || $accessor_set_no
91 ), 91 ),
92 mutators => $mutators 92 mutators => $mutators
93 }; 93 };
94 $factoryCache{$key} = $factoryInfo; 94 $factoryCache{$key} = $factoryInfo;
95 } 95 }
96 96
97 { 97 {
98 no strict 'refs'; 98 no strict 'refs';
99 *{ $propInfo->Class.'::'.$propInfo->Name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo)); 99 *{ $propInfo->Class.'::'.$propInfo->Name } = $factoryInfo->{factory}->($self->RemapFactoryParams($propInfo));
100 } 100 }
101 101
102 my $mutators = $factoryInfo->{mutators}; 102 my $mutators = $factoryInfo->{mutators};
103 103
104 $propInfo->canGet( $mutators->{get} ? 1 : 0 ); 104 $propInfo->canGet( $mutators->{get} ? 1 : 0 );
105 $propInfo->canSet( $mutators->{set} ? 1 : 0 ); 105 $propInfo->canSet( $mutators->{set} ? 1 : 0 );
106 $propInfo->ownerSet( $mutators->{owner} ); 106 $propInfo->ownerSet( $mutators->{owner} );
107 107
108 1; 108 1;
109 } 109 }
110 110
111 # extract from property info: class, name, get_accessor, set_accessor, validator 111 # extract from property info: class, name, get_accessor, set_accessor, validator
112 sub RemapFactoryParams { 112 sub RemapFactoryParams {
113 my ($self,$propInfo) = @_; 113 my ($self,$propInfo) = @_;
114 114
115 my $mutators = $propInfo->Mutators; 115 my $mutators = $propInfo->Mutators;
116 my $class = $propInfo->Class; 116 my $class = $propInfo->Class;
117 my $validator = $propInfo->Attributes->{validator}; 117 my $validator = $propInfo->Attributes->{validator};
118 118
119 die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator); 119 die new IMPL::Exception('Can\'t find the specified validator',$class,$validator) if $validator and ref $validator ne 'CODE' and not $class->can($validator);
120 120
121 return ( 121 return (
122 $propInfo->get(qw(Class Name)), 122 $propInfo->get(qw(Class Name)),
123 (ref $mutators? 123 (ref $mutators?
124 ($mutators->{set},$mutators->{get}) 124 ($mutators->{set},$mutators->{get})
125 : 125 :
126 (undef,undef) 126 (undef,undef)
127 ), 127 ),
128 $validator 128 $validator
129 ); 129 );
130 } 130 }
131 131
132 sub MakeFactoryKey { 132 sub MakeFactoryKey {
133 my ($self,$propInfo) = @_; 133 my ($self,$propInfo) = @_;
134 134
135 my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator}); 135 my ($access,$mutators,$validator) = ($propInfo->get(qw(Access Mutators)),$propInfo->Attributes->{validator});
136 136
137 my $implementor = ref $self || $self; 137 my $implementor = ref $self || $self;
138 138
139 return join ('', 139 return join ('',
140 $implementor, 140 $implementor,
141 $access, 141 $access,
142 $validator ? 'v' : 'n', 142 $validator ? 'v' : 'n',
143 ref $mutators ? 143 ref $mutators ?
144 ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0) 144 ('c' , $mutators->{get} ? 1 : 0, $mutators->{set} ? 1 : 0)
145 : 145 :
146 ('s',$mutators) 146 ('s',$mutators)
147 ); 147 );
148 } 148 }
149 149
150 sub CreateFactory { 150 sub CreateFactory {
151 my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_; 151 my ($self,$codeAccessCheck,$codeValidator,$codeOwnerCheck,$codeGet,$codeSet) = @_;
152 152
153 my $strParams = join(',',$self->factoryParams); 153 my $strParams = join(',',$self->factoryParams);
154 154
155 my $factory = <<FACTORY; 155 my $factory = <<FACTORY;
156 156
157 sub { 157 sub {
158 my ($strParams) = \@_; 158 my ($strParams) = \@_;
159 my \$accessor; 159 my \$accessor;
160 \$accessor = sub { 160 \$accessor = sub {
161 my \$this = shift; 161 my \$this = shift;
162 $codeAccessCheck 162 $codeAccessCheck
163 if (\@_) { 163 if (\@_) {
164 $codeOwnerCheck 164 $codeOwnerCheck
165 $codeValidator 165 $codeValidator
166 $codeSet 166 $codeSet
167 } else { 167 } else {
168 $codeGet 168 $codeGet
169 } 169 }
170 } 170 }
171 } 171 }
172 FACTORY 172 FACTORY
173 173
174 return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") ); 174 return ( eval $factory or die new IMPL::Exception("Syntax error due compiling the factory","$@") );
175 } 175 }
176 176
177 1; 177 1;
178 178
179 __END__ 179 __END__