--- 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/20 20:48:00 1.10 @@ -1,7 +1,11 @@ ## --------------------------------------------------------------------------- -## $Id: Deep.pm,v 1.9 2003/02/18 19:35:56 joko Exp $ +## $Id: Deep.pm,v 1.10 2003/02/20 20:48:00 joko Exp $ ## --------------------------------------------------------------------------- ## $Log: Deep.pm,v $ +## 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 +48,20 @@ 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 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 +77,7 @@ } $vref->{$_} = \@arr; } - var_NumericalHashToArray($vref->{$_}); + numhash2list($vref->{$_}); } # } else { # #$vref->{$_} = scalar2iso($vref->{$_}); @@ -92,7 +90,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; @@ -137,7 +135,9 @@ 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; @@ -153,15 +153,20 @@ #$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; @@ -178,12 +183,17 @@ #$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) @@ -201,7 +211,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 +255,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,7 +272,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}); @@ -276,7 +284,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 +307,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 +325,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 +353,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 +398,101 @@ # 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++; } + +=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.) -# 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); +# 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 $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 $@; - } +# 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_copy2 { + + # if not defined then return it + return undef if $#_ < 0 || !defined( $_[0] ); + + # if not a reference then return the parameter + return $_[0] if !ref( $_[0] ); + my $obj = shift; + if ( UNIVERSAL::isa( $obj, 'SCALAR' ) ) { + my $temp = deep_copy2($$obj); + return \$temp; + } + elsif ( UNIVERSAL::isa( $obj, 'HASH' ) ) { + my $temp_hash = {}; + foreach my $key ( keys %$obj ) { + if ( !defined( $obj->{$key} ) || !ref( $obj->{$key} ) ) { + $temp_hash->{$key} = $obj->{$key}; + } + else { + $temp_hash->{$key} = deep_copy2( $obj->{$key} ); + } + } + return $temp_hash; } - - # 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"; - } + elsif ( UNIVERSAL::isa( $obj, 'ARRAY' ) ) { + my $temp_array = []; + foreach my $array_val (@$obj) { + if ( !defined($array_val) || !ref($array_val) ) { + push ( @$temp_array, $array_val ); + } + else { + push ( @$temp_array, deep_copy2($array_val) ); + } + } + return $temp_array; } - } else { - # use expr as simple scalar key (attributename) - $value = $obj->{$expr}; - } - - return $value; - -} - - -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; + # ?? I am uncertain about this one + elsif ( UNIVERSAL::isa( $obj, 'REF' ) ) { + my $temp = deep_copy2($$obj); + return \$temp; + } - # join parts with dereference operators together again and return built string - return (join('->', @parts_capsule), \@parts_pure); + # I guess that it is either CODE, GLOB or LVALUE + else { + return $obj; + } } -# 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"; } + deep_copy2(@_); } 1; +__END__