Mercurial > pub > Impl

comparison lib/IMPL/lang.pm @ 421:7798345304bc ref20150831

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
working on IMPL::Config, removed old stuff
author cin
date Sun, 16 Jul 2017 22:59:39 +0300
parents bbc4739c4d48
children
comparison
equal deleted inserted replaced
420:df591e3afd10 421:7798345304bc
18 &typeof 18 &typeof
19 &ishash 19 &ishash
20 &isarray 20 &isarray
21 &isscalar 21 &isscalar
22 &isglob 22 &isglob
23 )
24 ],
25
26 declare => [
27 qw(
28 &public
29 &protected
30 &private
31 &property
32 &static
33 &property
34 &_direct
35 &ACCESS_PUBLIC
36 &ACCESS_PROTECTED
37 &ACCESS_PRIVATE
38 &PROP_GET
39 &PROP_SET
40 &PROP_OWNERSET
41 &PROP_LIST
42 &PROP_ALL
43 &PROP_RO
44 &PROP_RW
45 &PROP_DIRECT
46 ) 23 )
47 ], 24 ],
48 compare => [ 25 compare => [
49 qw( 26 qw(
50 &equals 27 &equals
62 &hashSave 39 &hashSave
63 ) 40 )
64 ] 41 ]
65 ); 42 );
66 43
67 our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } }; 44 our @EXPORT_OK =
45 keys %{ { map ( ( $_, 1 ), map ( @{$_}, values %EXPORT_TAGS ) ) } };
68 46
69 use IMPL::Const qw(:all); 47 use IMPL::Const qw(:all);
70 48
71 sub is { 49 sub is {
72 carp "A typename can't be undefined" unless $_[1]; 50 carp "A typename can't be undefined" unless $_[1];
73 blessed($_[0]) and $_[0]->isa( $_[1] ); 51 blessed( $_[0] ) and $_[0]->isa( $_[1] );
74 } 52 }
75 53
76 sub isclass { 54 sub isclass {
77 carp "A typename can't be undefined" unless $_[1]; 55 carp "A typename can't be undefined" unless $_[1];
78 local $@; 56 local $@;
79 eval {not ref $_[0] and $_[0]->isa( $_[1] ) }; 57 eval { not ref $_[0] and $_[0]->isa( $_[1] ) };
80 } 58 }
81 59
82 sub typeof(*) { 60 sub typeof(*) {
83 blessed($_[0]); 61 blessed( $_[0] );
84 } 62 }
85 63
86 sub isarray { 64 sub isarray {
87 not blessed($_[0]) and ref $_[0] eq 'ARRAY'; 65 not blessed( $_[0] ) and ref $_[0] eq 'ARRAY';
88 } 66 }
89 67
90 sub ishash { 68 sub ishash {
91 not blessed($_[0]) and ref $_[0] eq 'HASH'; 69 not blessed( $_[0] ) and ref $_[0] eq 'HASH';
92 } 70 }
93 71
94 sub isscalar { 72 sub isscalar {
95 not blessed($_[0]) and ref $_[0] eq 'SCALAR'; 73 not blessed( $_[0] ) and ref $_[0] eq 'SCALAR';
96 } 74 }
97 75
98 sub isglob { 76 sub isglob {
99 not blessed($_[0]) and ref $_[0] eq 'GLOB'; 77 not blessed( $_[0] ) and ref $_[0] eq 'GLOB';
100 }
101
102 sub public($) {
103 my $info = shift;
104 $info->{access} = ACCESS_PUBLIC;
105 my $implementor = delete $info->{implementor};
106 $implementor->Implement($info);
107 }
108
109 sub private($) {
110 my $info = shift;
111 $info->{access} = ACCESS_PRIVATE;
112 my $implementor = delete $info->{implementor};
113 $implementor->Implement($info);
114 }
115
116 sub protected($) {
117 my $info = shift;
118 $info->{access} = ACCESS_PROTECTED;
119 my $implementor = delete $info->{implementor};
120 $implementor->Implement($info);
121 }
122
123 sub _direct ($) {
124 my $info = shift;
125 $info->{direct} = 1;
126 return $info;
127 }
128
129 sub property($$) {
130 my ($propName,$attributes) = @_;
131
132 $attributes = {
133 get => $attributes & PROP_GET,
134 set => $attributes & PROP_SET,
135 isList => $attributes & PROP_LIST
136 } unless ref $attributes;
137
138 my $class = caller;
139
140 return hashMerge (
141 $attributes,
142 {
143 implementor => $class->ClassPropertyImplementor,
144 name => $propName,
145 class => scalar(caller),
146 }
147 );
148 }
149
150 sub static($$) {
151 my ( $name, $value ) = @_;
152 my $class = caller;
153 $class->static_accessor( $name, $value );
154 } 78 }
155 79
156 sub coarsen { 80 sub coarsen {
157 my ( $value, $resolution ) = @_; 81 my ( $value, $resolution ) = @_;
158 return $resolution ? ceil( $value / $resolution ) * $resolution : $value; 82 return $resolution ? ceil( $value / $resolution ) * $resolution : $value;
159 } 83 }
160 84
161 # datetime is DateTime object 85 # datetime is DateTime object
162 # resolution is DateTime::Duration object, the resulting time will be aligned to it 86 # resolution is DateTime::Duration object, the resulting time will be aligned to it
163 sub coarsen_dt { 87 sub coarsen_dt {
174 ) 98 )
175 ); 99 );
176 } 100 }
177 101
178 sub equals { 102 sub equals {
179 if (defined $_[0]) { 103 if ( defined $_[0] ) {
180 return 0 if (not defined $_[1]); 104 return 0 if ( not defined $_[1] );
181 105
182 return $_[0] == $_[1]; 106 return $_[0] == $_[1];
183 } else { 107 }
108 else {
184 return 0 if defined $_[1]; 109 return 0 if defined $_[1];
185 110
186 return 1; 111 return 1;
187 } 112 }
188 } 113 }
189 114
190 sub equals_s { 115 sub equals_s {
191 if (defined $_[0]) { 116 if ( defined $_[0] ) {
192 return 0 if (not defined $_[1]); 117 return 0 if ( not defined $_[1] );
193 118
194 return $_[0] eq $_[1]; 119 return $_[0] eq $_[1];
195 } else { 120 }
121 else {
196 return 0 if defined $_[1]; 122 return 0 if defined $_[1];
197 123
198 return 1; 124 return 1;
199 } 125 }
200 } 126 }
201 127
202 sub hashDiff { 128 sub hashDiff {
203 my ($src,$dst) = @_; 129 my ( $src, $dst ) = @_;
204 130
205 $dst = $dst ? { %$dst } : {} ; 131 $dst = $dst ? {%$dst} : {};
206 $src ||= {}; 132 $src ||= {};
207 133
208 my %result; 134 my %result;
209 135
210 foreach my $key ( keys %$src ) { 136 foreach my $key ( keys %$src ) {
211 if (exists $dst->{$key}) { 137 if ( exists $dst->{$key} ) {
212 $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key}); 138 $result{"+$key"} = $dst->{$key}
139 unless equals_s( $dst->{$key}, $src->{$key} );
213 delete $dst->{$key}; 140 delete $dst->{$key};
214 } else { 141 }
142 else {
215 $result{"-$key"} = 1; 143 $result{"-$key"} = 1;
216 } 144 }
217 } 145 }
218 146
219 $result{"+$_"} = $dst->{$_} foreach keys %$dst; 147 $result{"+$_"} = $dst->{$_} foreach keys %$dst;
220 148
221 return \%result; 149 return \%result;
222 } 150 }
223 151
224 sub hashMerge { 152 sub hashMerge {
225 return hashApply( { %{$_[0] || {}} }, $_[1] ); 153 return hashApply( { %{ $_[0] || {} } }, $_[1] );
226 } 154 }
227 155
228 sub hashApply { 156 sub hashApply {
229 my ($target,$diff) = @_; 157 my ( $target, $diff ) = @_;
230 158
231 return $target unless ref $diff eq 'HASH'; 159 return $target unless ref $diff eq 'HASH';
232 160
233 while ( my ($key,$value) = each %$diff) { 161 while ( my ( $key, $value ) = each %$diff ) {
234 $key =~ /^(\+|-)?(.*)$/; 162 $key =~ /^(\+|-)?(.*)$/;
235 my $op = $1 || '+'; 163 my $op = $1 || '+';
236 $key = $2; 164 $key = $2;
237 165
238 if ($op eq '-') { 166 if ( $op eq '-' ) {
239 delete $target->{$key}; 167 delete $target->{$key};
240 } else { 168 }
169 else {
241 $target->{$key} = $value; 170 $target->{$key} = $value;
242 } 171 }
243 } 172 }
244 173
245 return $target; 174 return $target;
246 } 175 }
247 176
248 sub hashCompare { 177 sub hashCompare {
249 my ($l,$r,$cmp) = @_; 178 my ( $l, $r, $cmp ) = @_;
250 179
251 $cmp ||= \&equals_s; 180 $cmp ||= \&equals_s;
252 181
253 return 0 unless scalar keys %$l == scalar keys %$r; 182 return 0 unless scalar keys %$l == scalar keys %$r;
254 &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l; 183 &$cmp( $l->{$_}, $r->{$_} ) || return 0 foreach keys %$l;
255 184
256 return 1; 185 return 1;
257 } 186 }
258 187
259 sub hashParse { 188 sub hashParse {
260 my ($s,$p,$d) = @_; 189 my ( $s, $p, $d ) = @_;
261 190
262 $p = $p ? qr/$p/ : qr/\n+/; 191 $p = $p ? qr/$p/ : qr/\n+/;
263 $d = $d ? qr/$d/ : qr/\s*=\s*/; 192 $d = $d ? qr/$d/ : qr/\s*=\s*/;
264 193
265 return { 194 return { map split( $d, $_, 2 ), split( $p, $s ) };
266 map split($d,$_,2), split($p,$s)
267 };
268 } 195 }
269 196
270 sub hashSave { 197 sub hashSave {
271 my ($hash,$p,$d) = @_; 198 my ( $hash, $p, $d ) = @_;
272 199
273 return "" unless ref $hash eq 'HASH'; 200 return "" unless ref $hash eq 'HASH';
274 201
275 $p ||= "\n"; 202 $p ||= "\n";
276 $d ||= " = "; 203 $d ||= " = ";
277 204
278 return 205 return join( $p, map( join( $d, $_, $hash->{$_} ), keys %$hash ) );
279 join(
280 $p,
281 map(
282 join(
283 $d,
284 $_,
285 $hash->{$_}
286 ),
287 keys %$hash
288 )
289 );
290 } 206 }
291 207
292 1; 208 1;