/[cvs]/nfo/perl/libs/Data/Mungle/Transform/Deep.pm
ViewVC logotype

Contents of /nfo/perl/libs/Data/Mungle/Transform/Deep.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.23 - (show annotations)
Tue May 13 07:39:22 2003 UTC (21 years, 1 month ago) by joko
Branch: MAIN
Changes since 1.22: +9 -1 lines
new option 'define' for "sub expand": set value to empty string if desired

1 ## ---------------------------------------------------------------------------
2 ## $Id: Deep.pm,v 1.22 2003/05/10 17:09:18 jonen Exp $
3 ## ---------------------------------------------------------------------------
4 ## $Log: Deep.pm,v $
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
37 ## fix regarding new deep_copy
38 ##
39 ## Revision 1.11 2003/02/20 21:13:54 joko
40 ## - removed implementation of deep_copy2 - get this from the Pitonyak namespace (now cloned to repository)
41 ##
42 ## Revision 1.10 2003/02/20 20:48:00 joko
43 ## - refactored lots of code to Data::Code::Ref
44 ## + alternative 'deep_copy' implementation
45 ##
46 ## Revision 1.9 2003/02/18 19:35:56 joko
47 ## +- modified 'sub refexpr2perlref': now can get the $delimiter passed, too
48 ##
49 ## Revision 1.8 2003/02/09 05:10:56 joko
50 ## + minor update
51 ##
52 ## Revision 1.7 2003/01/19 03:26:59 joko
53 ## + added 'sub deep_copy' - refactored from libp
54 ## + add 'sub merge' - exported from CPAN's 'Hash::Merge'
55 ##
56 ## Revision 1.6 2002/12/23 11:27:53 jonen
57 ## + changed behavior WATCH!
58 ##
59 ## Revision 1.5 2002/12/16 19:57:54 joko
60 ## + option 'init'
61 ##
62 ## Revision 1.4 2002/12/05 13:56:49 joko
63 ## - var_deref
64 ## + expand - more sophisticated dereferencing with callbacks using Iterate
65 ##
66 ## Revision 1.3 2002/12/03 05:34:55 joko
67 ## + bugfix: now utilizing var_utf2iso from Data::Transform::Encode
68 ##
69 ## Revision 1.2 2002/12/01 04:44:07 joko
70 ## + code from Data::Transform::OO
71 ##
72 ## Revision 1.1 2002/11/29 04:49:20 joko
73 ## + initial check-in
74 ##
75 ## Revision 1.1 2002/10/10 03:26:00 cvsjoko
76 ## + new
77 ## ---------------------------------------------------------------------------
78
79
80 package Data::Mungle::Transform::Deep;
81
82 use strict;
83 use warnings;
84
85 require Exporter;
86 our @ISA = qw( Exporter );
87 our @EXPORT_OK = qw(
88 &expand
89 &deep_copy
90 &merge_to
91 );
92
93
94 use attributes;
95 use Data::Dumper;
96 use Iterate;
97
98 use Pitonyak::DeepCopy;
99 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::Mungle::Code::Ref qw( ref_slot );
101
102 sub numhash2list {
103 my $vref = shift;
104 #my $context = shift;
105 if (ref $vref eq 'HASH') {
106 foreach (keys %{$vref}) {
107 # if ((ref $vref->{$_}) =~ m/HASH/) {
108 if ((ref $vref->{$_}) =~ m/HASH/) {
109 if ($vref->{$_}{0}) { # might be a numerical-indexed array
110 #print "000\n";
111 #print "context: $context\n";
112 my @arr;
113 foreach my $key_numeric (sort keys %{$vref->{$_}}) {
114 push @arr, $vref->{$_}{$key_numeric};
115 }
116 $vref->{$_} = \@arr;
117 }
118 numhash2list($vref->{$_});
119 }
120 # } else {
121 # #$vref->{$_} = scalar2iso($vref->{$_});
122 # }
123 }
124 }
125 }
126
127
128 # FIXME: could this be refactored using expand?
129 # btw: "expand": look at scripts@CPAN (System Administration):
130 # there is a perl make with perl
131 sub _var_deref_test {
132 my $obj = shift;
133 my $options = shift;
134 my $result;
135 if ((ref $obj) eq 'ARRAY') {
136 foreach (@{$obj}) {
137 my $ref = ref $_;
138 if ($ref) {
139 push(@{$result}, var_deref($_, $options));
140 #undef $_;
141 } else {
142 #push(@{$result}, $_);
143 push(@{$result}, deep_copy($_));
144 }
145 #undef $_ if $options->{destroy};
146 #$options->{destroy}->($_) if $options->{destroy};
147 }
148 # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ???
149 } else {
150 foreach (keys %{$obj}) {
151 my $key = $_;
152 my $ref = ref $obj->{$_};
153 if ($ref) {
154 $result->{$_} = var_deref($obj->{$_}, $options);
155 #undef $obj->{$_};
156 } else {
157 #$result->{$_} = $obj->{$_};
158 $result->{$_} = deep_copy($obj->{$_});
159 }
160 #undef $obj->{$_} if $options->{destroy};
161 #$options->{destroy}->($obj->{$_}) if $options->{destroy};
162 }
163 }
164 #undef $obj if $options->{destroy};
165 $options->{cb_destroy}->($obj) if $options->{cb_destroy};
166 return $result;
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 # TODO: Review: Could this be revamped using Clone.pm?
173 sub expand {
174
175 my $obj = shift;
176 my $options = shift;
177 my $result;
178
179 #print "ref: ", ref $obj, "\n";
180
181 if (ref $obj eq 'ARRAY') {
182
183 # if we expand for php, keep empty ARRAY
184 if($#$obj == -1 && $options->{childObj2string}) {
185 $result = $obj;
186 } else {
187 IterArray @$obj, sub {
188 my $item;
189 # if current item is a reference ...
190 if (ref $_[0]) {
191 $item = $_[0];
192 # if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
193 # instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> )
194 if ($item && $options->{childObj2string}) {
195 $item = twingle_reference($item);
196 } else {
197 # ... expand structure recursively
198 $item = expand($_[0], $options);
199 }
200 # destroy item via seperate callback method (a POST) if requested
201 #$options->{cb}->{destroy}->($_[0]) if $options->{destroy};
202
203 # ... assume plain scalar
204 } else {
205 #$item = deep_copy($_[0]);
206 $item = $_[0];
207 # conversions/encodings
208 $item = latin_to_utf8_scalar($item) if ($item && $options->{utf8});
209 $item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin});
210 }
211
212 $item = '' if $options->{define} and not defined $item;
213 #push(@{$result}, $item) if $item; # use item only if not undef (TODO: make configurable via $options)
214 push(@{$result}, $item); # use item in any case
215
216 }
217 }
218
219 } elsif (ref $obj eq 'CODE') {
220 #print Dumper($obj);
221 #exit;
222
223 # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ???
224 } elsif (ref $obj) {
225
226 # if we expand for php, keep empty HASH
227 my @tmp = keys %$obj;
228 if($#tmp == -1 && $options->{childObj2string}) {
229 $result = $obj;
230 } else {
231 IterHash %$obj, sub {
232 my $item;
233
234 # if current item is a reference ...
235 if (ref $_[1]) {
236 $item = $_[1];
237 # if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
238 # instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> )
239 if ($item && $options->{childObj2string} && !(ref $_[1] eq "ARRAY") && !(ref $_[1] eq "HASH") && !(ref $_[1] eq "Set::Object")) {
240 $item = twingle_reference($item);
241 } else {
242 # ... expand structure recursively
243 $item = expand($_[1], $options);
244 }
245 # destroy item via seperate callback method (a POST) if requested
246 #$options->{cb}->{destroy}->($_[1]) if $options->{destroy};
247
248 # ... assume plain scalar
249 } else {
250 #$item = deep_copy($_[1]);
251 $item = $_[1];
252 # conversions/encodings
253 $item = latin_to_utf8_scalar($item) if ($item && $options->{utf8});
254 $item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin});
255 }
256
257 $item = '' if $options->{define} and not defined $item;
258 #$result->{$_[0]} = $item if $item; # use item only if not undef (TODO: make configurable via $options)
259 $result->{$_[0]} = $item; # use item in any case
260 }
261 }
262
263 } else {
264 #die ("not a reference!");
265 $result = $obj;
266
267 }
268
269 # convert all values to utf8 (inside complex struct)
270 # now done in core-item-callbacks via Greg London's "Iterate" from CPAN
271 # latin_to_utf8($result) if ($options->{utf8});
272
273 # destroy persistent object from memory to be sure to get a fresh one next time
274 #undef $obj if $options->{destroy};
275 #$options->{cb_destroy}->($obj) if $options->{cb_destroy};
276 #$options->{cb}->{destroy}->($obj) if $options->{destroy};
277
278 return $result;
279 }
280
281
282
283 my @indexstack;
284 sub _var_traverse_mixin_update_old {
285 my $obj = shift;
286 my $data = shift;
287 my $bool_recursion = shift;
288 if (!$bool_recursion) {
289 @indexstack = ();
290 }
291 my $result;
292
293 # 'ARRAY' does not work!
294 if ((ref $obj) eq 'ARRAY') {
295 #print "ARRAY\n";
296 my $i = 0;
297 foreach (@{$obj}) {
298 push @indexstack, $i;
299 my $ref = ref $_;
300 if ($ref) {
301 #$obj->[$i] = var_mixin($_, $data, 1);
302 var_traverse_mixin_update($_, $data, 1);
303 } else {
304 $obj->[$i] = $_;
305 }
306 pop @indexstack;
307 $i++;
308 }
309 } else {
310 foreach (keys %{$obj}) {
311 push @indexstack, $_;
312 my $ref = ref $obj->{$_};
313 if ($ref) {
314 #$obj->{$_} = var_mixin($obj->{$_}, $data, 1);
315 var_traverse_mixin_update($obj->{$_}, $data, 1);
316 } else {
317 #$obj->{$_} = $obj->{$_};
318 my $evstring = getSlot($data);
319 $obj->{$_} = $evstring;
320
321 }
322 pop @indexstack;
323 }
324 }
325 #return $result;
326 }
327
328 sub merge_to {
329 _hash2object(@_);
330 # TODO:
331 # re-implement using CPAN's "Iterate" and/or a modified Hash::Merge.
332 }
333
334
335 # todo: maybe do diff(s) here sometimes!?
336 sub _hash2object {
337 my $object = shift;
338 my $data = shift;
339 my $options = shift;
340
341 #print "hash2object", "\n";
342
343 # "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables,
344 # this method corrects this
345 numhash2list($data) if ($options->{php});
346
347 # utf8-conversion/-encoding (essential for I18N)
348 utf8_to_latin($data) if ($options->{utf8});
349
350 # get fresh object from database
351 # todo:
352 # - handle "locked" objects !!!
353 # - check if already another update occoured (object-revisioning needed!)
354 #my $obj = $self->getObject($oid);
355
356 # mix changes into fresh object and save it back
357 _hash2object_traverse_mixin($object, $data, 0, $options);
358
359 # done in core mixin function?
360 #$self->{storage}->update($obj);
361
362 # we should "undef" some objects here to destroy them in memory and enforce reloading when used next time
363 # simulate:
364 #$self->{storage}->disconnect();
365
366 }
367
368 # ------------------------------------
369 # core mixin function
370 # TODO-FEATURE: make this possible in a reverse way: object is empty (no fields) and gets filled up by mixin-data
371
372 # remember keys of structures we are traversing
373 # this is a HACK:
374 # - don't (!!!) "packageglobal" @indexstack
375 # - it will lead to problems with parallelism!
376
377 #my @indexstack;
378
379 # traverse a deeply nested structure, mix in values from given hash, update underlying tangram-object
380 sub _hash2object_traverse_mixin {
381 my $object = shift;
382 my $data = shift;
383 my $bool_recursion = shift;
384 my $options = shift;
385
386 # clear our key - stack if we are called from user-code (non-recursively)
387 @indexstack = () if (!$bool_recursion);
388
389 my $classname = ref $object;
390 # if ($classname) {
391 # print STDERR "*****************", Dumper(Class::Tangram::attribute_types($classname)), "\n";
392 # }
393
394 # parser: detected OBJECT (a Tangram one?) (reftype == HASH) (assume)
395 # what's exactly done here? hmmm.... it works ;)
396 # maybe a HACK: please try not to use "IntrHash"es, maybe this cannot handle them!!!
397 # extend! check!
398
399 #print attributes::reftype($object), "\n";
400
401 # V1
402 #if ((attributes::reftype($object) eq 'HASH') && (ref($object) ne 'HASH') && (ref($object) ne 'ARRAY')) {
403 # V2
404 my $reftype = attributes::reftype($object);
405 #print "reftype: '$reftype'", "\n";
406 if ($reftype eq 'HASH') {
407
408 # print STDERR "===", "reftype: ", attributes::reftype($obj), "\n";
409
410 my @fields;
411 # loop through fields of object (Tangram-object)
412 @fields = keys %{$object};
413
414 # loop through fields of to.be.injected-data (arbitrary Perl-data-structure)
415 @fields = keys %{$data} if $options->{init};
416 # @fields = keys %{$data} if $options->{mixin};
417
418 foreach (@fields) {
419 my $field = $_;
420 push @indexstack, $field;
421
422 # determine type of object
423 my $ref = ref $object->{$field};
424 # print STDERR "attrname: $_ ATTRref: $ref", "\n";
425 if ($ref) {
426 _hash2object_traverse_mixin($object->{$field}, $data, 1, $options);
427 } else {
428 my $val = ref_slot($data, \@indexstack);
429
430 #print Dumper($options);
431 my $field_target = $field;
432 if (my $pattern = $options->{pattern_strip_key}) {
433 print "pattern: $pattern", "\n";
434 $field_target =~ s/$pattern//;
435 print "field: $field_target", "\n";
436 }
437
438 $object->{$field_target} = $val if defined $val;
439 }
440 pop @indexstack;
441 }
442
443 # save object to database ...
444 # ... do an update if it already exists, do an insert if it doesn't
445 # my $objectId = $self->{storage}->id($obj);
446 # $logger->debug( __PACKAGE__ . "->saveObjectFromHash_traverse_mixin_update( object $obj objectId $objectId )" );
447 # if ($objectId) {
448 # $self->{storage}->update($obj);
449
450 #print __PACKAGE__ . ":", "\n";
451 #print Dumper($object);
452
453 # } else {
454 # $self->{storage}->insert($obj);
455 # }
456
457 }
458
459 #&& ( ref($obj) ne 'HASH' )
460
461 # loop through entries of array (IntrArray, isn't it?)
462 if ((ref $object) eq 'ARRAY') {
463 # print STDERR "===", "refttype ", attributes::reftype($obj), "\n";
464 my $i = 0;
465 foreach (@{$object}) {
466 push @indexstack, $i;
467 my $ref = ref $_;
468 # print STDERR "attrname: $_ ATTRref: $ref", "\n";
469 # if ($ref && $_) {
470 if ($ref) {
471 _hash2object_traverse_mixin($_, $data, 1, $options);
472 } else {
473 $object->[$i] = $_ if defined $_;
474 }
475 pop @indexstack;
476 $i++;
477 }
478
479 =pod
480 # object?
481 } else {
482 print "reference: ", ref $object, "\n";
483 print "reftype: ", $reftype, "\n";
484 die(__PACKAGE__ . "->_hash2object_traverse_mixin: can not handle this!");
485 =cut
486
487 }
488
489 }
490
491
492 # ACK's go to Randal L. Schwartz <merlyn@stonehenge.com>
493 # on the website:
494 # This text is copyright by Miller-Freeman, Inc., and is used with their permission.
495 # Further distribution or use is not permitted.
496 # please visit http://www.stonehenge.com/merlyn/UnixReview/col30.html
497 sub deep_copy1 {
498 my $this = shift;
499 if (not ref $this) {
500 $this;
501 } elsif (ref $this eq "ARRAY") {
502 [map deep_copy1($_), @$this];
503 } elsif (ref $this eq "HASH") {
504 +{map { $_ => deep_copy1($this->{$_}) } keys %$this};
505 } elsif (ref $this eq "CODE") {
506 $this;
507 } else { die "deep_copy1 asks: what type is $this?" }
508 #} else { print "deep_copy asks: what type is $this?", "\n"; }
509 }
510
511 # ACK's go to Andrew Pitonyak
512 # Copyright 2002, Andrew Pitonyak (perlboy@pitonyak.org)
513 # please visit: http://www.pitonyak.org/code/perl/Pitonyak/DeepCopy.pm.html
514 sub deep_copy {
515 Pitonyak::DeepCopy::deep_copy(@_);
516 }
517
518
519 1;
520 __END__

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed