--- nfo/perl/libs/Data/Mungle/Transform/Deep.pm 2002/12/03 05:34:55 1.3 +++ nfo/perl/libs/Data/Mungle/Transform/Deep.pm 2003/02/20 22:45:19 1.12 @@ -1,21 +1,49 @@ -############################################## -# -# $Id: Deep.pm,v 1.3 2002/12/03 05:34:55 joko Exp $ -# -# $Log: Deep.pm,v $ -# 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.12 2003/02/20 22:45:19 joko Exp $ +## --------------------------------------------------------------------------- +## $Log: Deep.pm,v $ +## 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; @@ -26,20 +54,21 @@ require Exporter; our @ISA = qw( Exporter ); our @EXPORT_OK = qw( - &var_NumericalHashToArray - &var_deref - &var_mixin - &object2hash - &hash2object - &refexpr2perlref + &expand + &deep_copy + &merge_to ); -# &getStructSlotByStringyAddress + use attributes; use Data::Dumper; -use Data::Transform::Encode qw( var_utf2iso ); +use Iterate; + +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 var_NumericalHashToArray { +sub numhash2list { my $vref = shift; #my $context = shift; if (ref $vref eq 'HASH') { @@ -55,7 +84,7 @@ } $vref->{$_} = \@arr; } - var_NumericalHashToArray($vref->{$_}); + numhash2list($vref->{$_}); } # } else { # #$vref->{$_} = scalar2iso($vref->{$_}); @@ -65,17 +94,25 @@ } -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; if ((ref $obj) eq 'ARRAY') { foreach (@{$obj}) { my $ref = ref $_; if ($ref) { - push(@{$result}, var_deref($_)); + push(@{$result}, var_deref($_, $options)); + #undef $_; } else { - push(@{$result}, $_); + #push(@{$result}, $_); + push(@{$result}, deep_copy($_)); } + #undef $_ if $options->{destroy}; + #$options->{destroy}->($_) if $options->{destroy}; } # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ??? } else { @@ -83,20 +120,105 @@ my $key = $_; my $ref = ref $obj->{$_}; if ($ref) { - $result->{$_} = var_deref($obj->{$_}); + $result->{$_} = var_deref($obj->{$_}, $options); + #undef $obj->{$_}; } else { - $result->{$_} = $obj->{$_}; + #$result->{$_} = $obj->{$_}; + $result->{$_} = deep_copy($obj->{$_}); } + #undef $obj->{$_} if $options->{destroy}; + #$options->{destroy}->($obj->{$_}) if $options->{destroy}; } } + #undef $obj if $options->{destroy}; + $options->{cb_destroy}->($obj) if $options->{cb_destroy}; return $result; } +sub expand { + + my $obj = shift; + my $options = shift; + my $result; + + #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); + # destroy item via seperate callback method (a POST) if requested + #$options->{cb}->{destroy}->($_[0]) if $options->{destroy}; + + # ... assume plain scalar + } else { + #$item = deep_copy($_[0]); + $item = $_[0]; + # conversions/encodings + $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'; }" ??? + } elsif (ref $obj) { + + IterHash %$obj, sub { + my $item; + + # if current item is a reference ... + if (ref $_[1]) { + # ... expand structure recursively + $item = expand($_[1], $options); + # destroy item via seperate callback method (a POST) if requested + #$options->{cb}->{destroy}->($_[1]) if $options->{destroy}; + + # ... assume plain scalar + } else { + #$item = deep_copy($_[1]); + $item = $_[1]; + # conversions/encodings + $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}); + + # destroy persistent object from memory to be sure to get a fresh one next time + #undef $obj if $options->{destroy}; + #$options->{cb_destroy}->($obj) if $options->{cb_destroy}; + #$options->{cb}->{destroy}->($obj) if $options->{destroy}; + + return $result; +} + my @indexstack; -sub var_traverse_mixin_update { +sub _var_traverse_mixin_update_old { my $obj = shift; my $data = shift; my $bool_recursion = shift; @@ -140,16 +262,15 @@ #return $result; } -sub object2hash { - my $object = shift; - my $options = shift; - my $deref = var_deref($object); - 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; @@ -158,7 +279,7 @@ # "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}); @@ -170,7 +291,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); @@ -193,10 +314,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); @@ -210,22 +332,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; } @@ -256,101 +403,55 @@ 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"; } } - -sub refexpr2perlref { - - 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; - +# 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_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__