|
407
|
1 package IMPL::lang;
|
|
|
2 use strict;
|
|
|
3 use warnings;
|
|
|
4
|
|
|
5 use parent qw(Exporter);
|
|
|
6 use IMPL::clone qw(clone);
|
|
|
7 use Scalar::Util qw(blessed);
|
|
408
|
8 use POSIX;
|
|
407
|
9 use Carp qw(carp);
|
|
|
10
|
|
409
|
11 our @EXPORT = qw(&is &isclass &typeof &coarsen &coarsen_dt);
|
|
407
|
12 our %EXPORT_TAGS = (
|
|
|
13 base => [
|
|
|
14 qw(
|
|
|
15 &is
|
|
|
16 &clone
|
|
|
17 &isclass
|
|
|
18 &typeof
|
|
412
|
19 &ishash
|
|
|
20 &isarray
|
|
419
|
21 &isscalar
|
|
|
22 &isglob
|
|
407
|
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 )
|
|
|
47 ],
|
|
|
48 compare => [
|
|
|
49 qw(
|
|
|
50 &equals
|
|
|
51 &equals_s
|
|
|
52 &hashCompare
|
|
|
53 )
|
|
|
54 ],
|
|
|
55 hash => [
|
|
|
56 qw(
|
|
|
57 &hashApply
|
|
|
58 &hashMerge
|
|
|
59 &hashDiff
|
|
|
60 &hashCompare
|
|
|
61 &hashParse
|
|
|
62 &hashSave
|
|
|
63 )
|
|
|
64 ]
|
|
|
65 );
|
|
|
66
|
|
|
67 our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } };
|
|
|
68
|
|
|
69 use IMPL::Const qw(:all);
|
|
|
70
|
|
412
|
71 sub is {
|
|
407
|
72 carp "A typename can't be undefined" unless $_[1];
|
|
|
73 blessed($_[0]) and $_[0]->isa( $_[1] );
|
|
|
74 }
|
|
|
75
|
|
|
76 sub isclass {
|
|
|
77 carp "A typename can't be undefined" unless $_[1];
|
|
|
78 local $@;
|
|
|
79 eval {not ref $_[0] and $_[0]->isa( $_[1] ) };
|
|
|
80 }
|
|
|
81
|
|
|
82 sub typeof(*) {
|
|
412
|
83 blessed($_[0]);
|
|
|
84 }
|
|
|
85
|
|
|
86 sub isarray {
|
|
|
87 not blessed($_[0]) and ref $_[0] eq 'ARRAY';
|
|
|
88 }
|
|
|
89
|
|
|
90 sub ishash {
|
|
|
91 not blessed($_[0]) and ref $_[0] eq 'HASH';
|
|
407
|
92 }
|
|
|
93
|
|
419
|
94 sub isscalar {
|
|
|
95 not blessed($_[0]) and ref $_[0] eq 'SCALAR';
|
|
|
96 }
|
|
|
97
|
|
|
98 sub isglob {
|
|
|
99 not blessed($_[0]) and ref $_[0] eq 'GLOB';
|
|
|
100 }
|
|
|
101
|
|
407
|
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 }
|
|
|
155
|
|
408
|
156 sub coarsen {
|
|
|
157 my ( $value, $resolution ) = @_;
|
|
|
158 return $resolution ? ceil( $value / $resolution ) * $resolution : $value;
|
|
|
159 }
|
|
|
160
|
|
409
|
161 # datetime is DateTime object
|
|
|
162 # resolution is DateTime::Duration object, the resulting time will be aligned to it
|
|
|
163 sub coarsen_dt {
|
|
|
164 my ( $datetime, $resolution ) = @_;
|
|
|
165
|
|
|
166 return $datetime unless $resolution;
|
|
|
167
|
|
|
168 my $date = $datetime->clone()->truncate( to => "day" );
|
|
|
169
|
|
|
170 return $date->add(
|
|
|
171 minutes => coarsen(
|
|
|
172 $datetime->subtract_datetime($date)->in_units('minutes'),
|
|
|
173 $resolution->in_units('minutes')
|
|
|
174 )
|
|
|
175 );
|
|
|
176 }
|
|
|
177
|
|
407
|
178 sub equals {
|
|
|
179 if (defined $_[0]) {
|
|
|
180 return 0 if (not defined $_[1]);
|
|
|
181
|
|
|
182 return $_[0] == $_[1];
|
|
|
183 } else {
|
|
|
184 return 0 if defined $_[1];
|
|
|
185
|
|
|
186 return 1;
|
|
|
187 }
|
|
|
188 }
|
|
|
189
|
|
|
190 sub equals_s {
|
|
|
191 if (defined $_[0]) {
|
|
|
192 return 0 if (not defined $_[1]);
|
|
|
193
|
|
|
194 return $_[0] eq $_[1];
|
|
|
195 } else {
|
|
|
196 return 0 if defined $_[1];
|
|
|
197
|
|
|
198 return 1;
|
|
|
199 }
|
|
|
200 }
|
|
|
201
|
|
|
202 sub hashDiff {
|
|
|
203 my ($src,$dst) = @_;
|
|
|
204
|
|
|
205 $dst = $dst ? { %$dst } : {} ;
|
|
|
206 $src ||= {};
|
|
|
207
|
|
|
208 my %result;
|
|
|
209
|
|
|
210 foreach my $key ( keys %$src ) {
|
|
|
211 if (exists $dst->{$key}) {
|
|
|
212 $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key});
|
|
|
213 delete $dst->{$key};
|
|
|
214 } else {
|
|
|
215 $result{"-$key"} = 1;
|
|
|
216 }
|
|
|
217 }
|
|
|
218
|
|
|
219 $result{"+$_"} = $dst->{$_} foreach keys %$dst;
|
|
|
220
|
|
|
221 return \%result;
|
|
|
222 }
|
|
|
223
|
|
|
224 sub hashMerge {
|
|
|
225 return hashApply( { %{$_[0] || {}} }, $_[1] );
|
|
|
226 }
|
|
|
227
|
|
|
228 sub hashApply {
|
|
|
229 my ($target,$diff) = @_;
|
|
|
230
|
|
|
231 return $target unless ref $diff eq 'HASH';
|
|
|
232
|
|
|
233 while ( my ($key,$value) = each %$diff) {
|
|
|
234 $key =~ /^(\+|-)?(.*)$/;
|
|
|
235 my $op = $1 || '+';
|
|
|
236 $key = $2;
|
|
|
237
|
|
|
238 if ($op eq '-') {
|
|
|
239 delete $target->{$key};
|
|
|
240 } else {
|
|
|
241 $target->{$key} = $value;
|
|
|
242 }
|
|
|
243 }
|
|
|
244
|
|
|
245 return $target;
|
|
|
246 }
|
|
|
247
|
|
|
248 sub hashCompare {
|
|
|
249 my ($l,$r,$cmp) = @_;
|
|
|
250
|
|
|
251 $cmp ||= \&equals_s;
|
|
|
252
|
|
|
253 return 0 unless scalar keys %$l == scalar keys %$r;
|
|
|
254 &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l;
|
|
|
255
|
|
|
256 return 1;
|
|
|
257 }
|
|
|
258
|
|
|
259 sub hashParse {
|
|
|
260 my ($s,$p,$d) = @_;
|
|
|
261
|
|
|
262 $p = $p ? qr/$p/ : qr/\n+/;
|
|
|
263 $d = $d ? qr/$d/ : qr/\s*=\s*/;
|
|
|
264
|
|
|
265 return {
|
|
|
266 map split($d,$_,2), split($p,$s)
|
|
|
267 };
|
|
|
268 }
|
|
|
269
|
|
|
270 sub hashSave {
|
|
|
271 my ($hash,$p,$d) = @_;
|
|
|
272
|
|
|
273 return "" unless ref $hash eq 'HASH';
|
|
|
274
|
|
|
275 $p ||= "\n";
|
|
|
276 $d ||= " = ";
|
|
|
277
|
|
|
278 return
|
|
|
279 join(
|
|
|
280 $p,
|
|
|
281 map(
|
|
|
282 join(
|
|
|
283 $d,
|
|
|
284 $_,
|
|
|
285 $hash->{$_}
|
|
|
286 ),
|
|
|
287 keys %$hash
|
|
|
288 )
|
|
|
289 );
|
|
|
290 }
|
|
|
291
|
|
|
292 1;
|
