--- nfo/perl/libs/Data/Mungle/Transform/Deep.pm	2002/11/29 04:49:20	1.1
+++ nfo/perl/libs/Data/Mungle/Transform/Deep.pm	2004/06/07 16:44:54	1.24
@@ -1,35 +1,111 @@
-##############################################
-#
-#  $Id: Deep.pm,v 1.1 2002/11/29 04:49:20 joko Exp $
-#
-#  $Log: Deep.pm,v $
-#  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.24 2004/06/07 16:44:54 joko Exp $
+## ---------------------------------------------------------------------------
+##  $Log: Deep.pm,v $
+##  Revision 1.24  2004/06/07 16:44:54  joko
+##  sub expand: Now also converts hash-keys to/from utf-8
+##
+##  Revision 1.23  2003/05/13 07:39:22  joko
+##  new option 'define' for "sub expand": set value to empty string if desired
+##
+##  Revision 1.22  2003/05/10 17:09:18  jonen
+##  + added keep of empty arrays/hashes if 'expand' for php
+##
+##  Revision 1.21  2003/04/09 07:21:56  joko
+##  childObj2string now inside Encode.pm, renamed to 'twingle_reference'
+##
+##  Revision 1.20  2003/04/04 17:31:23  joko
+##  minor update to 'childObj2string'
+##
+##  Revision 1.19  2003/03/28 03:11:25  jonen
+##  + bugfix
+##
+##  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;
 
 require Exporter;
 our @ISA = qw( Exporter );
-our @EXPORT_OK = qw( 
-  &var_NumericalHashToArray 
-  &var_deref 
-  &var_mixin 
-  &getStructSlotByStringyAddress 
+our @EXPORT_OK = qw(
+  &expand
+  &deep_copy
+  &merge_to
 );
 
+
 use attributes;
+use Data::Dumper;
+use Iterate;
 
+use Pitonyak::DeepCopy;
+use Data::Mungle::Transform::Encode qw( latin_to_utf8 latin_to_utf8_scalar utf8_to_latin utf8_to_latin_scalar twingle_reference );
+use Data::Mungle::Code::Ref qw( ref_slot );
 
-sub var_NumericalHashToArray {
+sub numhash2list {
   my $vref = shift;
   #my $context = shift;
   if (ref $vref eq 'HASH') {
@@ -45,7 +121,7 @@
               }
               $vref->{$_} = \@arr;
             }
-            var_NumericalHashToArray($vref->{$_});
+            numhash2list($vref->{$_});
           }
 #      } else {
 #        #$vref->{$_} = scalar2iso($vref->{$_});
@@ -55,37 +131,168 @@
 }
 
 
-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 {
     foreach (keys %{$obj}) {
       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;
 }
 
 
+# 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
+# TODO: Review: Could this be revamped using Clone.pm?
+sub expand {
+
+  my $obj = shift;
+  my $options = shift;
+  my $result;
+
+  #print "ref: ", ref $obj, "\n";
+
+  if (ref $obj eq 'ARRAY') {
+   
+   # if we expand for php, keep empty ARRAY
+   if($#$obj == -1 && $options->{childObj2string}) {
+     $result = $obj;
+   } else {
+    IterArray @$obj, sub {
+      my $item;
+      # if current item is a reference ...
+      if (ref $_[0]) {
+        $item = $_[0];
+        # if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
+        # instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) 
+        if ($item && $options->{childObj2string}) {
+          $item = twingle_reference($item);
+        } 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};
+
+      # ... 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});
+      }
+      
+      $item = '' if $options->{define} and not defined $item;
+      #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) {
+   
+   # if we expand for php, keep empty HASH
+   my @tmp = keys %$obj;
+   if($#tmp == -1 && $options->{childObj2string}) {
+     $result = $obj;
+   } else {
+    IterHash %$obj, sub {
+      my $key = $_[0];
+      my $item;
+
+      # conversions/encodings
+      $key = latin_to_utf8_scalar($key) if ($key && $options->{utf8});
+      $key = utf8_to_latin_scalar($key) if ($key && $options->{to_latin});
+
+      # if current item is a reference ...
+      if (ref $_[1]) {
+        $item = $_[1];
+        # if $options->{childObj2string} is TRUE or STRING don't expand referenced object,
+        # instead replace it by per option choosed string (default: o_<classname>_<ref type>_<guid> ) 
+        if ($item && $options->{childObj2string} && !(ref $_[1] eq "ARRAY") && !(ref $_[1] eq "HASH") && !(ref $_[1] eq "Set::Object")) {
+          $item = twingle_reference($item);
+        } 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};
+      
+      # ... 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});
+      }
+      
+      $item = '' if $options->{define} and not defined $item;
+      #$result->{$_[0]} = $item if $item;   # use item only if not undef  (TODO: make configurable via $options)
+      $result->{$key} = $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
+    # 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};
+  #$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;
@@ -129,22 +336,196 @@
   #return $result;
 }
 
-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 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 {
+  my $object = shift;
+  my $data = shift;
+  my $options = shift;
+
+  #print "hash2object", "\n";
+  
+  # "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables,
+  # this method corrects this
+  numhash2list($data) if ($options->{php});
+
+  # utf8-conversion/-encoding (essential for I18N)
+  utf8_to_latin($data) if ($options->{utf8});
+
+  # get fresh object from database
+  # todo:
+  #   - handle "locked" objects !!!
+  #   - check if already another update occoured (object-revisioning needed!)
+  #my $obj = $self->getObject($oid);
+
+  # mix changes into fresh object and save it back
+  _hash2object_traverse_mixin($object, $data, 0, $options);
+
+  # done in core mixin function?
+  #$self->{storage}->update($obj);
+
+  # we should "undef" some objects here to destroy them in memory and enforce reloading when used next time
+  # simulate:
+  #$self->{storage}->disconnect();
+
+}
+
+# ------------------------------------
+#   core mixin function
+# TODO-FEATURE: make this possible in a reverse way: object is empty (no fields) and gets filled up by mixin-data
+
+# remember keys of structures we are traversing
+# this is a HACK:
+#  - don't (!!!) "packageglobal" @indexstack
+#  - it will lead to problems with parallelism!
+
+#my @indexstack;
+
+# traverse a deeply nested structure, mix in values from given hash, update underlying tangram-object
+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);
+
+  my $classname = ref $object;
+#  if ($classname) {
+#    print STDERR "*****************", Dumper(Class::Tangram::attribute_types($classname)), "\n";
+#  }
+
+  # parser: detected OBJECT (a Tangram one?)   (reftype == HASH) (assume)
+  # 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!
+  
+  #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)
+    @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->{$field};
+#      print STDERR "attrname: $_  ATTRref: $ref", "\n";
+      if ($ref) {
+        _hash2object_traverse_mixin($object->{$field}, $data, 1, $options);
+      } else {
+        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;
+    }
+
+    # save object to database ...
+    # ... do an update if it already exists, do an insert if it doesn't
+#    my $objectId = $self->{storage}->id($obj);
+#    $logger->debug( __PACKAGE__ . "->saveObjectFromHash_traverse_mixin_update( object $obj objectId $objectId )" );
+#    if ($objectId) {
+#      $self->{storage}->update($obj);
+
+#print __PACKAGE__ . ":", "\n";
+#print Dumper($object);
+
+#    } else {
+#      $self->{storage}->insert($obj);
+#    }
+    
+  }
+
+#&& ( ref($obj) ne 'HASH' ) 
+
+    # loop through entries of array (IntrArray, isn't it?)
+  if ((ref $object) eq 'ARRAY') {
+#    print STDERR "===", "refttype ", attributes::reftype($obj), "\n";
+    my $i = 0;
+    foreach (@{$object}) {
+      push @indexstack, $i;
+      my $ref = ref $_;
+#      print STDERR "attrname: $_  ATTRref: $ref", "\n";
+#      if ($ref && $_) {
+      if ($ref) {
+        _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
+  
+  }
+
+}
+
+
+# ACK's go to Randal L. Schwartz <merlyn@stonehenge.com>
+# 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(@_);
+}
+
+
 1;
+__END__