--- 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/02/18 19:35:56 1.9 @@ -1,25 +1,39 @@ -############################################## -# -# $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.9 2003/02/18 19:35:56 joko Exp $ +## --------------------------------------------------------------------------- +## $Log: Deep.pm,v $ +## 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; @@ -36,6 +50,8 @@ &hash2object &refexpr2perlref &expand + &deep_copy + &merge ); # &var_deref # &getStructSlotByStringyAddress @@ -43,7 +59,8 @@ use attributes; use Data::Dumper; use Data::Transform::Encode qw( var_utf2iso var2utf8 scalar2utf8 ); -use libp qw( deep_copy ); + +use Hash::Merge qw( merge ); use Iterate; sub var_NumericalHashToArray { @@ -72,6 +89,9 @@ } +# 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 { my $obj = shift; my $options = shift; @@ -256,7 +276,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); @@ -283,6 +303,7 @@ 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); @@ -300,18 +321,35 @@ # 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; + +#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,10 +380,11 @@ 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++; @@ -356,6 +395,7 @@ # 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; @@ -379,21 +419,48 @@ my $obj = shift; my $expr = shift; - my $callbackMap = 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/->/) { + } elsif ($expr =~ m/$delimiter/) { # 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); + (my $objPerlRefString, my $parts) = refexpr2perlref_parts($expr, $delimiter); + + # trace + #print "expr: $expr", "\n"; + #print "objPerlRefString: $objPerlRefString", "\n"; - # if value isn't set, try to "fallback" to callbackMap + 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) { @@ -424,9 +491,12 @@ sub refexpr2perlref_parts { my $expr = shift; + my $delimiter = shift; + + $delimiter = quotemeta($delimiter); # split expression by dereference operators first - my @parts_pure = split(/->/, $expr); + 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) @@ -439,4 +509,19 @@ return (join('->', @parts_capsule), \@parts_pure); } +# ACK's go to ... +sub deep_copy { + my $this = shift; + if (not ref $this) { + $this; + } elsif (ref $this eq "ARRAY") { + [map deep_copy($_), @$this]; + } elsif (ref $this eq "HASH") { + +{map { $_ => deep_copy($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"; } +} + 1;