3 |
# $Id$ |
# $Id$ |
4 |
# |
# |
5 |
# $Log$ |
# $Log$ |
6 |
|
# Revision 1.5 2002/12/16 19:57:54 joko |
7 |
|
# + option 'init' |
8 |
|
# |
9 |
# Revision 1.4 2002/12/05 13:56:49 joko |
# Revision 1.4 2002/12/05 13:56:49 joko |
10 |
# - var_deref |
# - var_deref |
11 |
# + expand - more sophisticated dereferencing with callbacks using Iterate |
# + expand - more sophisticated dereferencing with callbacks using Iterate |
259 |
#my $obj = $self->getObject($oid); |
#my $obj = $self->getObject($oid); |
260 |
|
|
261 |
# mix changes into fresh object and save it back |
# mix changes into fresh object and save it back |
262 |
hash2object_traverse_mixin($object, $data); |
hash2object_traverse_mixin($object, $data, 0, $options); |
263 |
|
|
264 |
# done in core mixin function? |
# done in core mixin function? |
265 |
#$self->{storage}->update($obj); |
#$self->{storage}->update($obj); |
286 |
my $object = shift; |
my $object = shift; |
287 |
my $data = shift; |
my $data = shift; |
288 |
my $bool_recursion = shift; |
my $bool_recursion = shift; |
289 |
|
my $options = shift; |
290 |
|
|
291 |
# clear our key - stack if we are called from user-code (non-recursively) |
# clear our key - stack if we are called from user-code (non-recursively) |
292 |
@indexstack = () if (!$bool_recursion); |
@indexstack = () if (!$bool_recursion); |
304 |
|
|
305 |
# print STDERR "===", "reftype: ", attributes::reftype($obj), "\n"; |
# print STDERR "===", "reftype: ", attributes::reftype($obj), "\n"; |
306 |
|
|
307 |
|
my @fields; |
308 |
# loop through fields of object (Tangram-object) |
# loop through fields of object (Tangram-object) |
309 |
foreach (keys %{$object}) { |
@fields = keys %{$object}; |
310 |
|
|
311 |
|
# loop through fields of to.be.injected-data (arbitrary Perl-data-structure) |
312 |
|
@fields = keys %{$data} if $options->{init}; |
313 |
|
|
314 |
|
foreach (@fields) { |
315 |
push @indexstack, $_; |
push @indexstack, $_; |
316 |
|
|
317 |
# determine type of object |
# determine type of object |
318 |
my $ref = ref $object->{$_}; |
my $ref = ref $object->{$_}; |
319 |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
320 |
if ($ref) { |
if ($ref) { |
321 |
hash2object_traverse_mixin($object->{$_}, $data, 1); |
hash2object_traverse_mixin($object->{$_}, $data, 1, $options); |
322 |
} else { |
} else { |
323 |
my $val = getStructSlotByStringyAddress($data, \@indexstack); |
my $val = getStructSlotByStringyAddress($data, \@indexstack); |
324 |
$object->{$_} = $val; |
$object->{$_} = $val; |
353 |
my $ref = ref $_; |
my $ref = ref $_; |
354 |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
355 |
if ($ref && $_) { |
if ($ref && $_) { |
356 |
hash2object_traverse_mixin($_, $data, 1); |
hash2object_traverse_mixin($_, $data, 1, $options); |
357 |
} else { |
} else { |
358 |
$object->[$i] = $_; |
$object->[$i] = $_; |
359 |
} |
} |
366 |
|
|
367 |
|
|
368 |
# this function seems to do similar stuff like these below (refexpr2perlref & co.) |
# this function seems to do similar stuff like these below (refexpr2perlref & co.) |
369 |
|
# TODO: maybe this mechanism can be replaced completely through some nice module from CPAN .... ? ;-) |
370 |
sub getStructSlotByStringyAddress { |
sub getStructSlotByStringyAddress { |
371 |
my $var = shift; |
my $var = shift; |
372 |
my $indexstack_ref = shift; |
my $indexstack_ref = shift; |