|
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 compare => [
|
|
|
26 qw(
|
|
|
27 &equals
|
|
|
28 &equals_s
|
|
|
29 &hashCompare
|
|
|
30 )
|
|
|
31 ],
|
|
|
32 hash => [
|
|
|
33 qw(
|
|
|
34 &hashApply
|
|
|
35 &hashMerge
|
|
|
36 &hashDiff
|
|
|
37 &hashCompare
|
|
|
38 &hashParse
|
|
|
39 &hashSave
|
|
|
40 )
|
|
|
41 ]
|
|
|
42 );
|
|
|
43
|
|
421
|
44 our @EXPORT_OK =
|
|
|
45 keys %{ { map ( ( $_, 1 ), map ( @{$_}, values %EXPORT_TAGS ) ) } };
|
|
407
|
46
|
|
|
47 use IMPL::Const qw(:all);
|
|
|
48
|
|
412
|
49 sub is {
|
|
407
|
50 carp "A typename can't be undefined" unless $_[1];
|
|
421
|
51 blessed( $_[0] ) and $_[0]->isa( $_[1] );
|
|
407
|
52 }
|
|
|
53
|
|
|
54 sub isclass {
|
|
|
55 carp "A typename can't be undefined" unless $_[1];
|
|
|
56 local $@;
|
|
421
|
57 eval { not ref $_[0] and $_[0]->isa( $_[1] ) };
|
|
407
|
58 }
|
|
|
59
|
|
|
60 sub typeof(*) {
|
|
421
|
61 blessed( $_[0] );
|
|
412
|
62 }
|
|
|
63
|
|
|
64 sub isarray {
|
|
421
|
65 not blessed( $_[0] ) and ref $_[0] eq 'ARRAY';
|
|
412
|
66 }
|
|
|
67
|
|
|
68 sub ishash {
|
|
421
|
69 not blessed( $_[0] ) and ref $_[0] eq 'HASH';
|
|
407
|
70 }
|
|
|
71
|
|
419
|
72 sub isscalar {
|
|
421
|
73 not blessed( $_[0] ) and ref $_[0] eq 'SCALAR';
|
|
419
|
74 }
|
|
|
75
|
|
|
76 sub isglob {
|
|
421
|
77 not blessed( $_[0] ) and ref $_[0] eq 'GLOB';
|
|
407
|
78 }
|
|
|
79
|
|
408
|
80 sub coarsen {
|
|
421
|
81 my ( $value, $resolution ) = @_;
|
|
|
82 return $resolution ? ceil( $value / $resolution ) * $resolution : $value;
|
|
408
|
83 }
|
|
|
84
|
|
409
|
85 # datetime is DateTime object
|
|
|
86 # resolution is DateTime::Duration object, the resulting time will be aligned to it
|
|
|
87 sub coarsen_dt {
|
|
|
88 my ( $datetime, $resolution ) = @_;
|
|
|
89
|
|
|
90 return $datetime unless $resolution;
|
|
|
91
|
|
|
92 my $date = $datetime->clone()->truncate( to => "day" );
|
|
|
93
|
|
|
94 return $date->add(
|
|
|
95 minutes => coarsen(
|
|
|
96 $datetime->subtract_datetime($date)->in_units('minutes'),
|
|
|
97 $resolution->in_units('minutes')
|
|
|
98 )
|
|
|
99 );
|
|
|
100 }
|
|
|
101
|
|
407
|
102 sub equals {
|
|
421
|
103 if ( defined $_[0] ) {
|
|
|
104 return 0 if ( not defined $_[1] );
|
|
|
105
|
|
407
|
106 return $_[0] == $_[1];
|
|
421
|
107 }
|
|
|
108 else {
|
|
407
|
109 return 0 if defined $_[1];
|
|
421
|
110
|
|
407
|
111 return 1;
|
|
|
112 }
|
|
|
113 }
|
|
|
114
|
|
|
115 sub equals_s {
|
|
421
|
116 if ( defined $_[0] ) {
|
|
|
117 return 0 if ( not defined $_[1] );
|
|
|
118
|
|
407
|
119 return $_[0] eq $_[1];
|
|
421
|
120 }
|
|
|
121 else {
|
|
407
|
122 return 0 if defined $_[1];
|
|
421
|
123
|
|
407
|
124 return 1;
|
|
|
125 }
|
|
|
126 }
|
|
|
127
|
|
|
128 sub hashDiff {
|
|
421
|
129 my ( $src, $dst ) = @_;
|
|
|
130
|
|
|
131 $dst = $dst ? {%$dst} : {};
|
|
407
|
132 $src ||= {};
|
|
421
|
133
|
|
407
|
134 my %result;
|
|
421
|
135
|
|
407
|
136 foreach my $key ( keys %$src ) {
|
|
421
|
137 if ( exists $dst->{$key} ) {
|
|
|
138 $result{"+$key"} = $dst->{$key}
|
|
|
139 unless equals_s( $dst->{$key}, $src->{$key} );
|
|
407
|
140 delete $dst->{$key};
|
|
421
|
141 }
|
|
|
142 else {
|
|
407
|
143 $result{"-$key"} = 1;
|
|
|
144 }
|
|
|
145 }
|
|
421
|
146
|
|
407
|
147 $result{"+$_"} = $dst->{$_} foreach keys %$dst;
|
|
421
|
148
|
|
407
|
149 return \%result;
|
|
|
150 }
|
|
|
151
|
|
|
152 sub hashMerge {
|
|
421
|
153 return hashApply( { %{ $_[0] || {} } }, $_[1] );
|
|
407
|
154 }
|
|
|
155
|
|
|
156 sub hashApply {
|
|
421
|
157 my ( $target, $diff ) = @_;
|
|
|
158
|
|
407
|
159 return $target unless ref $diff eq 'HASH';
|
|
421
|
160
|
|
|
161 while ( my ( $key, $value ) = each %$diff ) {
|
|
407
|
162 $key =~ /^(\+|-)?(.*)$/;
|
|
|
163 my $op = $1 || '+';
|
|
|
164 $key = $2;
|
|
421
|
165
|
|
|
166 if ( $op eq '-' ) {
|
|
407
|
167 delete $target->{$key};
|
|
421
|
168 }
|
|
|
169 else {
|
|
407
|
170 $target->{$key} = $value;
|
|
|
171 }
|
|
|
172 }
|
|
421
|
173
|
|
407
|
174 return $target;
|
|
|
175 }
|
|
|
176
|
|
|
177 sub hashCompare {
|
|
421
|
178 my ( $l, $r, $cmp ) = @_;
|
|
|
179
|
|
407
|
180 $cmp ||= \&equals_s;
|
|
421
|
181
|
|
407
|
182 return 0 unless scalar keys %$l == scalar keys %$r;
|
|
421
|
183 &$cmp( $l->{$_}, $r->{$_} ) || return 0 foreach keys %$l;
|
|
|
184
|
|
407
|
185 return 1;
|
|
|
186 }
|
|
|
187
|
|
|
188 sub hashParse {
|
|
421
|
189 my ( $s, $p, $d ) = @_;
|
|
|
190
|
|
407
|
191 $p = $p ? qr/$p/ : qr/\n+/;
|
|
|
192 $d = $d ? qr/$d/ : qr/\s*=\s*/;
|
|
421
|
193
|
|
|
194 return { map split( $d, $_, 2 ), split( $p, $s ) };
|
|
407
|
195 }
|
|
|
196
|
|
|
197 sub hashSave {
|
|
421
|
198 my ( $hash, $p, $d ) = @_;
|
|
|
199
|
|
407
|
200 return "" unless ref $hash eq 'HASH';
|
|
421
|
201
|
|
407
|
202 $p ||= "\n";
|
|
|
203 $d ||= " = ";
|
|
421
|
204
|
|
|
205 return join( $p, map( join( $d, $_, $hash->{$_} ), keys %$hash ) );
|
|
407
|
206 }
|
|
|
207
|
|
|
208 1;
|
