--- nfo/perl/libs/Data/Mungle/Transform/Deep.pm 2003/02/18 19:35:56 1.9 +++ nfo/perl/libs/Data/Mungle/Transform/Deep.pm 2003/02/27 14:39:48 1.15 @@ -1,7 +1,27 @@ ## --------------------------------------------------------------------------- -## $Id: Deep.pm,v 1.9 2003/02/18 19:35:56 joko Exp $ +## $Id: Deep.pm,v 1.15 2003/02/27 14:39:48 jonen Exp $ ## --------------------------------------------------------------------------- ## $Log: Deep.pm,v $ +## 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 ## @@ -44,26 +64,21 @@ require Exporter; our @ISA = qw( Exporter ); our @EXPORT_OK = qw( - &var_NumericalHashToArray - &var_mixin - &object2hash - &hash2object - &refexpr2perlref &expand &deep_copy - &merge + &merge_to ); -# &var_deref -# &getStructSlotByStringyAddress + use attributes; use Data::Dumper; -use Data::Transform::Encode qw( var_utf2iso var2utf8 scalar2utf8 ); - -use Hash::Merge qw( merge ); use Iterate; -sub var_NumericalHashToArray { +use Pitonyak::DeepCopy; +use Data::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar ); +use Data::Code::Ref qw( ref_slot ); + +sub numhash2list { my $vref = shift; #my $context = shift; if (ref $vref eq 'HASH') { @@ -79,7 +94,7 @@ } $vref->{$_} = \@arr; } - var_NumericalHashToArray($vref->{$_}); + numhash2list($vref->{$_}); } # } else { # #$vref->{$_} = scalar2iso($vref->{$_}); @@ -92,7 +107,7 @@ # 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 { +sub _var_deref_test { my $obj = shift; my $options = shift; my $result; @@ -131,20 +146,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}; @@ -153,23 +179,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}; @@ -178,17 +216,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}; @@ -201,7 +244,7 @@ my @indexstack; -sub var_traverse_mixin_update { +sub _var_traverse_mixin_update_old { my $obj = shift; my $data = shift; my $bool_recursion = shift; @@ -245,17 +288,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". } + # todo: maybe do diff(s) here sometimes!? -sub hash2object { +sub _hash2object { my $object = shift; my $data = shift; my $options = shift; @@ -264,10 +305,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: @@ -276,7 +317,7 @@ #my $obj = $self->getObject($oid); # mix changes into fresh object and save it back - hash2object_traverse_mixin($object, $data, 0, $options); + _hash2object_traverse_mixin($object, $data, 0, $options); # done in core mixin function? #$self->{storage}->update($obj); @@ -299,7 +340,7 @@ #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; @@ -317,7 +358,15 @@ # 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"; @@ -337,9 +386,9 @@ my $ref = ref $object->{$field}; # print STDERR "attrname: $_ ATTRref: $ref", "\n"; if ($ref) { - hash2object_traverse_mixin($object->{$field}, $data, 1, $options); + _hash2object_traverse_mixin($object->{$field}, $data, 1, $options); } else { - my $val = getStructSlotByStringyAddress($data, \@indexstack); + my $val = ref_slot($data, \@indexstack); #print Dumper($options); my $field_target = $field; @@ -382,146 +431,65 @@ # print STDERR "attrname: $_ ATTRref: $ref", "\n"; # if ($ref && $_) { if ($ref) { - hash2object_traverse_mixin($_, $data, 1, $options); + _hash2object_traverse_mixin($_, $data, 1, $options); } else { $object->[$i] = $_ if defined $_; } pop @indexstack; $i++; } - } - -} - - -# this function seems to do similar stuff like these below (refexpr2perlref & co.) -# TODO: maybe this mechanism can be replaced completely through some nice module from CPAN .... ? ;-) -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); -} - - -sub refexpr2perlref { - - my $obj = shift; - my $expr = shift; - my $values = shift; - my $delimiter = shift; - - $delimiter ||= '->'; - - my $value; - # detect for callback (code-reference) - if (ref($expr) eq 'CODE') { - $value = &$expr($obj); - - } elsif ($expr =~ m/$delimiter/) { - # use expr as complex object reference declaration (obj->subObj->subSubObj->0->attribute) - (my $objPerlRefString, my $parts) = refexpr2perlref_parts($expr, $delimiter); - - # trace - #print "expr: $expr", "\n"; - #print "objPerlRefString: $objPerlRefString", "\n"; - - my $evstr = '$obj' . '->' . $objPerlRefString; - - # trace - #print "eval: $evstr", "\n"; - - $value = eval($evstr); - die ($@) if $@; - - # if value isn't set, try to set it - my $callbackMap; - if ($values) { - #if (ref $values eq 'HASH') { - if (ref $values eq 'Data::Map') { - $callbackMap = $values->getAttributes(); - } else { - # apply $values as single value to referenced slot - #print "APPLY!", "\n"; - eval('$obj' . '->' . $objPerlRefString . ' = $values;'); - die ($@) if $@; - } - } - - # determine $values - if it's a hashref, use it as a "valueMap" - # "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"; - } - } +=pod + # object? } else { - # use expr as simple scalar key (attributename) - $value = $obj->{$expr}; - } - - return $value; + print "reference: ", ref $object, "\n"; + print "reftype: ", $reftype, "\n"; + die(__PACKAGE__ . "->_hash2object_traverse_mixin: can not handle this!"); +=cut -} - - -sub refexpr2perlref_parts { - my $expr = shift; - my $delimiter = shift; - - $delimiter = quotemeta($delimiter); - - # split expression by dereference operators first - my @parts_pure = split(/$delimiter/, $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); } -# ACK's go to ... -sub deep_copy { + +# 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_copy($_), @$this]; + [map deep_copy1($_), @$this]; } elsif (ref $this eq "HASH") { - +{map { $_ => deep_copy($this->{$_}) } keys %$this}; + +{map { $_ => deep_copy1($this->{$_}) } keys %$this}; } elsif (ref $this eq "CODE") { $this; - #} else { die "deep_copy asks: what type is $this?" } - } else { print "deep_copy asks: what type is $this?", "\n"; } + } 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 childObj2string { + my $obj = shift; + my $option = shift; + my $classname = ref $obj; + + if($option == 1) { + my $string = "o_" . $classname . "_" .$obj->{guid}; + return $string; + } +} + + 1; +__END__