2 |
## $Id$ |
## $Id$ |
3 |
## --------------------------------------------------------------------------- |
## --------------------------------------------------------------------------- |
4 |
## $Log$ |
## $Log$ |
5 |
|
## Revision 1.22 2003/05/10 17:09:18 jonen |
6 |
|
## + added keep of empty arrays/hashes if 'expand' for php |
7 |
|
## |
8 |
|
## Revision 1.21 2003/04/09 07:21:56 joko |
9 |
|
## childObj2string now inside Encode.pm, renamed to 'twingle_reference' |
10 |
|
## |
11 |
|
## Revision 1.20 2003/04/04 17:31:23 joko |
12 |
|
## minor update to 'childObj2string' |
13 |
|
## |
14 |
|
## Revision 1.19 2003/03/28 03:11:25 jonen |
15 |
|
## + bugfix |
16 |
|
## |
17 |
|
## Revision 1.18 2003/03/28 03:07:26 jonen |
18 |
|
## + minor changes |
19 |
|
## |
20 |
|
## Revision 1.17 2003/03/27 15:17:07 joko |
21 |
|
## namespace fixes for Data::Mungle::* |
22 |
|
## |
23 |
|
## Revision 1.16 2003/03/27 15:04:52 joko |
24 |
|
## minor update: comment |
25 |
|
## |
26 |
|
## Revision 1.15 2003/02/27 14:39:48 jonen |
27 |
|
## + fixed bug at _hash2object() |
28 |
|
## |
29 |
|
## Revision 1.14 2003/02/22 17:13:55 jonen |
30 |
|
## + added function 'childObject2string()' to encode 'child'-references to option related string |
31 |
|
## + use new option at 'expand()' for replacing 'childObject2string' |
32 |
|
## |
33 |
|
## Revision 1.13 2003/02/21 01:48:50 joko |
34 |
|
## renamed core function |
35 |
|
## |
36 |
## Revision 1.12 2003/02/20 22:45:19 joko |
## Revision 1.12 2003/02/20 22:45:19 joko |
37 |
## fix regarding new deep_copy |
## fix regarding new deep_copy |
38 |
## |
## |
77 |
## --------------------------------------------------------------------------- |
## --------------------------------------------------------------------------- |
78 |
|
|
79 |
|
|
80 |
package Data::Transform::Deep; |
package Data::Mungle::Transform::Deep; |
81 |
|
|
82 |
use strict; |
use strict; |
83 |
use warnings; |
use warnings; |
96 |
use Iterate; |
use Iterate; |
97 |
|
|
98 |
use Pitonyak::DeepCopy; |
use Pitonyak::DeepCopy; |
99 |
use Data::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar ); |
use Data::Mungle::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar twingle_reference ); |
100 |
use Data::Code::Ref qw( ref_slot ); |
use Data::Mungle::Code::Ref qw( ref_slot ); |
101 |
|
|
102 |
sub numhash2list { |
sub numhash2list { |
103 |
my $vref = shift; |
my $vref = shift; |
167 |
} |
} |
168 |
|
|
169 |
|
|
170 |
|
# convert values in hash to utf8 (and back) to be ready for (e.g.) encapsulation in XML |
171 |
|
# but still using the known latin locale stuff |
172 |
sub expand { |
sub expand { |
173 |
|
|
174 |
my $obj = shift; |
my $obj = shift; |
178 |
#print "ref: ", ref $obj, "\n"; |
#print "ref: ", ref $obj, "\n"; |
179 |
|
|
180 |
if (ref $obj eq 'ARRAY') { |
if (ref $obj eq 'ARRAY') { |
181 |
|
|
182 |
|
# if we expand for php, keep empty ARRAY |
183 |
|
if($#$obj == -1 && $options->{childObj2string}) { |
184 |
|
$result = $obj; |
185 |
|
} else { |
186 |
IterArray @$obj, sub { |
IterArray @$obj, sub { |
187 |
my $item; |
my $item; |
188 |
# if current item is a reference ... |
# if current item is a reference ... |
189 |
if (ref $_[0]) { |
if (ref $_[0]) { |
190 |
# ... expand structure recursively |
$item = $_[0]; |
191 |
$item = expand($_[0], $options); |
# if $options->{childObj2string} is TRUE or STRING don't expand referenced object, |
192 |
|
# instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) |
193 |
|
if ($item && $options->{childObj2string}) { |
194 |
|
$item = twingle_reference($item); |
195 |
|
} else { |
196 |
|
# ... expand structure recursively |
197 |
|
$item = expand($_[0], $options); |
198 |
|
} |
199 |
# destroy item via seperate callback method (a POST) if requested |
# destroy item via seperate callback method (a POST) if requested |
200 |
#$options->{cb}->{destroy}->($_[0]) if $options->{destroy}; |
#$options->{cb}->{destroy}->($_[0]) if $options->{destroy}; |
201 |
|
|
211 |
push(@{$result}, $item); # use item in any case |
push(@{$result}, $item); # use item in any case |
212 |
|
|
213 |
} |
} |
214 |
|
} |
215 |
|
|
216 |
} elsif (ref $obj eq 'CODE') { |
} elsif (ref $obj eq 'CODE') { |
217 |
#print Dumper($obj); |
#print Dumper($obj); |
219 |
|
|
220 |
# TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ??? |
# TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ??? |
221 |
} elsif (ref $obj) { |
} elsif (ref $obj) { |
222 |
|
|
223 |
|
# if we expand for php, keep empty HASH |
224 |
|
my @tmp = keys %$obj; |
225 |
|
if($#tmp == -1 && $options->{childObj2string}) { |
226 |
|
$result = $obj; |
227 |
|
} else { |
228 |
IterHash %$obj, sub { |
IterHash %$obj, sub { |
229 |
my $item; |
my $item; |
230 |
|
|
231 |
# if current item is a reference ... |
# if current item is a reference ... |
232 |
if (ref $_[1]) { |
if (ref $_[1]) { |
233 |
# ... expand structure recursively |
$item = $_[1]; |
234 |
$item = expand($_[1], $options); |
# if $options->{childObj2string} is TRUE or STRING don't expand referenced object, |
235 |
|
# instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) |
236 |
|
if ($item && $options->{childObj2string} && !(ref $_[1] eq "ARRAY") && !(ref $_[1] eq "HASH") && !(ref $_[1] eq "Set::Object")) { |
237 |
|
$item = twingle_reference($item); |
238 |
|
} else { |
239 |
|
# ... expand structure recursively |
240 |
|
$item = expand($_[1], $options); |
241 |
|
} |
242 |
# destroy item via seperate callback method (a POST) if requested |
# destroy item via seperate callback method (a POST) if requested |
243 |
#$options->{cb}->{destroy}->($_[1]) if $options->{destroy}; |
#$options->{cb}->{destroy}->($_[1]) if $options->{destroy}; |
244 |
|
|
253 |
#$result->{$_[0]} = $item if $item; # use item only if not undef (TODO: make configurable via $options) |
#$result->{$_[0]} = $item if $item; # use item only if not undef (TODO: make configurable via $options) |
254 |
$result->{$_[0]} = $item; # use item in any case |
$result->{$_[0]} = $item; # use item in any case |
255 |
} |
} |
256 |
|
} |
257 |
|
|
258 |
} else { |
} else { |
259 |
#die ("not a reference!"); |
#die ("not a reference!"); |
263 |
|
|
264 |
# convert all values to utf8 (inside complex struct) |
# convert all values to utf8 (inside complex struct) |
265 |
# now done in core-item-callbacks via Greg London's "Iterate" from CPAN |
# now done in core-item-callbacks via Greg London's "Iterate" from CPAN |
266 |
# var2utf8($result) if ($options->{utf8}); |
# latin_to_utf8($result) if ($options->{utf8}); |
267 |
|
|
268 |
# destroy persistent object from memory to be sure to get a fresh one next time |
# destroy persistent object from memory to be sure to get a fresh one next time |
269 |
#undef $obj if $options->{destroy}; |
#undef $obj if $options->{destroy}; |
323 |
sub merge_to { |
sub merge_to { |
324 |
_hash2object(@_); |
_hash2object(@_); |
325 |
# TODO: |
# TODO: |
326 |
# re-implement using CPAN's "Iterate". |
# re-implement using CPAN's "Iterate" and/or a modified Hash::Merge. |
327 |
} |
} |
328 |
|
|
329 |
|
|
340 |
numhash2list($data) if ($options->{php}); |
numhash2list($data) if ($options->{php}); |
341 |
|
|
342 |
# utf8-conversion/-encoding (essential for I18N) |
# utf8-conversion/-encoding (essential for I18N) |
343 |
var_utf2iso($data) if ($options->{utf8}); |
utf8_to_latin($data) if ($options->{utf8}); |
344 |
|
|
345 |
# get fresh object from database |
# get fresh object from database |
346 |
# todo: |
# todo: |