3 |
# $Id$ |
# $Id$ |
4 |
# |
# |
5 |
# $Log$ |
# $Log$ |
6 |
|
# Revision 1.35 2003/04/19 16:09:48 jonen |
7 |
|
# + added operator dispatching (currently for getting ref-type) at 'getListFiltered' |
8 |
|
# |
9 |
|
# Revision 1.34 2003/04/11 01:18:53 joko |
10 |
|
# sendQuery: |
11 |
|
# + introduced crud action 'DELETE' |
12 |
|
# |
13 |
|
# Revision 1.33 2003/04/09 06:07:43 joko |
14 |
|
# revamped 'sub sendQuery' |
15 |
|
# |
16 |
|
# Revision 1.32 2003/04/08 22:52:22 joko |
17 |
|
# modified 'querySchema': better behaviour regarding filtering result |
18 |
|
# |
19 |
|
# Revision 1.31 2003/04/05 21:24:09 joko |
20 |
|
# modified 'sub getChildNodes': now contains code from 'querySchema' |
21 |
|
# |
22 |
|
# Revision 1.30 2003/03/27 15:31:14 joko |
23 |
|
# fixes to modules regarding new namespace(s) below Data::Mungle::* |
24 |
|
# |
25 |
|
# Revision 1.29 2003/02/21 01:47:18 joko |
26 |
|
# purged old code |
27 |
|
# minor cosmetics |
28 |
|
# |
29 |
# Revision 1.28 2003/02/20 20:20:26 joko |
# Revision 1.28 2003/02/20 20:20:26 joko |
30 |
# tried to get auto-disconnect working again - failed with that |
# tried to get auto-disconnect working again - failed with that |
31 |
# |
# |
146 |
|
|
147 |
use DesignPattern::Object; |
use DesignPattern::Object; |
148 |
use Data::Storage::Result::Tangram; |
use Data::Storage::Result::Tangram; |
149 |
use Data::Compare::Struct qw( isEmpty ); |
use Data::Mungle::Compare::Struct qw( isEmpty ); |
150 |
use Data::Transform::Deep qw( expand ); |
use Data::Mungle::Transform::Deep qw( expand deep_copy merge_to ); |
|
#use Data::Transform::Encode qw( var2utf8 ); |
|
151 |
|
|
152 |
# get logger instance |
# get logger instance |
153 |
my $logger = Log::Dispatch::Config->instance; |
my $logger = Log::Dispatch::Config->instance; |
247 |
sub getChildNodes { |
sub getChildNodes { |
248 |
|
|
249 |
my $self = shift; |
my $self = shift; |
250 |
my @nodes; |
my $mode = shift; |
251 |
|
my $filter = shift; |
252 |
|
|
253 |
|
$mode ||= 'core'; |
254 |
|
$filter ||= 'all'; |
255 |
|
|
256 |
|
$logger->debug( __PACKAGE__ . "->getChildNodes($mode)" ); |
257 |
|
|
258 |
$logger->debug( __PACKAGE__ . "->getChildNodes()" ); |
if ($mode eq 'core') { |
259 |
|
|
260 |
# create new DBI - Data::Storage - object from already connected DBI::db - handle inside the current COREHANDLE |
my @nodes; |
261 |
#my $loc = new Data::Storage::Locator( type => "DBI", dbi => { db => $self->{COREHANDLE}->{db} }); |
|
262 |
#my $loc = new Data::Storage::Locator( type => "DBI", COREHANDLE => $self->{COREHANDLE}->{db} ); |
# create new DBI - Data::Storage - object from already connected DBI::db - handle inside the current COREHANDLE |
263 |
|
#my $loc = new Data::Storage::Locator( type => "DBI", dbi => { db => $self->{COREHANDLE}->{db} }); |
264 |
# todo: should we retrieve information from the schema here |
#my $loc = new Data::Storage::Locator( type => "DBI", COREHANDLE => $self->{COREHANDLE}->{db} ); |
265 |
# rather than poorly getting table names from underlying dbi? |
|
266 |
my $storage = $self->_getSubLayerHandle(); |
# todo: should we retrieve information from the schema here |
267 |
@nodes = @{$storage->getChildNodes()}; |
# rather than poorly getting table names from underlying dbi? |
268 |
#$storage->_configureCOREHANDLE(); |
my $storage = $self->_getSubLayerHandle(); |
269 |
#print "getchildnodes\n"; |
@nodes = @{$storage->getChildNodes()}; |
270 |
#print Dumper($self); |
#$storage->_configureCOREHANDLE(); |
271 |
#if (my $result = $self->sendCommand( 'SHOW TABLES;' ) ) { |
#print "getchildnodes\n"; |
272 |
|
#print Dumper($self); |
273 |
|
#if (my $result = $self->sendCommand( 'SHOW TABLES;' ) ) { |
274 |
|
|
275 |
|
# TODO: REVIEW |
276 |
|
#$storage->disconnect(); |
277 |
|
|
278 |
|
$self->{meta}->{childnodes} = \@nodes; |
279 |
|
|
280 |
|
return \@nodes; |
281 |
|
|
282 |
# TODO: REVIEW |
} elsif ($mode eq 'root') { |
283 |
#$storage->disconnect(); |
|
284 |
|
# FIXME: this will return *all* known classes to 'Class::Tangram', |
285 |
|
# which might not be what you expect since more than one instance |
286 |
|
# of Tangram may be in memory and Class::Tangram seems to |
287 |
|
# offer no methods to determine this or filter its result(s) according |
288 |
|
# to a specific database. |
289 |
|
my @object_names = Class::Tangram::known_classes(); |
290 |
|
my @concret_names; |
291 |
|
my $o_cnt; |
292 |
|
foreach (sort @object_names) { |
293 |
|
push @concret_names, $_ if (!Class::Tangram::class_is_abstract($_)); |
294 |
|
$o_cnt++; |
295 |
|
} |
296 |
|
|
297 |
|
if ($filter eq 'all') { |
298 |
|
return \@object_names; |
299 |
|
} elsif ($filter eq 'concrete') { |
300 |
|
return \@concret_names; |
301 |
|
} |
302 |
|
|
303 |
$self->{meta}->{childnodes} = \@nodes; |
} |
304 |
|
|
|
return \@nodes; |
|
305 |
|
|
306 |
} |
} |
307 |
|
|
|
|
|
308 |
sub testIntegrity { |
sub testIntegrity { |
309 |
|
|
310 |
my $self = shift; |
my $self = shift; |
509 |
# objects => $objects, |
# objects => $objects, |
510 |
# ); |
# ); |
511 |
|
|
512 |
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
# TODO: is_op? |
513 |
push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'"; |
# dispatch un-common operators if exists |
514 |
|
if($filter->{op} eq "ref") { |
515 |
|
push @tfilters, 'ref($remote->{' . $filter->{key} . '})' . " eq '$filter->{val}'"; |
516 |
|
} else { |
517 |
|
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
518 |
|
push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'"; |
519 |
|
} |
520 |
|
|
521 |
} |
} |
522 |
|
|
569 |
sub sendQuery { |
sub sendQuery { |
570 |
my $self = shift; |
my $self = shift; |
571 |
my $query = shift; |
my $query = shift; |
|
#my $sql = "SELECT cs FROM $self->{metainfo}->{$descent}->{node} WHERE $self->{metainfo}->{$descent}->{IdentProvider}->{arg}='$self->{entry}->{source}->{ident}';"; |
|
|
#my $result = $self->{metainfo}->{$descent}->{storage}->sendCommand($sql); |
|
572 |
|
|
573 |
#print Dumper($query); |
#print Dumper($query); |
574 |
|
|
575 |
# HACK: special case: querying by id does not translate into a common tangram query |
# type = ITEM|LIST|TRANSPARENT |
576 |
# just load the object by given id(ent) |
my $type = ''; |
577 |
if ($query->{criterias}->[0]->{key} eq 'id' && $query->{criterias}->[0]->{op} eq 'eq') { |
# mode = OID|SPECIAL |
578 |
#print "LOAD!!!", "\n"; |
my $mode = ''; |
579 |
#exit; |
my $ident = ''; |
580 |
#return Set::Object->new( $self->{COREHANDLE}->load($query->{criterias}->[0]->{val}) ); |
my $crud = ''; |
581 |
my $ident = $query->{criterias}->[0]->{val}; |
|
582 |
#print "load obj", "\n"; |
|
583 |
#return $self->createSet() if $ident == 5; |
# dispatch type and mode |
584 |
$self->{_COREHANDLE}->unload($ident); |
|
585 |
my $object = $self->{_COREHANDLE}->load($ident); |
# defaults - 1 |
586 |
#print "get id", "\n"; |
if ($query->{options}) { |
587 |
my $oid = $self->{_COREHANDLE}->id($object); |
$crud = $query->{options}->{crud}; |
588 |
#print Dumper($object); |
$crud ||= $query->{options}->{action}; |
589 |
#print "oid: $oid", "\n"; |
} |
590 |
return $self->createSet($object); |
|
591 |
#return $self->createSet( $self->{COREHANDLE}->load('300090018') ); |
# defaults - 2 |
592 |
} |
$type ||= 'TRANSPARENT'; |
593 |
|
$crud ||= 'RETRIEVE'; |
594 |
my $list = $self->getListFiltered($query->{node}, $query->{criterias}); |
|
595 |
#return $self->createSet($object); |
if ($query->{options}->{OID}) { |
596 |
#return $self->createSet($list); |
$type = 'ITEM'; |
597 |
return $self->createSet(@$list); |
$mode = 'OID'; |
598 |
|
$ident = $query->{options}->{OID}; |
599 |
#die("This should not be reached for now - redirect to \$self->getListFiltered() here!"); |
|
600 |
|
} elsif (my $guid = $query->{options}->{GUID}) { |
601 |
|
$type = 'TRANSPARENT'; |
602 |
|
$query->{criterias} = [ { key => 'guid', op => 'eq', val => $guid } ]; |
603 |
|
|
604 |
|
# if operator is different (dispatcher for 'getListFiltered') |
605 |
|
} elsif (my $op = $query->{options}->{op}) { |
606 |
|
$type = 'TRANSPARENT'; |
607 |
|
$query->{criterias} = [ { key => $query->{options}->{meta_label}, op => $op, val => $query->{options}->{meta_value} } ]; |
608 |
|
|
609 |
|
} |
610 |
|
|
611 |
|
# HACK: special case: querying by id does not translate into a common tangram query |
612 |
|
# just load the object by given identifier (OID) named 'id' - this is required by Data::Transfer::Sync! |
613 |
|
if ($query->{criterias} && ($query->{criterias}->[0]->{key} eq 'id' && $query->{criterias}->[0]->{op} eq 'eq')) { |
614 |
|
$type = 'ITEM'; |
615 |
|
$mode = 'SPECIAL.SYNC'; |
616 |
|
$ident = $query->{criterias}->[0]->{val}; |
617 |
|
} |
618 |
|
|
619 |
|
|
620 |
|
# execute query |
621 |
|
my $result; |
622 |
|
|
623 |
|
if ($type eq 'ITEM' && $ident) { |
624 |
|
|
625 |
|
if ($mode eq 'OID') { |
626 |
|
# TODO: review this case! |
627 |
|
$result = $self->getObject($ident, $query->{options}); |
628 |
|
|
629 |
|
} elsif ($mode eq 'SPECIAL.SYNC') { |
630 |
|
|
631 |
|
# V1 - failed |
632 |
|
#return Set::Object->new( $self->{COREHANDLE}->load($query->{criterias}->[0]->{val}) ); |
633 |
|
|
634 |
|
# hmm.... |
635 |
|
#return $self->createSet() if $ident == 5; |
636 |
|
|
637 |
|
# Unload single object before doing any further operations to |
638 |
|
# expect a "fresh" object from orm when performing the next calls. |
639 |
|
$self->{_COREHANDLE}->unload($ident); |
640 |
|
|
641 |
|
# Load object from orm. |
642 |
|
my $object = $self->{_COREHANDLE}->load($ident); |
643 |
|
|
644 |
|
# determine object identifier (OID) |
645 |
|
my $oid = $self->{_COREHANDLE}->id($object); |
646 |
|
|
647 |
|
# encapsulate into result/response container and return this one |
648 |
|
$result = $self->createSet($object); |
649 |
|
|
650 |
|
# debugging |
651 |
|
#$result = $self->createSet( $self->{COREHANDLE}->load('300090018') ); |
652 |
|
|
653 |
|
} |
654 |
|
|
655 |
|
|
656 |
|
} elsif ($type eq 'TRANSPARENT') { |
657 |
|
|
658 |
|
if ($crud eq 'RETRIEVE') { |
659 |
|
|
660 |
|
my $list = $self->getListFiltered($query->{node}, $query->{criterias}); |
661 |
|
#return $self->createSet($object); |
662 |
|
#return $self->createSet($list); |
663 |
|
return $self->createSet(@$list); |
664 |
|
|
665 |
|
#die("This should not be reached for now - redirect to \$self->getListFiltered() here!"); |
666 |
|
|
667 |
|
# try a generic tangram query here |
668 |
|
# TODO: try to place an oql on top of that (search.cpan.org!) |
669 |
|
my @crits; |
670 |
|
foreach (@{$query->{criterias}}) { |
671 |
|
my $op = ''; |
672 |
|
$op = '=' if lc $_->{op} eq 'eq'; |
673 |
|
push @crits, "$_->{key}$op'$_->{val}'"; |
674 |
|
} |
675 |
|
my $subnodes = {}; |
676 |
|
map { $subnodes->{$_}++ } @{$query->{subnodes}}; |
677 |
|
# HACK: this is hardcoded ;( expand possibilities! |
678 |
|
#my $crit = join(' AND ', @crits); |
679 |
|
#my $sql = hash2Sql($query->{node}, $subnodes, 'SELECT', $crit); |
680 |
|
#return $self->sendCommand($sql); |
681 |
|
#my $h = $self->{COREHANDLE}->remote($query->{node}); |
682 |
|
#my $res = $self->{COREHANDLE}->select($h, $h->{); |
683 |
|
$result = $self->createCursor($query->{node}); |
684 |
|
|
685 |
|
} elsif ($crud eq 'UPDATE') { |
686 |
|
|
687 |
|
# Patch current query to be a loader (e.g. change action, remove payload) ... |
688 |
|
my $childquery = deep_copy($query); |
689 |
|
$childquery->{options}->{crud} = 'RETRIEVE'; |
690 |
|
delete $childquery->{payload}; |
691 |
|
|
692 |
|
# ... to use it to fetch a fresh object using ourselves (sendQuery). |
693 |
|
my $cursor = $self->sendQuery($childquery); |
694 |
|
my $status = $cursor->getStatus(); |
695 |
|
my $object = $cursor->getNextEntry(); |
696 |
|
|
697 |
|
# Merge values and apply value modifiers. |
698 |
|
my $options = { utf8 => 1, php => 1 }; |
699 |
|
merge_to($object, $query->{payload}, $options); |
700 |
|
|
701 |
|
# Execute update operation at orm. |
702 |
|
$self->update($object); |
703 |
|
|
704 |
|
} elsif ($crud eq 'DELETE') { |
705 |
|
|
706 |
|
# Patch current query to be a loader (e.g. change action) ... |
707 |
|
my $childquery = deep_copy($query); |
708 |
|
$childquery->{options}->{crud} = 'RETRIEVE'; |
709 |
|
|
710 |
|
# ... to use it to fetch a fresh object using ourselves (sendQuery). |
711 |
|
my $cursor = $self->sendQuery($childquery); |
712 |
|
my $status = $cursor->getStatus(); |
713 |
|
my $object = $cursor->getNextEntry(); |
714 |
|
|
715 |
|
$self->erase($object); |
716 |
|
|
717 |
|
} |
718 |
|
|
719 |
|
} |
720 |
|
|
721 |
|
return $result; |
722 |
|
|
|
# try a generic tangram query here |
|
|
# TODO: try to place an oql on top of that (search.cpan.org!) |
|
|
my @crits; |
|
|
foreach (@{$query->{criterias}}) { |
|
|
my $op = ''; |
|
|
$op = '=' if lc $_->{op} eq 'eq'; |
|
|
push @crits, "$_->{key}$op'$_->{val}'"; |
|
|
} |
|
|
my $subnodes = {}; |
|
|
map { $subnodes->{$_}++ } @{$query->{subnodes}}; |
|
|
# HACK: this is hardcoded ;( expand possibilities! |
|
|
#my $crit = join(' AND ', @crits); |
|
|
#my $sql = hash2Sql($query->{node}, $subnodes, 'SELECT', $crit); |
|
|
#return $self->sendCommand($sql); |
|
|
#my $h = $self->{COREHANDLE}->remote($query->{node}); |
|
|
#my $res = $self->{COREHANDLE}->select($h, $h->{); |
|
|
return $self->createCursor($query->{node}); |
|
723 |
} |
} |
724 |
|
|
725 |
sub eraseAll { |
sub eraseAll { |
755 |
return $object if $object; |
return $object if $object; |
756 |
} |
} |
757 |
|
|
758 |
sub getObjectByGuid { |
sub getObjectByGuid_old { |
759 |
my $self = shift; |
my $self = shift; |
760 |
my $guid = shift; |
my $guid = shift; |
761 |
my $options = shift; |
my $options = shift; |
785 |
|
|
786 |
} |
} |
787 |
|
|
788 |
sub getObjectAsHash { |
sub getObjectAsHash_old { |
789 |
my $self = shift; |
my $self = shift; |
790 |
my $oid = shift; |
my $oid = shift; |
791 |
my $options = shift; |
my $options = shift; |
800 |
# build options (a callback to unload autovivified objects) for 'expand' |
# build options (a callback to unload autovivified objects) for 'expand' |
801 |
# TODO: use $logger to write to debug here! |
# TODO: use $logger to write to debug here! |
802 |
my $cb; # = sub {}; |
my $cb; # = sub {}; |
803 |
|
|
804 |
|
# deactivated way to get rid of used instances, if requested |
805 |
=pod |
=pod |
806 |
if ($options->{destroy}) { |
if ($options->{destroy}) { |
807 |
$options->{cb}->{destroy} = sub { |
$options->{cb}->{destroy} = sub { |
808 |
print "================ DESTROY", "\n"; |
print "================ DESTROY", "\n"; |
809 |
my $object = shift; |
my $object = shift; |
810 |
#print Dumper($object); |
#print Dumper($object); |
811 |
$self->{_COREHANDLE}->unload($object); |
$self->{_COREHANDLE}->unload($object); |
812 |
#undef($object); |
#undef($object); |
813 |
}; |
}; |
814 |
} |
} |
815 |
=cut |
=cut |
816 |
|
|
817 |
my $hash = expand($obj, $options); |
my $hash = expand($obj, $options); |
818 |
#$options->{cb}->{destroy}->($obj); |
|
819 |
#$self->{_COREHANDLE}->unload($obj); |
# old (unsuccessful) attempts to get rid of used instances, if requested |
820 |
|
|
821 |
# convert values in hash to utf8 to be ready for (e.g.) encapsulation in XML |
# V1: |
822 |
# now done in expand |
#$options->{cb}->{destroy}->($obj); |
823 |
#var2utf8($hash) if ($options->{utf8}); |
#$self->{_COREHANDLE}->unload($obj); |
824 |
|
|
825 |
# old (wrong) attempts to get rid of used instances, if requested |
# V2: |
826 |
#$obj->clear_refs; |
#$obj->clear_refs; |
827 |
#$self->{COREHANDLE}->unload($obj) if($options->{destroy}); |
#$self->{COREHANDLE}->unload($obj) if($options->{destroy}); |
828 |
#$obj->DESTROY; |
#$obj->DESTROY; |