3 |
# $Id$ |
# $Id$ |
4 |
# |
# |
5 |
# $Log$ |
# $Log$ |
6 |
|
# Revision 1.6 2002/12/23 11:27:53 jonen |
7 |
|
# + changed behavior WATCH! |
8 |
|
# |
9 |
|
# Revision 1.5 2002/12/16 19:57:54 joko |
10 |
|
# + option 'init' |
11 |
|
# |
12 |
# Revision 1.4 2002/12/05 13:56:49 joko |
# Revision 1.4 2002/12/05 13:56:49 joko |
13 |
# - var_deref |
# - var_deref |
14 |
# + expand - more sophisticated dereferencing with callbacks using Iterate |
# + expand - more sophisticated dereferencing with callbacks using Iterate |
262 |
#my $obj = $self->getObject($oid); |
#my $obj = $self->getObject($oid); |
263 |
|
|
264 |
# mix changes into fresh object and save it back |
# mix changes into fresh object and save it back |
265 |
hash2object_traverse_mixin($object, $data); |
hash2object_traverse_mixin($object, $data, 0, $options); |
266 |
|
|
267 |
# done in core mixin function? |
# done in core mixin function? |
268 |
#$self->{storage}->update($obj); |
#$self->{storage}->update($obj); |
289 |
my $object = shift; |
my $object = shift; |
290 |
my $data = shift; |
my $data = shift; |
291 |
my $bool_recursion = shift; |
my $bool_recursion = shift; |
292 |
|
my $options = shift; |
293 |
|
|
294 |
# 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) |
295 |
@indexstack = () if (!$bool_recursion); |
@indexstack = () if (!$bool_recursion); |
307 |
|
|
308 |
# print STDERR "===", "reftype: ", attributes::reftype($obj), "\n"; |
# print STDERR "===", "reftype: ", attributes::reftype($obj), "\n"; |
309 |
|
|
310 |
|
my @fields; |
311 |
# loop through fields of object (Tangram-object) |
# loop through fields of object (Tangram-object) |
312 |
foreach (keys %{$object}) { |
@fields = keys %{$object}; |
313 |
|
|
314 |
|
# loop through fields of to.be.injected-data (arbitrary Perl-data-structure) |
315 |
|
@fields = keys %{$data} if $options->{init}; |
316 |
|
# @fields = keys %{$data} if $options->{mixin}; |
317 |
|
|
318 |
|
foreach (@fields) { |
319 |
push @indexstack, $_; |
push @indexstack, $_; |
320 |
|
|
321 |
# determine type of object |
# determine type of object |
322 |
my $ref = ref $object->{$_}; |
my $ref = ref $object->{$_}; |
323 |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
324 |
if ($ref) { |
if ($ref) { |
325 |
hash2object_traverse_mixin($object->{$_}, $data, 1); |
hash2object_traverse_mixin($object->{$_}, $data, 1, $options); |
326 |
} else { |
} else { |
327 |
my $val = getStructSlotByStringyAddress($data, \@indexstack); |
my $val = getStructSlotByStringyAddress($data, \@indexstack); |
328 |
$object->{$_} = $val; |
$object->{$_} = $val if defined $val; |
329 |
} |
} |
330 |
pop @indexstack; |
pop @indexstack; |
331 |
} |
} |
356 |
push @indexstack, $i; |
push @indexstack, $i; |
357 |
my $ref = ref $_; |
my $ref = ref $_; |
358 |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
# print STDERR "attrname: $_ ATTRref: $ref", "\n"; |
359 |
if ($ref && $_) { |
# if ($ref && $_) { |
360 |
hash2object_traverse_mixin($_, $data, 1); |
if ($ref) { |
361 |
|
hash2object_traverse_mixin($_, $data, 1, $options); |
362 |
} else { |
} else { |
363 |
$object->[$i] = $_; |
$object->[$i] = $_ if defined $_; |
364 |
} |
} |
365 |
pop @indexstack; |
pop @indexstack; |
366 |
$i++; |
$i++; |
371 |
|
|
372 |
|
|
373 |
# this function seems to do similar stuff like these below (refexpr2perlref & co.) |
# this function seems to do similar stuff like these below (refexpr2perlref & co.) |
374 |
|
# TODO: maybe this mechanism can be replaced completely through some nice module from CPAN .... ? ;-) |
375 |
sub getStructSlotByStringyAddress { |
sub getStructSlotByStringyAddress { |
376 |
my $var = shift; |
my $var = shift; |
377 |
my $indexstack_ref = shift; |
my $indexstack_ref = shift; |