--- nfo/perl/libs/Data/Mungle/Transform/Deep.pm	2002/11/29 04:49:20	1.1
+++ nfo/perl/libs/Data/Mungle/Transform/Deep.pm	2003/01/19 03:26:59	1.7
@@ -1,15 +1,33 @@
-##############################################
-#
-#  $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.7 2003/01/19 03:26:59 joko Exp $
+## ---------------------------------------------------------------------------
+##  $Log: Deep.pm,v $
+##  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;
@@ -19,15 +37,26 @@
 
 require Exporter;
 our @ISA = qw( Exporter );
-our @EXPORT_OK = qw( 
-  &var_NumericalHashToArray 
-  &var_deref 
-  &var_mixin 
-  &getStructSlotByStringyAddress 
+our @EXPORT_OK = qw(
+  &var_NumericalHashToArray
+  &var_mixin
+  &object2hash
+  &hash2object
+  &refexpr2perlref
+  &expand
+  &deep_copy
+  &merge
 );
+#  &var_deref
+#  &getStructSlotByStringyAddress
 
 use attributes;
+use Data::Dumper;
+use Data::Transform::Encode qw( var_utf2iso var2utf8 scalar2utf8 );
 
+use Hash::Merge qw( merge );
+#use libp qw( deep_copy );
+use Iterate;
 
 sub var_NumericalHashToArray {
   my $vref = shift;
@@ -57,31 +86,110 @@
 
 sub var_deref {
   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;
 }
 
 
+sub expand {
+
+  my $obj = shift;
+  my $options = shift;
+  my $result;
+
+  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 = scalar2utf8($item) if ($item && $options->{utf8});
+      }
+      #push(@{$result}, $item) if $item;   # use item only if not undef  (TODO: make configurable via $options)
+      push(@{$result}, $item);                 # use item in any case
+
+    }
+
+  # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
+  } else {
+
+    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 = scalar2utf8($item) if ($item && $options->{utf8});
+      }
+      #$result->{$_[0]} = $item if $item;   # use item only if not undef  (TODO: make configurable via $options)
+      $result->{$_[0]} = $item;               # use item in any case
+    }
+
+  }
+
+  # 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;
@@ -129,6 +237,157 @@
   #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;
+}
+
+# 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
+  var_NumericalHashToArray($data) if ($options->{php});
+
+  # utf8-conversion/-encoding (essential for I18N)
+  var_utf2iso($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!
+  if ((attributes::reftype($object) eq 'HASH') && (ref($object) ne 'HASH') && (ref($object) ne 'ARRAY')) {
+
+#    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 = getStructSlotByStringyAddress($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++;
+    }
+  }
+
+}
+
+
+# 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;
@@ -147,4 +406,84 @@
   return eval($evstring);
 }
 
+
+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;
+  
+}
+
+
+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);
+}
+
+# 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;