annotate lib/IMPL/lang.pm @ 417:3ed0c58e9da3 ref20150831

working on di container, tests
author cin
date Mon, 02 Nov 2015 01:56:53 +0300
parents 30e8c6a74937
children bbc4739c4d48
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
1 package IMPL::lang;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
2 use strict;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
3 use warnings;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
4
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
5 use parent qw(Exporter);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
6 use IMPL::_core::version;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
7 use IMPL::clone qw(clone);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
8 use Scalar::Util qw(blessed);
408
5c80e33f1218 added 'coarsen' function
cin
parents: 407
diff changeset
9 use POSIX;
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
10 use Carp qw(carp);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
11
409
cin
parents: 408
diff changeset
12 our @EXPORT = qw(&is &isclass &typeof &coarsen &coarsen_dt);
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
13 our %EXPORT_TAGS = (
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
14 base => [
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
15 qw(
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
16 &is
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
17 &clone
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
18 &isclass
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
19 &typeof
412
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
20 &ishash
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
21 &isarray
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
22 )
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
23 ],
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
24
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
25 declare => [
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
26 qw(
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
27 &public
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
28 &protected
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
29 &private
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
30 &property
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
31 &static
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
32 &property
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
33 &_direct
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
34 &ACCESS_PUBLIC
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
35 &ACCESS_PROTECTED
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
36 &ACCESS_PRIVATE
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
37 &PROP_GET
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
38 &PROP_SET
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
39 &PROP_OWNERSET
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
40 &PROP_LIST
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
41 &PROP_ALL
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
42 &PROP_RO
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
43 &PROP_RW
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
44 &PROP_DIRECT
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
45 )
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
46 ],
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
47 compare => [
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
48 qw(
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
49 &equals
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
50 &equals_s
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
51 &hashCompare
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
52 )
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
53 ],
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
54 hash => [
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
55 qw(
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
56 &hashApply
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
57 &hashMerge
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
58 &hashDiff
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
59 &hashCompare
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
60 &hashParse
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
61 &hashSave
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
62 )
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
63 ]
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
64 );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
65
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
66 our @EXPORT_OK = keys %{ { map (($_,1) , map (@{$_}, values %EXPORT_TAGS) ) } };
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
67
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
68 use IMPL::Const qw(:all);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
69
412
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
70 sub is {
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
71 carp "A typename can't be undefined" unless $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
72 blessed($_[0]) and $_[0]->isa( $_[1] );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
73 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
74
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
75 sub isclass {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
76 carp "A typename can't be undefined" unless $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
77 local $@;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
78 eval {not ref $_[0] and $_[0]->isa( $_[1] ) };
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
79 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
80
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
81 sub typeof(*) {
412
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
82 blessed($_[0]);
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
83 }
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
84
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
85 sub isarray {
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
86 not blessed($_[0]) and ref $_[0] eq 'ARRAY';
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
87 }
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
88
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
89 sub ishash {
30e8c6a74937 working on di container (role based registrations)
cin
parents: 409
diff changeset
90 not blessed($_[0]) and ref $_[0] eq 'HASH';
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
91 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
92
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
93 sub public($) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
94 my $info = shift;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
95 $info->{access} = ACCESS_PUBLIC;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
96 my $implementor = delete $info->{implementor};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
97 $implementor->Implement($info);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
98 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
99
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
100 sub private($) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
101 my $info = shift;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
102 $info->{access} = ACCESS_PRIVATE;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
103 my $implementor = delete $info->{implementor};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
104 $implementor->Implement($info);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
105 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
106
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
107 sub protected($) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
108 my $info = shift;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
109 $info->{access} = ACCESS_PROTECTED;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
110 my $implementor = delete $info->{implementor};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
111 $implementor->Implement($info);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
112 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
113
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
114 sub _direct ($) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
115 my $info = shift;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
116 $info->{direct} = 1;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
117 return $info;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
118 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
119
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
120 sub property($$) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
121 my ($propName,$attributes) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
122
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
123 $attributes = {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
124 get => $attributes & PROP_GET,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
125 set => $attributes & PROP_SET,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
126 isList => $attributes & PROP_LIST
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
127 } unless ref $attributes;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
128
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
129 my $class = caller;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
130
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
131 return hashMerge (
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
132 $attributes,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
133 {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
134 implementor => $class->ClassPropertyImplementor,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
135 name => $propName,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
136 class => scalar(caller),
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
137 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
138 );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
139 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
140
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
141 sub static($$) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
142 my ( $name, $value ) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
143 my $class = caller;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
144 $class->static_accessor( $name, $value );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
145 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
146
408
5c80e33f1218 added 'coarsen' function
cin
parents: 407
diff changeset
147 sub coarsen {
5c80e33f1218 added 'coarsen' function
cin
parents: 407
diff changeset
148 my ( $value, $resolution ) = @_;
5c80e33f1218 added 'coarsen' function
cin
parents: 407
diff changeset
149 return $resolution ? ceil( $value / $resolution ) * $resolution : $value;
5c80e33f1218 added 'coarsen' function
cin
parents: 407
diff changeset
150 }
5c80e33f1218 added 'coarsen' function
cin
parents: 407
diff changeset
151
409
cin
parents: 408
diff changeset
152 # datetime is DateTime object
cin
parents: 408
diff changeset
153 # resolution is DateTime::Duration object, the resulting time will be aligned to it
cin
parents: 408
diff changeset
154 sub coarsen_dt {
cin
parents: 408
diff changeset
155 my ( $datetime, $resolution ) = @_;
cin
parents: 408
diff changeset
156
cin
parents: 408
diff changeset
157 return $datetime unless $resolution;
cin
parents: 408
diff changeset
158
cin
parents: 408
diff changeset
159 my $date = $datetime->clone()->truncate( to => "day" );
cin
parents: 408
diff changeset
160
cin
parents: 408
diff changeset
161 return $date->add(
cin
parents: 408
diff changeset
162 minutes => coarsen(
cin
parents: 408
diff changeset
163 $datetime->subtract_datetime($date)->in_units('minutes'),
cin
parents: 408
diff changeset
164 $resolution->in_units('minutes')
cin
parents: 408
diff changeset
165 )
cin
parents: 408
diff changeset
166 );
cin
parents: 408
diff changeset
167 }
cin
parents: 408
diff changeset
168
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
169 sub equals {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
170 if (defined $_[0]) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
171 return 0 if (not defined $_[1]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
172
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
173 return $_[0] == $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
174 } else {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
175 return 0 if defined $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
176
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
177 return 1;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
178 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
179 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
180
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
181 sub equals_s {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
182 if (defined $_[0]) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
183 return 0 if (not defined $_[1]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
184
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
185 return $_[0] eq $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
186 } else {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
187 return 0 if defined $_[1];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
188
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
189 return 1;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
190 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
191 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
192
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
193 sub hashDiff {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
194 my ($src,$dst) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
195
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
196 $dst = $dst ? { %$dst } : {} ;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
197 $src ||= {};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
198
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
199 my %result;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
200
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
201 foreach my $key ( keys %$src ) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
202 if (exists $dst->{$key}) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
203 $result{"+$key"} = $dst->{$key} unless equals_s($dst->{$key}, $src->{$key});
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
204 delete $dst->{$key};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
205 } else {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
206 $result{"-$key"} = 1;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
207 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
208 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
209
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
210 $result{"+$_"} = $dst->{$_} foreach keys %$dst;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
211
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
212 return \%result;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
213 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
214
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
215 sub hashMerge {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
216 return hashApply( { %{$_[0] || {}} }, $_[1] );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
217 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
218
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
219 sub hashApply {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
220 my ($target,$diff) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
221
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
222 return $target unless ref $diff eq 'HASH';
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
223
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
224 while ( my ($key,$value) = each %$diff) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
225 $key =~ /^(\+|-)?(.*)$/;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
226 my $op = $1 || '+';
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
227 $key = $2;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
228
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
229 if ($op eq '-') {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
230 delete $target->{$key};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
231 } else {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
232 $target->{$key} = $value;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
233 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
234 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
235
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
236 return $target;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
237 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
238
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
239 sub hashCompare {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
240 my ($l,$r,$cmp) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
241
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
242 $cmp ||= \&equals_s;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
243
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
244 return 0 unless scalar keys %$l == scalar keys %$r;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
245 &$cmp($l->{$_},$r->{$_}) || return 0 foreach keys %$l;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
246
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
247 return 1;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
248 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
249
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
250 sub hashParse {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
251 my ($s,$p,$d) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
252
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
253 $p = $p ? qr/$p/ : qr/\n+/;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
254 $d = $d ? qr/$d/ : qr/\s*=\s*/;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
255
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
256 return {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
257 map split($d,$_,2), split($p,$s)
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
258 };
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
259 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
260
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
261 sub hashSave {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
262 my ($hash,$p,$d) = @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
263
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
264 return "" unless ref $hash eq 'HASH';
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
265
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
266 $p ||= "\n";
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
267 $d ||= " = ";
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
268
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
269 return
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
270 join(
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
271 $p,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
272 map(
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
273 join(
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
274 $d,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
275 $_,
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
276 $hash->{$_}
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
277 ),
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
278 keys %$hash
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
279 )
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
280 );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
281 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
282
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
283 1;