--- nfo/perl/libs/Data/Mungle/Transform/Deep.pm	2002/11/29 04:49:20	1.1
+++ nfo/perl/libs/Data/Mungle/Transform/Deep.pm	2002/12/01 04:44:07	1.2
@@ -1,8 +1,11 @@
 ##############################################
 #
-#  $Id: Deep.pm,v 1.1 2002/11/29 04:49:20 joko Exp $
+#  $Id: Deep.pm,v 1.2 2002/12/01 04:44:07 joko Exp $
 #
 #  $Log: Deep.pm,v $
+#  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
 #
@@ -19,14 +22,18 @@
 
 require Exporter;
 our @ISA = qw( Exporter );
-our @EXPORT_OK = qw( 
-  &var_NumericalHashToArray 
-  &var_deref 
-  &var_mixin 
-  &getStructSlotByStringyAddress 
+our @EXPORT_OK = qw(
+  &var_NumericalHashToArray
+  &var_deref
+  &var_mixin
+  &object2hash
+  &hash2object
+  &refexpr2perlref
 );
+#  &getStructSlotByStringyAddress
 
 use attributes;
+use Data::Dumper;
 
 
 sub var_NumericalHashToArray {
@@ -67,6 +74,7 @@
         push(@{$result}, $_);
       }
     }
+  # TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }"  ???
   } else {
     foreach (keys %{$obj}) {
       my $key = $_;
@@ -129,6 +137,134 @@
   #return $result;
 }
 
+sub object2hash {
+  my $object = shift;
+  my $options = shift;
+  my $deref = var_deref($object);
+  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;
+
+  # "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);
+
+  # 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;
+
+  # 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";
+        
+    # loop through fields of object (Tangram-object)
+    foreach (keys %{$object}) {
+      push @indexstack, $_;
+            
+      # determine type of object
+      my $ref = ref $object->{$_};
+#      print STDERR "attrname: $_  ATTRref: $ref", "\n";
+      if ($ref) {
+        hash2object_traverse_mixin($object->{$_}, $data, 1);
+      } else {
+        my $val = getStructSlotByStringyAddress($data, \@indexstack);
+        $object->{$_} = $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 && $_) {
+        hash2object_traverse_mixin($_, $data, 1);
+      } else {
+        $object->[$i] = $_;
+      }
+      pop @indexstack;
+      $i++;
+    }
+  }
+
+}
+
+
+# this function seems to do similar stuff like these below (refexpr2perlref & co.)
 sub getStructSlotByStringyAddress {
   my $var = shift;
   my $indexstack_ref = shift;
@@ -147,4 +283,69 @@
   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);
+}
+
 1;