--- nfo/perl/libs/Data/Mungle/Transform/Deep.pm 2002/12/05 13:56:49 1.4 +++ nfo/perl/libs/Data/Mungle/Transform/Deep.pm 2003/03/28 03:07:26 1.18 @@ -1,28 +1,71 @@ -############################################## -# -# $Id: Deep.pm,v 1.4 2002/12/05 13:56:49 joko Exp $ -# -# $Log: Deep.pm,v $ -# Revision 1.4 2002/12/05 13:56:49 joko -# - var_deref -# + expand - more sophisticated dereferencing with callbacks using Iterate -# -# Revision 1.3 2002/12/03 05:34:55 joko -# + bugfix: now utilizing var_utf2iso from Data::Transform::Encode -# -# Revision 1.2 2002/12/01 04:44:07 joko -# + code from Data::Transform::OO -# -# Revision 1.1 2002/11/29 04:49:20 joko -# + initial check-in -# -# Revision 1.1 2002/10/10 03:26:00 cvsjoko -# + new -# -############################################## +## --------------------------------------------------------------------------- +## $Id: Deep.pm,v 1.18 2003/03/28 03:07:26 jonen Exp $ +## --------------------------------------------------------------------------- +## $Log: Deep.pm,v $ +## Revision 1.18 2003/03/28 03:07:26 jonen +## + minor changes +## +## Revision 1.17 2003/03/27 15:17:07 joko +## namespace fixes for Data::Mungle::* +## +## Revision 1.16 2003/03/27 15:04:52 joko +## minor update: comment +## +## Revision 1.15 2003/02/27 14:39:48 jonen +## + fixed bug at _hash2object() +## +## Revision 1.14 2003/02/22 17:13:55 jonen +## + added function 'childObject2string()' to encode 'child'-references to option related string +## + use new option at 'expand()' for replacing 'childObject2string' +## +## Revision 1.13 2003/02/21 01:48:50 joko +## renamed core function +## +## Revision 1.12 2003/02/20 22:45:19 joko +## fix regarding new deep_copy +## +## Revision 1.11 2003/02/20 21:13:54 joko +## - removed implementation of deep_copy2 - get this from the Pitonyak namespace (now cloned to repository) +## +## Revision 1.10 2003/02/20 20:48:00 joko +## - refactored lots of code to Data::Code::Ref +## + alternative 'deep_copy' implementation +## +## Revision 1.9 2003/02/18 19:35:56 joko +## +- modified 'sub refexpr2perlref': now can get the $delimiter passed, too +## +## Revision 1.8 2003/02/09 05:10:56 joko +## + minor update +## +## Revision 1.7 2003/01/19 03:26:59 joko +## + added 'sub deep_copy' - refactored from libp +## + add 'sub merge' - exported from CPAN's 'Hash::Merge' +## +## Revision 1.6 2002/12/23 11:27:53 jonen +## + changed behavior WATCH! +## +## Revision 1.5 2002/12/16 19:57:54 joko +## + option 'init' +## +## Revision 1.4 2002/12/05 13:56:49 joko +## - var_deref +## + expand - more sophisticated dereferencing with callbacks using Iterate +## +## Revision 1.3 2002/12/03 05:34:55 joko +## + bugfix: now utilizing var_utf2iso from Data::Transform::Encode +## +## Revision 1.2 2002/12/01 04:44:07 joko +## + code from Data::Transform::OO +## +## Revision 1.1 2002/11/29 04:49:20 joko +## + initial check-in +## +## Revision 1.1 2002/10/10 03:26:00 cvsjoko +## + new +## --------------------------------------------------------------------------- -package Data::Transform::Deep; +package Data::Mungle::Transform::Deep; use strict; use warnings; @@ -30,23 +73,21 @@ require Exporter; our @ISA = qw( Exporter ); our @EXPORT_OK = qw( - &var_NumericalHashToArray - &var_mixin - &object2hash - &hash2object - &refexpr2perlref &expand + &deep_copy + &merge_to ); -# &var_deref -# &getStructSlotByStringyAddress + use attributes; use Data::Dumper; -use Data::Transform::Encode qw( var_utf2iso var2utf8 scalar2utf8 ); -use libp qw( deep_copy ); use Iterate; -sub var_NumericalHashToArray { +use Pitonyak::DeepCopy; +use Data::Mungle::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar ); +use Data::Mungle::Code::Ref qw( ref_slot ); + +sub numhash2list { my $vref = shift; #my $context = shift; if (ref $vref eq 'HASH') { @@ -62,7 +103,7 @@ } $vref->{$_} = \@arr; } - var_NumericalHashToArray($vref->{$_}); + numhash2list($vref->{$_}); } # } else { # #$vref->{$_} = scalar2iso($vref->{$_}); @@ -72,7 +113,10 @@ } -sub var_deref { +# FIXME: could this be refactored using expand? +# btw: "expand": look at scripts@CPAN (System Administration): +# there is a perl make with perl +sub _var_deref_test { my $obj = shift; my $options = shift; my $result; @@ -111,20 +155,31 @@ } +# convert values in hash to utf8 (and back) to be ready for (e.g.) encapsulation in XML +# but still using the known latin locale stuff sub expand { my $obj = shift; my $options = shift; my $result; - if ((ref $obj) eq 'ARRAY') { + #print "ref: ", ref $obj, "\n"; + + if (ref $obj eq 'ARRAY') { IterArray @$obj, sub { my $item; # if current item is a reference ... if (ref $_[0]) { - # ... expand structure recursively - $item = expand($_[0], $options); + $item = $_[0]; + # if $options->{childObj2string} is TRUE or STRING don't expand referenced object, + # instead replace it by per option choosed string (default: o___ ) + if ($item && $options->{childObj2string}) { + $item = childObj2string($item, $options->{childObj2string}); + } else { + # ... expand structure recursively + $item = expand($_[0], $options); + } # destroy item via seperate callback method (a POST) if requested #$options->{cb}->{destroy}->($_[0]) if $options->{destroy}; @@ -133,23 +188,35 @@ #$item = deep_copy($_[0]); $item = $_[0]; # conversions/encodings - $item = scalar2utf8($item) if ($item && $options->{utf8}); + $item = latin_to_utf8_scalar($item) if ($item && $options->{utf8}); + $item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin}); } #push(@{$result}, $item) if $item; # use item only if not undef (TODO: make configurable via $options) push(@{$result}, $item); # use item in any case } + } elsif (ref $obj eq 'CODE') { + #print Dumper($obj); + #exit; + # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ??? - } else { + } elsif (ref $obj) { IterHash %$obj, sub { my $item; # if current item is a reference ... if (ref $_[1]) { - # ... expand structure recursively - $item = expand($_[1], $options); + $item = $_[1]; + # if $options->{childObj2string} is TRUE or STRING don't expand referenced object, + # instead replace it by per option choosed string (default: o___ ) + if ($item && $options->{childObj2string} && !(ref $_[1] eq "ARRAY") && !(ref $_[1] eq "HASH")) { + $item = childObj2string($item, $options->{childObj2string}); + } else { + # ... expand structure recursively + $item = expand($_[1], $options); + } # destroy item via seperate callback method (a POST) if requested #$options->{cb}->{destroy}->($_[1]) if $options->{destroy}; @@ -158,17 +225,22 @@ #$item = deep_copy($_[1]); $item = $_[1]; # conversions/encodings - $item = scalar2utf8($item) if ($item && $options->{utf8}); + $item = latin_to_utf8_scalar($item) if ($item && $options->{utf8}); + $item = utf8_to_latin_scalar($item) if ($item && $options->{to_latin}); } #$result->{$_[0]} = $item if $item; # use item only if not undef (TODO: make configurable via $options) $result->{$_[0]} = $item; # use item in any case } + } else { + #die ("not a reference!"); + $result = $obj; + } # convert all values to utf8 (inside complex struct) # now done in core-item-callbacks via Greg London's "Iterate" from CPAN - # var2utf8($result) if ($options->{utf8}); + # latin_to_utf8($result) if ($options->{utf8}); # destroy persistent object from memory to be sure to get a fresh one next time #undef $obj if $options->{destroy}; @@ -181,7 +253,7 @@ my @indexstack; -sub var_traverse_mixin_update { +sub _var_traverse_mixin_update_old { my $obj = shift; my $data = shift; my $bool_recursion = shift; @@ -225,17 +297,15 @@ #return $result; } -sub object2hash { - my $object = shift; - my $options = shift; - #my $deref = var_deref($object); - my $deref = expand($object, $options); - #var2utf8($deref) if ($options->{utf8}); - return $deref; +sub merge_to { + _hash2object(@_); + # TODO: + # re-implement using CPAN's "Iterate" and/or a modified Hash::Merge. } + # todo: maybe do diff(s) here sometimes!? -sub hash2object { +sub _hash2object { my $object = shift; my $data = shift; my $options = shift; @@ -244,10 +314,10 @@ # "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables, # this method corrects this - var_NumericalHashToArray($data) if ($options->{php}); + numhash2list($data) if ($options->{php}); # utf8-conversion/-encoding (essential for I18N) - var_utf2iso($data) if ($options->{utf8}); + utf8_to_latin($data) if ($options->{utf8}); # get fresh object from database # todo: @@ -256,7 +326,7 @@ #my $obj = $self->getObject($oid); # mix changes into fresh object and save it back - hash2object_traverse_mixin($object, $data); + _hash2object_traverse_mixin($object, $data, 0, $options); # done in core mixin function? #$self->{storage}->update($obj); @@ -279,10 +349,11 @@ #my @indexstack; # traverse a deeply nested structure, mix in values from given hash, update underlying tangram-object -sub hash2object_traverse_mixin { +sub _hash2object_traverse_mixin { my $object = shift; my $data = shift; my $bool_recursion = shift; + my $options = shift; # clear our key - stack if we are called from user-code (non-recursively) @indexstack = () if (!$bool_recursion); @@ -296,22 +367,47 @@ # what's exactly done here? hmmm.... it works ;) # maybe a HACK: please try not to use "IntrHash"es, maybe this cannot handle them!!! # extend! check! - if ((attributes::reftype($object) eq 'HASH') && (ref($object) ne 'HASH') && (ref($object) ne 'ARRAY')) { + + #print attributes::reftype($object), "\n"; + + # V1 + #if ((attributes::reftype($object) eq 'HASH') && (ref($object) ne 'HASH') && (ref($object) ne 'ARRAY')) { + # V2 + my $reftype = attributes::reftype($object); + #print "reftype: '$reftype'", "\n"; + if ($reftype eq 'HASH') { # print STDERR "===", "reftype: ", attributes::reftype($obj), "\n"; + my @fields; # loop through fields of object (Tangram-object) - foreach (keys %{$object}) { - push @indexstack, $_; + @fields = keys %{$object}; + + # loop through fields of to.be.injected-data (arbitrary Perl-data-structure) + @fields = keys %{$data} if $options->{init}; +# @fields = keys %{$data} if $options->{mixin}; + + foreach (@fields) { + my $field = $_; + push @indexstack, $field; # determine type of object - my $ref = ref $object->{$_}; + my $ref = ref $object->{$field}; # print STDERR "attrname: $_ ATTRref: $ref", "\n"; if ($ref) { - hash2object_traverse_mixin($object->{$_}, $data, 1); + _hash2object_traverse_mixin($object->{$field}, $data, 1, $options); } else { - my $val = getStructSlotByStringyAddress($data, \@indexstack); - $object->{$_} = $val; + my $val = ref_slot($data, \@indexstack); + +#print Dumper($options); + my $field_target = $field; + if (my $pattern = $options->{pattern_strip_key}) { + print "pattern: $pattern", "\n"; + $field_target =~ s/$pattern//; + print "field: $field_target", "\n"; + } + + $object->{$field_target} = $val if defined $val; } pop @indexstack; } @@ -342,101 +438,67 @@ push @indexstack, $i; my $ref = ref $_; # print STDERR "attrname: $_ ATTRref: $ref", "\n"; - if ($ref && $_) { - hash2object_traverse_mixin($_, $data, 1); +# if ($ref && $_) { + if ($ref) { + _hash2object_traverse_mixin($_, $data, 1, $options); } else { - $object->[$i] = $_; + $object->[$i] = $_ if defined $_; } pop @indexstack; $i++; } + +=pod + # object? + } else { + print "reference: ", ref $object, "\n"; + print "reftype: ", $reftype, "\n"; + die(__PACKAGE__ . "->_hash2object_traverse_mixin: can not handle this!"); +=cut + } } -# this function seems to do similar stuff like these below (refexpr2perlref & co.) -sub getStructSlotByStringyAddress { - my $var = shift; - my $indexstack_ref = shift; - my @indexstack = @{$indexstack_ref}; - my $joiner = '->'; - my @evlist; - foreach (@indexstack) { - my $elem; - if ($_ =~ m/\d+/) { $elem = "[$_]"; } - if ($_ =~ m/\D+/) { $elem = "{$_}"; } - push @evlist, $elem; - } - my $evstring = join($joiner, @evlist); - $evstring = 'return $var->' . $evstring . ';'; - #print "ev: $evstring\n"; - return eval($evstring); +# ACK's go to Randal L. Schwartz +# on the website: +# This text is copyright by Miller-Freeman, Inc., and is used with their permission. +# Further distribution or use is not permitted. +# please visit http://www.stonehenge.com/merlyn/UnixReview/col30.html +sub deep_copy1 { + my $this = shift; + if (not ref $this) { + $this; + } elsif (ref $this eq "ARRAY") { + [map deep_copy1($_), @$this]; + } elsif (ref $this eq "HASH") { + +{map { $_ => deep_copy1($this->{$_}) } keys %$this}; + } elsif (ref $this eq "CODE") { + $this; + } else { die "deep_copy1 asks: what type is $this?" } + #} else { print "deep_copy asks: what type is $this?", "\n"; } } +# ACK's go to Andrew Pitonyak +# Copyright 2002, Andrew Pitonyak (perlboy@pitonyak.org) +# please visit: http://www.pitonyak.org/code/perl/Pitonyak/DeepCopy.pm.html +sub deep_copy { + Pitonyak::DeepCopy::deep_copy(@_); +} -sub refexpr2perlref { +sub childObj2string { my $obj = shift; - my $expr = shift; - my $callbackMap = shift; - - my $value; - # detect for callback (code-reference) - if (ref($expr) eq 'CODE') { - $value = &$expr($obj); - - } elsif ($expr =~ m/->/) { - # use expr as complex object reference declaration (obj->subObj->subSubObj->0->attribute) - (my $objPerlRefString, my $parts) = refexpr2perlref_parts($expr); - #print "\n", "expr: $expr"; - #print "\n", "objPerlRefString: $objPerlRefString"; - $value = eval('$obj' . '->' . $objPerlRefString); - - # if value isn't set, try to "fallback" to callbackMap - # callbacks are applied this way: - # take the last element of the expression parts and check if this string exists as a key in the callback-map - if (!$value && $callbackMap) { - #print Dumper($callbackMap); - - # prepare needle - my @parts = @$parts; - my $count = $#parts; - my $needle = $parts[$count]; - - # prepare haystack - my @haystack = keys %$callbackMap; - if (grep($needle, @haystack)) { - $value = $callbackMap->{$needle}->(); - #print "value: ", $value, "\n"; - } - } - - } else { - # use expr as simple scalar key (attributename) - $value = $obj->{$expr}; - } - - return $value; + my $option = shift; + my $classname = ref $obj; + if($option == 1) { + my $string = "o_" . $obj->{guid} . "_" . $classname; + } + return $string; } -sub refexpr2perlref_parts { - my $expr = shift; - - # split expression by dereference operators first - my @parts_pure = split(/->/, $expr); - - # wrap []'s around each part, if it consists of numeric characters only (=> numeric = array-index), - # use {}'s, if there are word-characters in it (=> alphanumeric = hash-key) - my @parts_capsule = @parts_pure; - map { - m/^\d+$/ && ($_ = "[$_]") || ($_ = "{$_}"); - } @parts_capsule; - - # join parts with dereference operators together again and return built string - return (join('->', @parts_capsule), \@parts_pure); -} - 1; +__END__