Mungle/Transform/Deep.pm

## ---------------------------------------------------------------------------
##  $Id: Object.pm,v 1.2 2002/12/27 16:05:42 joko Exp $
## ---------------------------------------------------------------------------
##  $Log: Object.pm,v $
##  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 libp qw( deep_copy );
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->{$_});
#      }
    }
  }
}


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