Mercurial > pub > Impl

comparison Lib/IMPL/lang.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 47dac58691ee
children 6adaeb86945d
comparison
equal deleted inserted replaced
193:8e8401c0aea4 194:4d0e1962161c
8 8
9 require IMPL::Class::PropertyInfo; 9 require IMPL::Class::PropertyInfo;
10 10
11 our @EXPORT = qw(&is); 11 our @EXPORT = qw(&is);
12 our %EXPORT_TAGS = ( 12 our %EXPORT_TAGS = (
13 base => [ 13 base => [
14 qw( 14 qw(
15 &is 15 &is
16 &clone 16 &clone
17 ) 17 )
18 ], 18 ],
19 constants => [ 19 constants => [
20 qw( 20 qw(
21 &ACCESS_PUBLIC 21 &ACCESS_PUBLIC
22 &ACCESS_PROTECTED 22 &ACCESS_PROTECTED
23 &ACCESS_PRIVATE 23 &ACCESS_PRIVATE
24 &PROP_GET 24 &PROP_GET
25 &PROP_SET 25 &PROP_SET
26 &PROP_OWNERSET 26 &PROP_OWNERSET
27 &PROP_LIST 27 &PROP_LIST
28 &PROP_ALL 28 &PROP_ALL
29 ) 29 )
30 ], 30 ],
31 31
32 declare => [ 32 declare => [
33 qw( 33 qw(
34 &public 34 &public
35 &protected 35 &protected
36 &private 36 &private
37 &virtual 37 &virtual
38 &property 38 &property
39 &static 39 &static
40 &property 40 &property
41 ) 41 )
42 ], 42 ],
43 compare => [ 43 compare => [
44 qw( 44 qw(
45 &equals 45 &equals
46 &equals_s 46 &equals_s
47 &hashCompare 47 &hashCompare
48 ) 48 )
49 ], 49 ],
50 hash => [ 50 hash => [
51 qw( 51 qw(
52 &hashApply 52 &hashApply
53 &hashMerge 53 &hashMerge
54 &hashDiff 54 &hashDiff
55 &hashCompare 55 &hashCompare
56 &hashParse 56 &hashParse
57 &hashSave 57 &hashSave
58 ) 58 )
59 ] 59 ]
60 ); 60 );
61 61
62 our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; 62 our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } };
63 63
64 use constant { 64 use constant {
65 ACCESS_PUBLIC => 1, 65 ACCESS_PUBLIC => 1,
66 ACCESS_PROTECTED => 2, 66 ACCESS_PROTECTED => 2,
67 ACCESS_PRIVATE => 3, 67 ACCESS_PRIVATE => 3,
68 PROP_GET => 1, 68 PROP_GET => 1,
69 PROP_SET => 2, 69 PROP_SET => 2,
70 PROP_OWNERSET => 10, 70 PROP_OWNERSET => 10,
71 PROP_LIST => 4, 71 PROP_LIST => 4,
72 PROP_ALL => 3 72 PROP_ALL => 3
73 }; 73 };
74 74
75 sub is($$) { 75 sub is($$) {
76 eval { $_[0]->isa( $_[1] ) }; 76 eval { $_[0]->isa( $_[1] ) };
77 } 77 }
78 78
79 sub virtual($) { 79 sub virtual($) {
80 $_[0]->Virtual(1); 80 $_[0]->Virtual(1);
81 $_[0]; 81 $_[0];
82 } 82 }
83 83
84 sub public($) { 84 sub public($) {
85 $_[0]->Access(ACCESS_PUBLIC); 85 $_[0]->Access(ACCESS_PUBLIC);
86 $_[0]->Implement; 86 $_[0]->Implement;
87 $_[0]; 87 $_[0];
88 } 88 }
89 89
90 sub private($) { 90 sub private($) {
91 $_[0]->Access(ACCESS_PRIVATE); 91 $_[0]->Access(ACCESS_PRIVATE);
92 $_[0]->Implement; 92 $_[0]->Implement;
93 $_[0]; 93 $_[0];
94 } 94 }
95 95
96 sub protected($) { 96 sub protected($) {
97 $_[0]->Access(ACCESS_PROTECTED); 97 $_[0]->Access(ACCESS_PROTECTED);
98 $_[0]->Implement; 98 $_[0]->Implement;
99 $_[0]; 99 $_[0];
100 } 100 }
101 101
102 sub property($$;$) { 102 sub property($$;$) {
103 my ( $propName, $mutators, $attributes ) = @_; 103 my ( $propName, $mutators, $attributes ) = @_;
104 my $Info = new IMPL::Class::PropertyInfo( 104 my $Info = new IMPL::Class::PropertyInfo(
105 { 105 {
106 Name => $propName, 106 Name => $propName,
107 Mutators => $mutators, 107 Mutators => $mutators,
108 Class => scalar(caller), 108 Class => scalar(caller),
109 Attributes => $attributes 109 Attributes => $attributes
110 } 110 }
111 ); 111 );
112 return $Info; 112 return $Info;
113 } 113 }
114 114
115 sub static($$) { 115 sub static($$) {
116 my ( $name, $value ) = @_; 116 my ( $name, $value ) = @_;
117 my $class = caller; 117 my $class = caller;
118 $class->static_accessor( $name, $value ); 118 $class->static_accessor( $name, $value );
119 } 119 }
120 120
121 sub equals { 121 sub equals {
122 if (defined $_[0]) { 122 if (defined $_[0]) {
123 return 0 if (not defined $_[1]); 123 return 0 if (not defined $_[1]);
124 124
125 return $_[0] == $_[1]; 125 return $_[0] == $_[1];
126 } else { 126 } else {
127 return 0 if defined $_[1]; 127 return 0 if defined $_[1];
128 128
129 return 1; 129 return 1;
130 } 130 }
131 } 131 }
132 132
133 sub equals_s { 133 sub equals_s {
134 if (defined $_[0]) { 134 if (defined $_[0]) {
135 return 0 if (not defined $_[1]); 135 return 0 if (not defined $_[1]);
136 136
137 return $_[0] eq $_[1]; 137 return $_[0] eq $_[1];
138 } else { 138 } else {
139 return 0 if defined $_[1]; 139 return 0 if defined $_[1];
140 140
141 return 1; 141 return 1;
142 } 142 }
143 } 143 }
144 144
145 sub hashDiff { 145 sub hashDiff {
146 my ($src,$dst) = @_; 146 my ($src,$dst) = @_;
147 147
148 $dst = $dst ? { %$dst } : {} ; 148 $dst = $dst ? { %$dst } : {} ;
149 $src ||= {}; 149 $src ||= {};
150 150
151 my %result; 151 my %result;
152 152
153 foreach my $key ( keys %$src ) { 153 foreach my $key ( keys %$src ) {
154 if (exists $dst->{$key}) { 154 if (exists $dst->{$key}) {
155 $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); 155 $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key});
156 delete $dst->{$key}; 156 delete $dst->{$key};
157 } else { 157 } else {
158 $result{"-$key"} = 1; 158 $result{"-$key"} = 1;
159 } 159 }
160 } 160 }
161 161
162 $result{"+$_"} = $dst->{$_} foreach keys %$dst; 162 $result{"+$_"} = $dst->{$_} foreach keys %$dst;
163 163
164 return \%result; 164 return \%result;
165 } 165 }
166 166
167 sub hashMerge { 167 sub hashMerge {
168 return hashApply( { %{$_[0]} }, $_[1] ); 168 return hashApply( { %{$_[0]} }, $_[1] );
169 } 169 }
170 170
171 sub hashApply { 171 sub hashApply {
172 my ($target,$diff) = @_; 172 my ($target,$diff) = @_;
173 173
174 while ( my ($key,$value) = each %$diff) { 174 while ( my ($key,$value) = each %$diff) {
175 $key =~ /^(\+|-)?(.*)$/; 175 $key =~ /^(\+|-)?(.*)$/;
176 my $op = $1 || '+'; 176 my $op = $1 || '+';
177 $key = $2; 177 $key = $2;
178 178
179 if ($op eq '-') { 179 if ($op eq '-') {
180 delete $target->{$key}; 180 delete $target->{$key};
181 } else { 181 } else {
182 $target->{$key} = $value; 182 $target->{$key} = $value;
183 } 183 }
184 } 184 }
185 185
186 return $target; 186 return $target;
187 } 187 }
188 188
189 sub hashCompare { 189 sub hashCompare {
190 my ($l,$r,$cmp) = @_; 190 my ($l,$r,$cmp) = @_;
191 191
192 $cmp ||= \&equals_s; 192 $cmp ||= \&equals_s;
193 193
194 return 0 unless scalar keys %$l == scalar keys %$r; 194 return 0 unless scalar keys %$l == scalar keys %$r;
195 &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; 195 &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l;
196 196
197 return 1; 197 return 1;
198 } 198 }
199 199
200 sub hashParse { 200 sub hashParse {
201 my ($s,$p,$d) = @_; 201 my ($s,$p,$d) = @_;
202 202
203 $p = $p ? qr/$p/ : qr/\n+/; 203 $p = $p ? qr/$p/ : qr/\n+/;
204 $d = $d ? qr/$d/ : qr/\s*=\s*/; 204 $d = $d ? qr/$d/ : qr/\s*=\s*/;
205 205
206 return { 206 return {
207 map split($d,$_,2), split($p,$s) 207 map split($d,$_,2), split($p,$s)
208 }; 208 };
209 } 209 }
210 210
211 sub hashSave { 211 sub hashSave {
212 my ($hash,$p,$d) = @_; 212 my ($hash,$p,$d) = @_;
213 213
214 return "" unless ref $hash eq 'HASH'; 214 return "" unless ref $hash eq 'HASH';
215 215
216 $p ||= "\n"; 216 $p ||= "\n";
217 $d ||= " = "; 217 $d ||= " = ";
218 218
219 return 219 return
220 join( 220 join(
221 $p, 221 $p,
222 map( 222 map(
223 join( 223 join(
224 $d, 224 $d,
225 $_, 225 $_,
226 $hash->{$_} 226 $hash->{$_}
227 ), 227 ),
228 keys %$hash 228 keys %$hash
229 ) 229 )
230 ); 230 );
231 } 231 }
232 232
233 1; 233 1;