6 |
## |
## |
7 |
## ---------------------------------------------------------------------------------------- |
## ---------------------------------------------------------------------------------------- |
8 |
## $Log$ |
## $Log$ |
9 |
|
## Revision 1.9 2003/04/09 07:53:34 joko |
10 |
|
## minor namespace update |
11 |
|
## |
12 |
|
## Revision 1.8 2003/04/09 07:27:02 joko |
13 |
|
## minor update (just cosmetics) |
14 |
|
## |
15 |
|
## Revision 1.7 2003/03/27 15:31:16 joko |
16 |
|
## fixes to modules regarding new namespace(s) below Data::Mungle::* |
17 |
|
## |
18 |
|
## Revision 1.6 2003/02/21 01:47:53 joko |
19 |
|
## renamed core function |
20 |
|
## |
21 |
|
## Revision 1.5 2003/02/20 20:24:33 joko |
22 |
|
## + additional pre-flight checks |
23 |
|
## |
24 |
|
## Revision 1.4 2003/02/14 14:14:38 joko |
25 |
|
## + new code refactored here |
26 |
|
## |
27 |
## Revision 1.3 2003/02/11 07:54:55 joko |
## Revision 1.3 2003/02/11 07:54:55 joko |
28 |
## + modified module usage |
## + modified module usage |
29 |
## + debugging trials |
## + debugging trials |
54 |
|
|
55 |
use Data::Dumper; |
use Data::Dumper; |
56 |
use Hash::Merge qw( merge ); |
use Hash::Merge qw( merge ); |
57 |
use libdb qw( hash2Sql ); |
use shortcuts::database qw( hash2sql ); |
58 |
use Data::Transform::Deep qw( hash2object ); |
use Data::Mungle::Transform::Deep qw( merge_to ); |
59 |
|
|
60 |
|
|
61 |
# get logger instance |
# get logger instance |
145 |
my $ident = shift; |
my $ident = shift; |
146 |
my $force = shift; |
my $force = shift; |
147 |
|
|
148 |
|
=pod |
149 |
|
#print "isa: ", UNIVERSAL::isa($self->{meta}->{$descent}->{storage}), "\n"; |
150 |
|
|
151 |
|
# this seems to be the first time we access this side, |
152 |
|
# so just check (again) for a valid storage handle |
153 |
|
if (! ref $self->{meta}->{$descent}->{storage}) { |
154 |
|
$logger->critical( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident ): Storage handle undefined!" ); |
155 |
|
return; |
156 |
|
} |
157 |
|
=cut |
158 |
|
|
159 |
#$logger->debug( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident )" ); |
#$logger->debug( __PACKAGE__ . "->_statloadNode( descent=$descent ident=$ident )" ); |
160 |
|
|
161 |
# fetch entry to retrieve checksum from |
# fetch entry to retrieve checksum from |
186 |
] |
] |
187 |
}; |
}; |
188 |
|
|
|
# trace |
|
|
#print "query:", "\n"; |
|
|
#print Dumper($query); |
|
|
|
|
189 |
# send query and fetch first entry from result |
# send query and fetch first entry from result |
190 |
my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query); |
my $result = $self->{meta}->{$descent}->{storage}->sendQuery($query); |
191 |
my $entry = $result->getNextEntry(); |
my $entry = $result->getNextEntry(); |
259 |
next; |
next; |
260 |
} |
} |
261 |
|
|
262 |
|
# 2.b check storage handle type |
263 |
|
my $dbType = $self->{meta}->{$descent}->{storage}->{locator}->{type}; |
264 |
|
if (!$dbType) { |
265 |
|
$logger->critical( __PACKAGE__ . "->touchNodeSet: Storage ( descent='$descent', dbKey='$dbkey' ) has no 'dbType' - configuration-error?" ); |
266 |
|
next; |
267 |
|
} |
268 |
|
|
269 |
# 3. check if descents (and nodes?) are actually available.... |
# 3. check if descents (and nodes?) are actually available.... |
270 |
# TODO: |
# TODO: |
271 |
# eventually pre-check mode of access-attempt (read/write) here to provide an "early-croak" if possible |
# eventually pre-check mode of access-attempt (read/write) here to provide an "early-croak" if possible |
274 |
# print Dumper($self->{meta}->{$descent}->{storage}->{locator}); |
# print Dumper($self->{meta}->{$descent}->{storage}->{locator}); |
275 |
|
|
276 |
|
|
|
my $dbType = $self->{meta}->{$descent}->{storage}->{locator}->{type}; |
|
277 |
my $nodeName = $self->{meta}->{$descent}->{nodeName}; |
my $nodeName = $self->{meta}->{$descent}->{nodeName}; |
278 |
my $accessorType = $self->{meta}->{$descent}->{accessorType}; |
my $accessorType = $self->{meta}->{$descent}->{accessorType}; |
279 |
my $accessorName = $self->{meta}->{$descent}->{accessorName}; |
my $accessorName = $self->{meta}->{$descent}->{accessorName}; |
358 |
# TODO: wrap this around '$storageHandle->sendQuery(...)'!? |
# TODO: wrap this around '$storageHandle->sendQuery(...)'!? |
359 |
my $sql_main; |
my $sql_main; |
360 |
if (lc($action) eq 'insert') { |
if (lc($action) eq 'insert') { |
361 |
$sql_main = hash2Sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_INSERT'); |
$sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_INSERT'); |
362 |
} elsif (lc $action eq 'update') { |
} elsif (lc $action eq 'update') { |
363 |
$crit ||= "$self->{meta}->{$descent}->{IdentProvider}->{arg}='$self->{node}->{$descent}->{ident}'"; |
$crit ||= "$self->{meta}->{$descent}->{IdentProvider}->{arg}='$self->{node}->{$descent}->{ident}'"; |
364 |
$sql_main = hash2Sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_UPDATE', $crit); |
$sql_main = hash2sql($self->{meta}->{$descent}->{accessorName}, $map, 'SQL_UPDATE', $crit); |
365 |
} |
} |
366 |
my $sqlHandle = $self->{meta}->{$descent}->{storage}->sendCommand($sql_main); |
my $sqlHandle = $self->{meta}->{$descent}->{storage}->sendCommand($sql_main); |
367 |
|
|
479 |
# mix in (merge) values ... |
# mix in (merge) values ... |
480 |
# TODO: use Hash::Merge here? benchmark! |
# TODO: use Hash::Merge here? benchmark! |
481 |
# no! we'd need a Object::Merge here! it's *...2object* |
# no! we'd need a Object::Merge here! it's *...2object* |
482 |
hash2object($object, $map); |
merge_to($object, $map); |
483 |
|
|
484 |
# trace |
# trace |
485 |
#print Dumper($object); |
#print Dumper($object); |
503 |
|
|
504 |
} elsif (lc $action eq 'update') { |
} elsif (lc $action eq 'update') { |
505 |
|
|
506 |
# get fresh object from orm first |
# Get fresh object from orm first. |
507 |
|
# TODO: Review, is a 'sendQuery' required in this place? |
508 |
|
# By now: NO! It's more expensive and we can just expect existing objects for update operations. |
509 |
|
# If it doesn't exist either, we assume the engine will fail on issuing the 'update' operation later... |
510 |
$object = $self->{meta}->{$descent}->{storage}->load($self->{node}->{$descent}->{ident}); |
$object = $self->{meta}->{$descent}->{storage}->load($self->{node}->{$descent}->{ident}); |
511 |
|
|
|
#print Dumper($self->{node}); |
|
|
|
|
512 |
# mix in values |
# mix in values |
513 |
#print Dumper($object); |
merge_to($object, $map); |
|
# TODO: use Hash::Merge here??? |
|
|
hash2object($object, $map); |
|
|
#print Dumper($object); |
|
|
#exit; |
|
514 |
|
|
515 |
# update orm |
# update orm |
516 |
$self->{meta}->{$descent}->{storage}->update($object); |
$self->{meta}->{$descent}->{storage}->update($object); |
517 |
|
|
518 |
} |
} |
519 |
|
|
|
#exit; |
|
|
|
|
520 |
my $error = 0; |
my $error = 0; |
521 |
|
|
522 |
# handle new style callbacks - this is a HACK - do this without an eval! |
# handle new style callbacks - this is a HACK - do this without an eval! |
525 |
#print Dumper($map_callbacks); |
#print Dumper($map_callbacks); |
526 |
foreach my $node (keys %{$map_callbacks->{write}}) { |
foreach my $node (keys %{$map_callbacks->{write}}) { |
527 |
#print Dumper($node); |
#print Dumper($node); |
528 |
my $perl_callback = $self->{meta}->{$descent}->{node} . '::' . $node . '_write'; |
|
529 |
|
# ------------ half-redundant: make $self->callCallback($object, $value, $opts) |
530 |
|
my $perl_callback = $self->{meta}->{$descent}->{nodeType} . '::' . $node . '_write'; |
531 |
my $evalstring = $perl_callback . '( { object => $object, value => $map_callbacks->{write}->{$node}, storage => $self->{meta}->{$descent}->{storage} } );'; |
my $evalstring = $perl_callback . '( { object => $object, value => $map_callbacks->{write}->{$node}, storage => $self->{meta}->{$descent}->{storage} } );'; |
532 |
#print $evalstring, "\n"; exit; |
#print $evalstring, "\n"; exit; |
533 |
eval($evalstring); |
eval($evalstring); |
534 |
if ($@) { |
if ($@) { |
535 |
$error = 1; |
$error = 1; |
536 |
print $@, "\n"; |
$logger->error( __PACKAGE__ . "->_modifyNode: $@" ); |
537 |
|
next; |
538 |
} |
} |
539 |
|
# ------------ half-redundant: make $self->callCallback($object, $value, $opts) |
540 |
|
|
541 |
#print "after eval", "\n"; |
#print "after eval", "\n"; |
542 |
|
|
571 |
|
|
572 |
} |
} |
573 |
|
|
574 |
|
sub _erase_all { |
575 |
|
my $self = shift; |
576 |
|
my $descent = shift; |
577 |
|
#my $node = shift; |
578 |
|
#print Dumper($self->{meta}->{$descent}); |
579 |
|
#my $node = $self->{meta}->{$descent}->{nodeName}; |
580 |
|
my $node = $self->{meta}->{$descent}->{accessorName}; |
581 |
|
$logger->debug( __PACKAGE__ . "->_erase_all( node $node )" ); |
582 |
|
$self->{meta}->{$descent}->{storage}->eraseAll($node); |
583 |
|
} |
584 |
|
|
585 |
1; |
1; |
586 |
|
__END__ |