Mungle/Transform/Deep.pm

## ---------------------------------------------------------------------------
##  $Id: Deep.pm,v 1.8 2003/02/09 05:10:56 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: Deep.pm,v $
##  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;

use strict;
use warnings;

require Exporter;
our @ISA = qw( Exporter );
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 Iterate;

sub var_NumericalHashToArray {
  my $vref = shift;
  #my $context = shift;
  if (ref $vref eq 'HASH') {
    foreach (keys %{$vref}) {
#      if ((ref $vref->{$_}) =~ m/HASH/) {
          if ((ref $vref->{$_}) =~ m/HASH/) {
            if ($vref->{$_}{0}) {   # might be a numerical-indexed array
              #print "000\n";
              #print "context: $context\n";
              my @arr;
              foreach my $key_numeric (sort keys %{$vref->{$_}}) {
                push @arr, $vref->{$_}{$key_numeric};
              }
              $vref->{$_} = \@arr;
            }
            var_NumericalHashToArray($vref->{$_});
          }
#      } else {
#        #$vref->{$_} = scalar2iso($vref->{$_});
#      }
    }
  }
}


# 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;
  my $result;
  if ((ref $obj) eq 'ARRAY') {
    foreach (@{$obj}) {
      my $ref = ref $_;
      if ($ref) {
        push(@{$result}, var_deref($_, $options));
        #undef $_;
      } else {
        #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->{$_}, $options);
        #undef $obj->{$_};
      } else {
        #$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;
sub var_traverse_mixin_update {
  my $obj = shift;
  my $data = shift;
  my $bool_recursion = shift;
  if (!$bool_recursion) {
    @indexstack = ();
  }
  my $result;

  # 'ARRAY' does not work!
  if ((ref $obj) eq 'ARRAY') {
    #print "ARRAY\n";
    my $i = 0;
    foreach (@{$obj}) {
      push @indexstack, $i;
      my $ref = ref $_;
      if ($ref) {
        #$obj->[$i] = var_mixin($_, $data, 1);
        var_traverse_mixin_update($_, $data, 1);
      } else {
        $obj->[$i] = $_;
      }
      pop @indexstack;
      $i++;
    }
  } else {
    foreach (keys %{$obj}) {
      push @indexstack, $_;
      my $ref = ref $obj->{$_};
      if ($ref) {
        #$obj->{$_} = var_mixin($obj->{$_}, $data, 1);
        var_traverse_mixin_update($obj->{$_}, $data, 1);
      } else {
        #$obj->{$_} = $obj->{$_};
        my $evstring = getSlot($data);
        $obj->{$_} = $evstring;
        
      }
      pop @indexstack;
    }
  }
  #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;
  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 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 $@;
      }
    }
    
    # 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";
      }
    }

  } 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;

  # 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;
1	joko	1.7	## ---------------------------------------------------------------------------
2	joko	1.9	## $Id: Deep.pm,v 1.8 2003/02/09 05:10:56 joko Exp $
3	joko	1.7	## ---------------------------------------------------------------------------
4	joko	1.8	## $Log: Deep.pm,v $
5	joko	1.9	## Revision 1.8 2003/02/09 05:10:56 joko
6			## + minor update
7			##
8	joko	1.8	## Revision 1.7 2003/01/19 03:26:59 joko
9			## + added 'sub deep_copy' - refactored from libp
10			## + add 'sub merge' - exported from CPAN's 'Hash::Merge'
11			##
12	joko	1.7	## Revision 1.6 2002/12/23 11:27:53 jonen
13			## + changed behavior WATCH!
14			##
15			## Revision 1.5 2002/12/16 19:57:54 joko
16			## + option 'init'
17			##
18			## Revision 1.4 2002/12/05 13:56:49 joko
19			## - var_deref
20			## + expand - more sophisticated dereferencing with callbacks using Iterate
21			##
22			## Revision 1.3 2002/12/03 05:34:55 joko
23			## + bugfix: now utilizing var_utf2iso from Data::Transform::Encode
24			##
25			## Revision 1.2 2002/12/01 04:44:07 joko
26			## + code from Data::Transform::OO
27			##
28			## Revision 1.1 2002/11/29 04:49:20 joko
29			## + initial check-in
30			##
31			## Revision 1.1 2002/10/10 03:26:00 cvsjoko
32			## + new
33			## ---------------------------------------------------------------------------
34	joko	1.1
35
36			package Data::Transform::Deep;
37
38			use strict;
39			use warnings;
40
41			require Exporter;
42			our @ISA = qw( Exporter );
43	joko	1.2	our @EXPORT_OK = qw(
44			&var_NumericalHashToArray
45			&var_mixin
46			&object2hash
47			&hash2object
48			&refexpr2perlref
49	joko	1.4	&expand
50	joko	1.7	&deep_copy
51			&merge
52	joko	1.1	);
53	joko	1.4	# &var_deref
54	joko	1.2	# &getStructSlotByStringyAddress
55	joko	1.1
56			use attributes;
57	joko	1.2	use Data::Dumper;
58	joko	1.4	use Data::Transform::Encode qw( var_utf2iso var2utf8 scalar2utf8 );
59	joko	1.7
60			use Hash::Merge qw( merge );
61	joko	1.4	use Iterate;
62	joko	1.1
63			sub var_NumericalHashToArray {
64			my $vref = shift;
65			#my $context = shift;
66			if (ref $vref eq 'HASH') {
67			foreach (keys %{$vref}) {
68			# if ((ref $vref->{$_}) =~ m/HASH/) {
69			if ((ref $vref->{$_}) =~ m/HASH/) {
70			if ($vref->{$_}{0}) { # might be a numerical-indexed array
71			#print "000\n";
72			#print "context: $context\n";
73			my @arr;
74			foreach my $key_numeric (sort keys %{$vref->{$_}}) {
75			push @arr, $vref->{$_}{$key_numeric};
76			}
77			$vref->{$_} = \@arr;
78			}
79			var_NumericalHashToArray($vref->{$_});
80			}
81			# } else {
82			# #$vref->{$_} = scalar2iso($vref->{$_});
83			# }
84			}
85			}
86			}
87
88
89	joko	1.9	# FIXME: could this be refactored using expand?
90			# btw: "expand": look at scripts@CPAN (System Administration):
91			# there is a perl make with perl
92	joko	1.1	sub var_deref {
93			my $obj = shift;
94	joko	1.4	my $options = shift;
95	joko	1.1	my $result;
96			if ((ref $obj) eq 'ARRAY') {
97			foreach (@{$obj}) {
98			my $ref = ref $_;
99			if ($ref) {
100	joko	1.4	push(@{$result}, var_deref($_, $options));
101			#undef $_;
102	joko	1.1	} else {
103	joko	1.4	#push(@{$result}, $_);
104			push(@{$result}, deep_copy($_));
105	joko	1.1	}
106	joko	1.4	#undef $_ if $options->{destroy};
107			#$options->{destroy}->($_) if $options->{destroy};
108	joko	1.1	}
109	joko	1.2	# TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ???
110	joko	1.1	} else {
111			foreach (keys %{$obj}) {
112			my $key = $_;
113			my $ref = ref $obj->{$_};
114			if ($ref) {
115	joko	1.4	$result->{$_} = var_deref($obj->{$_}, $options);
116			#undef $obj->{$_};
117	joko	1.1	} else {
118	joko	1.4	#$result->{$_} = $obj->{$_};
119			$result->{$_} = deep_copy($obj->{$_});
120	joko	1.1	}
121	joko	1.4	#undef $obj->{$_} if $options->{destroy};
122			#$options->{destroy}->($obj->{$_}) if $options->{destroy};
123	joko	1.1	}
124			}
125	joko	1.4	#undef $obj if $options->{destroy};
126			$options->{cb_destroy}->($obj) if $options->{cb_destroy};
127	joko	1.1	return $result;
128			}
129
130
131	joko	1.4	sub expand {
132
133			my $obj = shift;
134			my $options = shift;
135			my $result;
136
137			if ((ref $obj) eq 'ARRAY') {
138
139			IterArray @$obj, sub {
140			my $item;
141			# if current item is a reference ...
142			if (ref $_[0]) {
143			# ... expand structure recursively
144			$item = expand($_[0], $options);
145			# destroy item via seperate callback method (a POST) if requested
146			#$options->{cb}->{destroy}->($_[0]) if $options->{destroy};
147
148			# ... assume plain scalar
149			} else {
150			#$item = deep_copy($_[0]);
151			$item = $_[0];
152			# conversions/encodings
153			$item = scalar2utf8($item) if ($item && $options->{utf8});
154			}
155			#push(@{$result}, $item) if $item; # use item only if not undef (TODO: make configurable via $options)
156			push(@{$result}, $item); # use item in any case
157
158			}
159
160			# TODO: "} elsif (ref $obj eq 'HASH') { [...] } else { croak 'could not deref blah'; }" ???
161			} else {
162
163			IterHash %$obj, sub {
164			my $item;
165
166			# if current item is a reference ...
167			if (ref $_[1]) {
168			# ... expand structure recursively
169			$item = expand($_[1], $options);
170			# destroy item via seperate callback method (a POST) if requested
171			#$options->{cb}->{destroy}->($_[1]) if $options->{destroy};
172
173			# ... assume plain scalar
174			} else {
175			#$item = deep_copy($_[1]);
176			$item = $_[1];
177			# conversions/encodings
178			$item = scalar2utf8($item) if ($item && $options->{utf8});
179			}
180			#$result->{$_[0]} = $item if $item; # use item only if not undef (TODO: make configurable via $options)
181			$result->{$_[0]} = $item; # use item in any case
182			}
183
184			}
185
186			# convert all values to utf8 (inside complex struct)
187			# now done in core-item-callbacks via Greg London's "Iterate" from CPAN
188			# var2utf8($result) if ($options->{utf8});
189
190			# destroy persistent object from memory to be sure to get a fresh one next time
191			#undef $obj if $options->{destroy};
192			#$options->{cb_destroy}->($obj) if $options->{cb_destroy};
193			#$options->{cb}->{destroy}->($obj) if $options->{destroy};
194
195			return $result;
196			}
197
198	joko	1.1
199
200			my @indexstack;
201			sub var_traverse_mixin_update {
202			my $obj = shift;
203			my $data = shift;
204			my $bool_recursion = shift;
205			if (!$bool_recursion) {
206			@indexstack = ();
207			}
208			my $result;
209
210			# 'ARRAY' does not work!
211			if ((ref $obj) eq 'ARRAY') {
212			#print "ARRAY\n";
213			my $i = 0;
214			foreach (@{$obj}) {
215			push @indexstack, $i;
216			my $ref = ref $_;
217			if ($ref) {
218			#$obj->[$i] = var_mixin($_, $data, 1);
219			var_traverse_mixin_update($_, $data, 1);
220			} else {
221			$obj->[$i] = $_;
222			}
223			pop @indexstack;
224			$i++;
225			}
226			} else {
227			foreach (keys %{$obj}) {
228			push @indexstack, $_;
229			my $ref = ref $obj->{$_};
230			if ($ref) {
231			#$obj->{$_} = var_mixin($obj->{$_}, $data, 1);
232			var_traverse_mixin_update($obj->{$_}, $data, 1);
233			} else {
234			#$obj->{$_} = $obj->{$_};
235			my $evstring = getSlot($data);
236			$obj->{$_} = $evstring;
237
238			}
239			pop @indexstack;
240			}
241			}
242			#return $result;
243			}
244
245	joko	1.2	sub object2hash {
246			my $object = shift;
247			my $options = shift;
248	joko	1.4	#my $deref = var_deref($object);
249			my $deref = expand($object, $options);
250			#var2utf8($deref) if ($options->{utf8});
251	joko	1.2	return $deref;
252			}
253
254			# todo: maybe do diff(s) here sometimes!?
255			sub hash2object {
256			my $object = shift;
257			my $data = shift;
258			my $options = shift;
259
260	joko	1.3	#print "hash2object", "\n";
261
262	joko	1.2	# "patch" needed 'cause php passes numerical-indexed-arrays as hash-tables,
263			# this method corrects this
264			var_NumericalHashToArray($data) if ($options->{php});
265
266			# utf8-conversion/-encoding (essential for I18N)
267			var_utf2iso($data) if ($options->{utf8});
268
269			# get fresh object from database
270			# todo:
271			# - handle "locked" objects !!!
272			# - check if already another update occoured (object-revisioning needed!)
273			#my $obj = $self->getObject($oid);
274
275			# mix changes into fresh object and save it back
276	joko	1.5	hash2object_traverse_mixin($object, $data, 0, $options);
277	joko	1.2
278			# done in core mixin function?
279			#$self->{storage}->update($obj);
280
281			# we should "undef" some objects here to destroy them in memory and enforce reloading when used next time
282			# simulate:
283			#$self->{storage}->disconnect();
284
285			}
286
287			# ------------------------------------
288			# core mixin function
289			# TODO-FEATURE: make this possible in a reverse way: object is empty (no fields) and gets filled up by mixin-data
290
291			# remember keys of structures we are traversing
292			# this is a HACK:
293			# - don't (!!!) "packageglobal" @indexstack
294			# - it will lead to problems with parallelism!
295
296			#my @indexstack;
297
298			# traverse a deeply nested structure, mix in values from given hash, update underlying tangram-object
299			sub hash2object_traverse_mixin {
300			my $object = shift;
301			my $data = shift;
302			my $bool_recursion = shift;
303	joko	1.5	my $options = shift;
304	joko	1.2
305			# clear our key - stack if we are called from user-code (non-recursively)
306			@indexstack = () if (!$bool_recursion);
307
308			my $classname = ref $object;
309			# if ($classname) {
310			# print STDERR "*****************", Dumper(Class::Tangram::attribute_types($classname)), "\n";
311			# }
312
313			# parser: detected OBJECT (a Tangram one?) (reftype == HASH) (assume)
314			# what's exactly done here? hmmm.... it works ;)
315			# maybe a HACK: please try not to use "IntrHash"es, maybe this cannot handle them!!!
316			# extend! check!
317			if ((attributes::reftype($object) eq 'HASH') && (ref($object) ne 'HASH') && (ref($object) ne 'ARRAY')) {
318
319			# print STDERR "===", "reftype: ", attributes::reftype($obj), "\n";
320
321	joko	1.5	my @fields;
322	joko	1.2	# loop through fields of object (Tangram-object)
323	joko	1.5	@fields = keys %{$object};
324
325			# loop through fields of to.be.injected-data (arbitrary Perl-data-structure)
326			@fields = keys %{$data} if $options->{init};
327	jonen	1.6	# @fields = keys %{$data} if $options->{mixin};
328	joko	1.5
329			foreach (@fields) {
330	joko	1.7	my $field = $_;
331			push @indexstack, $field;
332	joko	1.2
333			# determine type of object
334	joko	1.7	my $ref = ref $object->{$field};
335	joko	1.2	# print STDERR "attrname: $_ ATTRref: $ref", "\n";
336			if ($ref) {
337	joko	1.7	hash2object_traverse_mixin($object->{$field}, $data, 1, $options);
338	joko	1.2	} else {
339			my $val = getStructSlotByStringyAddress($data, \@indexstack);
340	joko	1.7
341	joko	1.8	#print Dumper($options);
342	joko	1.7	my $field_target = $field;
343			if (my $pattern = $options->{pattern_strip_key}) {
344			print "pattern: $pattern", "\n";
345			$field_target =~ s/$pattern//;
346			print "field: $field_target", "\n";
347			}
348
349			$object->{$field_target} = $val if defined $val;
350	joko	1.2	}
351			pop @indexstack;
352			}
353
354			# save object to database ...
355			# ... do an update if it already exists, do an insert if it doesn't
356			# my $objectId = $self->{storage}->id($obj);
357			# $logger->debug( __PACKAGE__ . "->saveObjectFromHash_traverse_mixin_update( object $obj objectId $objectId )" );
358			# if ($objectId) {
359			# $self->{storage}->update($obj);
360
361			#print __PACKAGE__ . ":", "\n";
362			#print Dumper($object);
363
364			# } else {
365			# $self->{storage}->insert($obj);
366			# }
367
368			}
369
370			#&& ( ref($obj) ne 'HASH' )
371
372			# loop through entries of array (IntrArray, isn't it?)
373			if ((ref $object) eq 'ARRAY') {
374			# print STDERR "===", "refttype ", attributes::reftype($obj), "\n";
375			my $i = 0;
376			foreach (@{$object}) {
377			push @indexstack, $i;
378			my $ref = ref $_;
379			# print STDERR "attrname: $_ ATTRref: $ref", "\n";
380	jonen	1.6	# if ($ref && $_) {
381			if ($ref) {
382	joko	1.5	hash2object_traverse_mixin($_, $data, 1, $options);
383	joko	1.2	} else {
384	jonen	1.6	$object->[$i] = $_ if defined $_;
385	joko	1.2	}
386			pop @indexstack;
387			$i++;
388			}
389			}
390
391			}
392
393
394			# this function seems to do similar stuff like these below (refexpr2perlref & co.)
395	joko	1.5	# TODO: maybe this mechanism can be replaced completely through some nice module from CPAN .... ? ;-)
396	joko	1.1	sub getStructSlotByStringyAddress {
397			my $var = shift;
398			my $indexstack_ref = shift;
399			my @indexstack = @{$indexstack_ref};
400			my $joiner = '->';
401			my @evlist;
402			foreach (@indexstack) {
403			my $elem;
404			if ($_ =~ m/\d+/) { $elem = "[$_]"; }
405			if ($_ =~ m/\D+/) { $elem = "{$_}"; }
406			push @evlist, $elem;
407			}
408			my $evstring = join($joiner, @evlist);
409			$evstring = 'return $var->' . $evstring . ';';
410			#print "ev: $evstring\n";
411			return eval($evstring);
412	joko	1.2	}
413
414
415			sub refexpr2perlref {
416
417			my $obj = shift;
418			my $expr = shift;
419	joko	1.9	my $values = shift;
420			my $delimiter = shift;
421
422			$delimiter \|\|= '->';
423	joko	1.2
424			my $value;
425			# detect for callback (code-reference)
426			if (ref($expr) eq 'CODE') {
427			$value = &$expr($obj);
428
429	joko	1.9	} elsif ($expr =~ m/$delimiter/) {
430	joko	1.2	# use expr as complex object reference declaration (obj->subObj->subSubObj->0->attribute)
431	joko	1.9	(my $objPerlRefString, my $parts) = refexpr2perlref_parts($expr, $delimiter);
432
433			# trace
434			#print "expr: $expr", "\n";
435			#print "objPerlRefString: $objPerlRefString", "\n";
436
437			my $evstr = '$obj' . '->' . $objPerlRefString;
438
439			# trace
440			#print "eval: $evstr", "\n";
441
442			$value = eval($evstr);
443			die ($@) if $@;
444	joko	1.2
445	joko	1.9	# if value isn't set, try to set it
446			my $callbackMap;
447			if ($values) {
448			#if (ref $values eq 'HASH') {
449			if (ref $values eq 'Data::Map') {
450			$callbackMap = $values->getAttributes();
451			} else {
452			# apply $values as single value to referenced slot
453			#print "APPLY!", "\n";
454			eval('$obj' . '->' . $objPerlRefString . ' = $values;');
455			die ($@) if $@;
456			}
457			}
458
459			# determine $values - if it's a hashref, use it as a "valueMap"
460			# "fallback" to callbackMap
461	joko	1.2	# callbacks are applied this way:
462			# take the last element of the expression parts and check if this string exists as a key in the callback-map
463			if (!$value && $callbackMap) {
464			#print Dumper($callbackMap);
465
466			# prepare needle
467			my @parts = @$parts;
468			my $count = $#parts;
469			my $needle = $parts[$count];
470
471			# prepare haystack
472			my @haystack = keys %$callbackMap;
473			if (grep($needle, @haystack)) {
474			$value = $callbackMap->{$needle}->();
475			#print "value: ", $value, "\n";
476			}
477			}
478
479			} else {
480			# use expr as simple scalar key (attributename)
481			$value = $obj->{$expr};
482			}
483
484			return $value;
485
486			}
487
488
489			sub refexpr2perlref_parts {
490			my $expr = shift;
491	joko	1.9	my $delimiter = shift;
492
493			$delimiter = quotemeta($delimiter);
494	joko	1.2
495			# split expression by dereference operators first
496	joko	1.9	my @parts_pure = split(/$delimiter/, $expr);
497	joko	1.2
498			# wrap []'s around each part, if it consists of numeric characters only (=> numeric = array-index),
499			# use {}'s, if there are word-characters in it (=> alphanumeric = hash-key)
500			my @parts_capsule = @parts_pure;
501			map {
502			m/^\d+$/ && ($_ = "[$_]") \|\| ($_ = "{$_}");
503			} @parts_capsule;
504
505			# join parts with dereference operators together again and return built string
506			return (join('->', @parts_capsule), \@parts_pure);
507	joko	1.7	}
508
509			# ACK's go to ...
510			sub deep_copy {
511			my $this = shift;
512			if (not ref $this) {
513			$this;
514			} elsif (ref $this eq "ARRAY") {
515			[map deep_copy($_), @$this];
516			} elsif (ref $this eq "HASH") {
517			+{map { $_ => deep_copy($this->{$_}) } keys %$this};
518			} elsif (ref $this eq "CODE") {
519			$this;
520			#} else { die "deep_copy asks: what type is $this?" }
521			} else { print "deep_copy asks: what type is $this?", "\n"; }
522	joko	1.1	}
523
524			1;
MailToCvsAdmin">MailToCvsAdmin	ViewVC Help
Powered by ViewVC 1.1.26