3 |
# $Id$ |
# $Id$ |
4 |
# |
# |
5 |
# $Log$ |
# $Log$ |
6 |
|
# Revision 1.37 2003/05/10 17:37:39 jonen |
7 |
|
# corrected last commit |
8 |
|
# |
9 |
|
# Revision 1.36 2003/05/10 17:31:18 jonen |
10 |
|
# + added new functions related to 'create' item |
11 |
|
# - createNode() |
12 |
|
# # creates non-persistent 'deep dummy filled' object |
13 |
|
# - insertChildNode() |
14 |
|
# # inserts child node at given parent (child node haven't to exists, |
15 |
|
# createNode will be injected transparently) |
16 |
|
# |
17 |
|
# Revision 1.35 2003/04/19 16:09:48 jonen |
18 |
|
# + added operator dispatching (currently for getting ref-type) at 'getListFiltered' |
19 |
|
# |
20 |
|
# Revision 1.34 2003/04/11 01:18:53 joko |
21 |
|
# sendQuery: |
22 |
|
# + introduced crud action 'DELETE' |
23 |
|
# |
24 |
|
# Revision 1.33 2003/04/09 06:07:43 joko |
25 |
|
# revamped 'sub sendQuery' |
26 |
|
# |
27 |
# Revision 1.32 2003/04/08 22:52:22 joko |
# Revision 1.32 2003/04/08 22:52:22 joko |
28 |
# modified 'querySchema': better behaviour regarding filtering result |
# modified 'querySchema': better behaviour regarding filtering result |
29 |
# |
# |
158 |
use DesignPattern::Object; |
use DesignPattern::Object; |
159 |
use Data::Storage::Result::Tangram; |
use Data::Storage::Result::Tangram; |
160 |
use Data::Mungle::Compare::Struct qw( isEmpty ); |
use Data::Mungle::Compare::Struct qw( isEmpty ); |
161 |
use Data::Mungle::Transform::Deep qw( expand ); |
use Data::Mungle::Transform::Deep qw( expand deep_copy merge_to ); |
162 |
|
|
163 |
# get logger instance |
# get logger instance |
164 |
my $logger = Log::Dispatch::Config->instance; |
my $logger = Log::Dispatch::Config->instance; |
520 |
# objects => $objects, |
# objects => $objects, |
521 |
# ); |
# ); |
522 |
|
|
523 |
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
# TODO: is_op? |
524 |
push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'"; |
# dispatch un-common operators if exists |
525 |
|
if($filter->{op} eq "ref") { |
526 |
|
push @tfilters, 'ref($remote->{' . $filter->{key} . '})' . " eq '$filter->{val}'"; |
527 |
|
} else { |
528 |
|
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
529 |
|
push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'"; |
530 |
|
} |
531 |
|
|
532 |
} |
} |
533 |
|
|
580 |
sub sendQuery { |
sub sendQuery { |
581 |
my $self = shift; |
my $self = shift; |
582 |
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); |
|
583 |
|
|
584 |
#print Dumper($query); |
#print Dumper($query); |
585 |
|
|
586 |
# HACK: special case: querying by id does not translate into a common tangram query |
# type = ITEM|LIST|TRANSPARENT |
587 |
# just load the object by given id(ent) |
my $type = ''; |
588 |
if ($query->{criterias} && ($query->{criterias}->[0]->{key} eq 'id' && $query->{criterias}->[0]->{op} eq 'eq')) { |
# mode = OID|SPECIAL |
589 |
#print "LOAD!!!", "\n"; |
my $mode = ''; |
590 |
#exit; |
my $ident = ''; |
591 |
#return Set::Object->new( $self->{COREHANDLE}->load($query->{criterias}->[0]->{val}) ); |
my $crud = ''; |
592 |
my $ident = $query->{criterias}->[0]->{val}; |
|
593 |
#print "load obj", "\n"; |
|
594 |
#return $self->createSet() if $ident == 5; |
# dispatch type and mode |
595 |
$self->{_COREHANDLE}->unload($ident); |
|
596 |
my $object = $self->{_COREHANDLE}->load($ident); |
# defaults - 1 |
597 |
#print "get id", "\n"; |
if ($query->{options}) { |
598 |
my $oid = $self->{_COREHANDLE}->id($object); |
$crud = $query->{options}->{crud}; |
599 |
#print Dumper($object); |
$crud ||= $query->{options}->{action}; |
600 |
#print "oid: $oid", "\n"; |
} |
601 |
return $self->createSet($object); |
|
602 |
#return $self->createSet( $self->{COREHANDLE}->load('300090018') ); |
# defaults - 2 |
603 |
} |
$type ||= 'TRANSPARENT'; |
604 |
|
$crud ||= 'RETRIEVE'; |
605 |
my $list = $self->getListFiltered($query->{node}, $query->{criterias}); |
|
606 |
#return $self->createSet($object); |
if ($query->{options}->{OID}) { |
607 |
#return $self->createSet($list); |
$type = 'ITEM'; |
608 |
return $self->createSet(@$list); |
$mode = 'OID'; |
609 |
|
$ident = $query->{options}->{OID}; |
610 |
#die("This should not be reached for now - redirect to \$self->getListFiltered() here!"); |
|
611 |
|
} elsif (my $guid = $query->{options}->{GUID}) { |
612 |
|
$type = 'TRANSPARENT'; |
613 |
|
$query->{criterias} = [ { key => 'guid', op => 'eq', val => $guid } ]; |
614 |
|
|
615 |
|
# if operator is different (dispatcher for 'getListFiltered') |
616 |
|
} elsif (my $op = $query->{options}->{op}) { |
617 |
|
$type = 'TRANSPARENT'; |
618 |
|
$query->{criterias} = [ { key => $query->{options}->{meta_label}, op => $op, val => $query->{options}->{meta_value} } ]; |
619 |
|
|
620 |
|
} |
621 |
|
|
622 |
|
# HACK: special case: querying by id does not translate into a common tangram query |
623 |
|
# just load the object by given identifier (OID) named 'id' - this is required by Data::Transfer::Sync! |
624 |
|
if ($query->{criterias} && ($query->{criterias}->[0]->{key} eq 'id' && $query->{criterias}->[0]->{op} eq 'eq')) { |
625 |
|
$type = 'ITEM'; |
626 |
|
$mode = 'SPECIAL.SYNC'; |
627 |
|
$ident = $query->{criterias}->[0]->{val}; |
628 |
|
} |
629 |
|
|
630 |
|
|
631 |
|
# execute query |
632 |
|
my $result; |
633 |
|
|
634 |
|
if ($type eq 'ITEM' && $ident) { |
635 |
|
|
636 |
|
if ($mode eq 'OID') { |
637 |
|
# TODO: review this case! |
638 |
|
$result = $self->getObject($ident, $query->{options}); |
639 |
|
|
640 |
|
} elsif ($mode eq 'SPECIAL.SYNC') { |
641 |
|
|
642 |
|
# V1 - failed |
643 |
|
#return Set::Object->new( $self->{COREHANDLE}->load($query->{criterias}->[0]->{val}) ); |
644 |
|
|
645 |
|
# hmm.... |
646 |
|
#return $self->createSet() if $ident == 5; |
647 |
|
|
648 |
|
# Unload single object before doing any further operations to |
649 |
|
# expect a "fresh" object from orm when performing the next calls. |
650 |
|
$self->{_COREHANDLE}->unload($ident); |
651 |
|
|
652 |
|
# Load object from orm. |
653 |
|
my $object = $self->{_COREHANDLE}->load($ident); |
654 |
|
|
655 |
|
# determine object identifier (OID) |
656 |
|
my $oid = $self->{_COREHANDLE}->id($object); |
657 |
|
|
658 |
|
# encapsulate into result/response container and return this one |
659 |
|
$result = $self->createSet($object); |
660 |
|
|
661 |
|
# debugging |
662 |
|
#$result = $self->createSet( $self->{COREHANDLE}->load('300090018') ); |
663 |
|
|
664 |
|
} |
665 |
|
|
666 |
|
|
667 |
|
} elsif ($type eq 'TRANSPARENT') { |
668 |
|
|
669 |
|
if ($crud eq 'RETRIEVE') { |
670 |
|
|
671 |
|
my $list = $self->getListFiltered($query->{node}, $query->{criterias}); |
672 |
|
#return $self->createSet($object); |
673 |
|
#return $self->createSet($list); |
674 |
|
return $self->createSet(@$list); |
675 |
|
|
676 |
|
#die("This should not be reached for now - redirect to \$self->getListFiltered() here!"); |
677 |
|
|
678 |
|
# try a generic tangram query here |
679 |
|
# TODO: try to place an oql on top of that (search.cpan.org!) |
680 |
|
my @crits; |
681 |
|
foreach (@{$query->{criterias}}) { |
682 |
|
my $op = ''; |
683 |
|
$op = '=' if lc $_->{op} eq 'eq'; |
684 |
|
push @crits, "$_->{key}$op'$_->{val}'"; |
685 |
|
} |
686 |
|
my $subnodes = {}; |
687 |
|
map { $subnodes->{$_}++ } @{$query->{subnodes}}; |
688 |
|
# HACK: this is hardcoded ;( expand possibilities! |
689 |
|
#my $crit = join(' AND ', @crits); |
690 |
|
#my $sql = hash2Sql($query->{node}, $subnodes, 'SELECT', $crit); |
691 |
|
#return $self->sendCommand($sql); |
692 |
|
#my $h = $self->{COREHANDLE}->remote($query->{node}); |
693 |
|
#my $res = $self->{COREHANDLE}->select($h, $h->{); |
694 |
|
$result = $self->createCursor($query->{node}); |
695 |
|
|
696 |
|
} elsif ($crud eq 'UPDATE') { |
697 |
|
|
698 |
|
# Patch current query to be a loader (e.g. change action, remove payload) ... |
699 |
|
my $childquery = deep_copy($query); |
700 |
|
$childquery->{options}->{crud} = 'RETRIEVE'; |
701 |
|
delete $childquery->{payload}; |
702 |
|
|
703 |
|
# ... to use it to fetch a fresh object using ourselves (sendQuery). |
704 |
|
my $cursor = $self->sendQuery($childquery); |
705 |
|
my $status = $cursor->getStatus(); |
706 |
|
my $object = $cursor->getNextEntry(); |
707 |
|
|
708 |
|
# Merge values and apply value modifiers. |
709 |
|
my $options = { utf8 => 1, php => 1 }; |
710 |
|
merge_to($object, $query->{payload}, $options); |
711 |
|
|
712 |
|
# Execute update operation at orm. |
713 |
|
$self->update($object); |
714 |
|
|
715 |
|
} elsif ($crud eq 'DELETE') { |
716 |
|
|
717 |
|
# Patch current query to be a loader (e.g. change action) ... |
718 |
|
my $childquery = deep_copy($query); |
719 |
|
$childquery->{options}->{crud} = 'RETRIEVE'; |
720 |
|
|
721 |
|
# ... to use it to fetch a fresh object using ourselves (sendQuery). |
722 |
|
my $cursor = $self->sendQuery($childquery); |
723 |
|
my $status = $cursor->getStatus(); |
724 |
|
my $object = $cursor->getNextEntry(); |
725 |
|
|
726 |
|
$self->erase($object); |
727 |
|
|
728 |
|
} elsif ($crud eq 'CREATE') { |
729 |
|
|
730 |
|
my $nodename = $query->{node}; |
731 |
|
my $newnode = $self->createNode($nodename); |
732 |
|
my $id = $self->{_COREHANDLE}->insert($newnode); |
733 |
|
|
734 |
|
print "Saved new node $nodename with GUID $newnode->{guid}, OID '$id': " . Dumper($newnode) . "\n"; |
735 |
|
|
736 |
|
return $newnode; |
737 |
|
|
738 |
|
} |
739 |
|
|
740 |
|
} |
741 |
|
|
742 |
|
return $result; |
743 |
|
|
|
# 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}); |
|
744 |
} |
} |
745 |
|
|
746 |
sub eraseAll { |
sub eraseAll { |
776 |
return $object if $object; |
return $object if $object; |
777 |
} |
} |
778 |
|
|
779 |
sub getObjectByGuid { |
sub getObjectByGuid_old { |
780 |
my $self = shift; |
my $self = shift; |
781 |
my $guid = shift; |
my $guid = shift; |
782 |
my $options = shift; |
my $options = shift; |
806 |
|
|
807 |
} |
} |
808 |
|
|
809 |
sub getObjectAsHash { |
sub getObjectAsHash_old { |
810 |
my $self = shift; |
my $self = shift; |
811 |
my $oid = shift; |
my $oid = shift; |
812 |
my $options = shift; |
my $options = shift; |
889 |
$self->{dataStorageLayer}->disconnect(); |
$self->{dataStorageLayer}->disconnect(); |
890 |
} |
} |
891 |
|
|
892 |
|
|
893 |
|
sub createNode { |
894 |
|
my $self = shift; |
895 |
|
my $classname = shift; |
896 |
|
|
897 |
|
my $obj = $classname->new(); |
898 |
|
|
899 |
|
my $attr_options = Class::Tangram::attribute_options($classname); |
900 |
|
#print "Attribute Options: " . Dumper($attr_options); |
901 |
|
|
902 |
|
my $attr_types = Class::Tangram::attribute_types($classname); |
903 |
|
#print "Attribute Types: " . Dumper($attr_types); |
904 |
|
|
905 |
|
foreach(keys %{$attr_types}) { |
906 |
|
if($attr_types->{$_} eq 'string') { |
907 |
|
$obj->{$_} = ''; |
908 |
|
} elsif($attr_types->{$_} eq 'int') { |
909 |
|
$obj->{$_} = 0; |
910 |
|
} elsif($attr_types->{$_} eq 'real') { |
911 |
|
$obj->{$_} = 0; |
912 |
|
} elsif($attr_types->{$_} eq 'rawdatetime') { |
913 |
|
$obj->{$_} = '0000-00-00 00:00:00'; |
914 |
|
} elsif($attr_types->{$_} eq 'ref') { |
915 |
|
if($attr_options->{$_}->{class}) { |
916 |
|
$obj->{$_} = $self->createNode($attr_options->{$_}->{class}); |
917 |
|
} else { |
918 |
|
#$obj->{$_} = undef(); |
919 |
|
} |
920 |
|
} elsif($attr_types->{$_} eq 'iarray') { |
921 |
|
$obj->{$_} = [ ]; |
922 |
|
} elsif($attr_types->{$_} eq 'hash') { |
923 |
|
$obj->{$_} = { }; |
924 |
|
} elsif($attr_types->{$_} eq 'flat_hash') { |
925 |
|
$obj->{$_} = { }; |
926 |
|
} |
927 |
|
} |
928 |
|
|
929 |
|
#print "New Object: " . Dumper($obj); |
930 |
|
|
931 |
|
return $obj; |
932 |
|
} |
933 |
|
|
934 |
|
|
935 |
|
sub insertChildNode { |
936 |
|
my $self = shift; |
937 |
|
my $child_entry = shift; |
938 |
|
my $query_args = shift; |
939 |
|
|
940 |
|
my $core = $self->{_COREHANDLE}; |
941 |
|
my $nodename = $query_args->{nodename}; |
942 |
|
|
943 |
|
# get parent object |
944 |
|
my $query = { |
945 |
|
node => $query_args->{parent}->{nodename}, |
946 |
|
options => { GUID => $query_args->{parent}->{guid}, }, |
947 |
|
}; |
948 |
|
my $cursor = $self->sendQuery($query); |
949 |
|
my $parent = $cursor->getNextEntry(); |
950 |
|
|
951 |
|
# debug |
952 |
|
#print "Parent_org: " . Dumper($parent); |
953 |
|
|
954 |
|
# Create child node object if isn't already done |
955 |
|
# ($child_entry have to be the class name then...) |
956 |
|
if(!ref($child_entry)) { |
957 |
|
$child_entry = $self->createNode($child_entry); |
958 |
|
# it could be insert 'manually' or will be insert 'transparent' if parent will be updated |
959 |
|
#$core->insert($child_entry); |
960 |
|
#print "Create child object [$nodename]: " . Dumper($child_entry); |
961 |
|
} |
962 |
|
|
963 |
|
# get reference of tied node |
964 |
|
my $tied_node = tied $parent->{$nodename}; |
965 |
|
|
966 |
|
# insert/change child entry at parent |
967 |
|
#print "reference: " . ref($parent->{$nodename}) . "\n"; |
968 |
|
if(ref($parent->{$nodename}) eq 'ARRAY') { |
969 |
|
# all tangram types are tied as 'SCALAR' with special 'FETCH', 'STORE' methods per type, |
970 |
|
# so a 'PUSH' is not implemented (which could be then done transparently) |
971 |
|
my $array = $tied_node->FETCH; |
972 |
|
push @$array, $child_entry; |
973 |
|
$tied_node->STORE($array); |
974 |
|
# node will be normaly untied at 'STORE' |
975 |
|
if(tied $parent->{$nodename}) { print "already tied !!\n"; } |
976 |
|
else { undef $tied_node; } |
977 |
|
} |
978 |
|
elsif(ref($parent->{$nodename}) eq 'HASH') { |
979 |
|
if(my $key = $query_args->{hash_key}) { |
980 |
|
# same problem as with 'ARRAY': |
981 |
|
# all tangram types are tied as 'SCALAR' with special 'FETCH', 'STORE' methods per type. |
982 |
|
my $hash = $tied_node->FETCH; |
983 |
|
$hash->{$key} = $child_entry; |
984 |
|
$tied_node->STORE($hash); |
985 |
|
# node will be normaly untied at 'STORE' |
986 |
|
if(tied $parent->{$nodename}) { print "already tied !!\n"; } |
987 |
|
else { undef $tied_node; } |
988 |
|
} else { |
989 |
|
print "ERROR: No HASH KEY given, so not able to insert hash entry!"; |
990 |
|
} |
991 |
|
} |
992 |
|
else { |
993 |
|
$parent->{$nodename} = $child_entry; |
994 |
|
} |
995 |
|
|
996 |
|
# debug |
997 |
|
#print "Parent_new: " . Dumper($parent); |
998 |
|
|
999 |
|
# save parent |
1000 |
|
$core->update($parent); |
1001 |
|
|
1002 |
|
# debug |
1003 |
|
#print "Saved Parent: ". Dumper($parent); |
1004 |
|
|
1005 |
|
return $child_entry; |
1006 |
|
} |
1007 |
|
|
1008 |
|
|
1009 |
1; |
1; |
1010 |
__END__ |
__END__ |