3 |
# $Id$ |
# $Id$ |
4 |
# |
# |
5 |
# $Log$ |
# $Log$ |
6 |
|
# Revision 1.49 2004/11/03 14:12:34 jonen |
7 |
|
# replaced print with logger->info |
8 |
|
# |
9 |
|
# Revision 1.48 2004/10/28 11:35:51 jonen |
10 |
|
# + bugfix related to select-criterias(filter) |
11 |
|
# |
12 |
|
# Revision 1.47 2004/08/31 14:26:08 jonen |
13 |
|
# updated |
14 |
|
# |
15 |
|
# Revision 1.46 2004/05/06 12:54:34 jonen |
16 |
|
# + bugfix related to multiple select-'filter' |
17 |
|
# |
18 |
|
# Revision 1.45 2003/12/14 01:48:36 jonen |
19 |
|
# small HACK at _insertChildNode: some special Childnodes should not be created because existing objects have to be selected! |
20 |
|
# TODO: make this more generic, e.g. implement a special flag at Schema |
21 |
|
# |
22 |
|
# Revision 1.44 2003/12/04 01:01:50 joko |
23 |
|
# + sendQuery now returns result even on crud=UPDATE |
24 |
|
# |
25 |
|
# Revision 1.43 2003/07/02 11:07:12 jonen |
26 |
|
# re-activate filtering of results *after* results are fetched from tangram |
27 |
|
# (needed for e.g. UserManagment) |
28 |
|
# |
29 |
|
# Revision 1.42 2003/07/01 23:24:17 joko |
30 |
|
# now using package before using function |
31 |
|
# |
32 |
|
# Revision 1.41 2003/06/29 02:03:45 joko |
33 |
|
# fix:? initialize schema on startup |
34 |
|
# |
35 |
|
# Revision 1.40 2003/06/25 22:57:54 joko |
36 |
|
# major rework of "sub sendQuery / sub getListFiltered": now should be capable of "sorting" |
37 |
|
# |
38 |
|
# Revision 1.39 2003/06/06 11:40:40 jonen |
39 |
|
# fixed bug at 'getFilteredList' |
40 |
|
# |
41 |
|
# Revision 1.38 2003/05/13 16:38:38 joko |
42 |
|
# problems with "tied" on 5.6.1/win32 |
43 |
|
# |
44 |
|
# Revision 1.37 2003/05/10 17:37:39 jonen |
45 |
|
# corrected last commit |
46 |
|
# |
47 |
|
# Revision 1.36 2003/05/10 17:31:18 jonen |
48 |
|
# + added new functions related to 'create' item |
49 |
|
# - createNode() |
50 |
|
# # creates non-persistent 'deep dummy filled' object |
51 |
|
# - insertChildNode() |
52 |
|
# # inserts child node at given parent (child node haven't to exists, |
53 |
|
# createNode will be injected transparently) |
54 |
|
# |
55 |
|
# Revision 1.35 2003/04/19 16:09:48 jonen |
56 |
|
# + added operator dispatching (currently for getting ref-type) at 'getListFiltered' |
57 |
|
# |
58 |
|
# Revision 1.34 2003/04/11 01:18:53 joko |
59 |
|
# sendQuery: |
60 |
|
# + introduced crud action 'DELETE' |
61 |
|
# |
62 |
# Revision 1.33 2003/04/09 06:07:43 joko |
# Revision 1.33 2003/04/09 06:07:43 joko |
63 |
# revamped 'sub sendQuery' |
# revamped 'sub sendQuery' |
64 |
# |
# |
192 |
|
|
193 |
use Data::Dumper; |
use Data::Dumper; |
194 |
use Tangram; |
use Tangram; |
195 |
|
use Class::Tangram; |
196 |
|
|
197 |
use DesignPattern::Object; |
use DesignPattern::Object; |
198 |
use Data::Storage::Result::Tangram; |
use Data::Storage::Result::Tangram; |
202 |
# get logger instance |
# get logger instance |
203 |
my $logger = Log::Dispatch::Config->instance; |
my $logger = Log::Dispatch::Config->instance; |
204 |
|
|
205 |
|
#$Tangram::TRACE = *STDOUT; |
206 |
|
|
207 |
# this holds the complete instantiated schema from tangram |
# this holds the complete instantiated schema from tangram |
208 |
my $schema_tangram; |
my $schema_tangram; |
221 |
#if (!$schema_tangram) { |
#if (!$schema_tangram) { |
222 |
#my $obj = getNewPerlObjectByPkgName($self->{locator}->{schema}, { EXPORT_OBJECTS => $self->{locator}->{classnames}, want_transactions => $self->{locator}->{want_transactions} } ); |
#my $obj = getNewPerlObjectByPkgName($self->{locator}->{schema}, { EXPORT_OBJECTS => $self->{locator}->{classnames}, want_transactions => $self->{locator}->{want_transactions} } ); |
223 |
my $obj = DesignPattern::Object->fromPackage($self->{locator}->{schema}, { 'EXPORT_OBJECTS' => $self->{locator}->{classnames}, 'want_transactions' => $self->{locator}->{want_transactions} } ); |
my $obj = DesignPattern::Object->fromPackage($self->{locator}->{schema}, { 'EXPORT_OBJECTS' => $self->{locator}->{classnames}, 'want_transactions' => $self->{locator}->{want_transactions} } ); |
224 |
$schema_tangram = $obj->getSchema(); |
$schema_tangram = $obj->getSchema() if $obj; |
225 |
#} |
#} |
226 |
if (!$schema_tangram) { |
if (!$schema_tangram) { |
227 |
$logger->error( __PACKAGE__ . "->_initSchema: No Schema available for $self->{schema}" ); |
$logger->error( __PACKAGE__ . "->_initSchema: No Schema available for $self->{locator}->{schema}." ); |
228 |
return 0; |
return 0; |
229 |
} |
} |
230 |
#$self->_patchSchema(); |
#$self->_patchSchema(); |
270 |
# return; |
# return; |
271 |
# } |
# } |
272 |
|
|
273 |
#return unless $self->_initSchema(); |
return unless $self->_initSchema(); |
274 |
$self->_initSchema(); |
#$self->_initSchema(); |
275 |
|
|
276 |
# create the main tangram storage object |
# create the main tangram storage object |
277 |
#$self->{COREHANDLE} = Tangram::Relational->connect( $schema, $dsn ); |
#$self->{COREHANDLE} = Tangram::Relational->connect( $schema, $dsn ); |
533 |
# redirect to unfiltered mode |
# redirect to unfiltered mode |
534 |
#return $self->getListUnfiltered(@_); |
#return $self->getListUnfiltered(@_); |
535 |
|
|
536 |
my $nodename = shift; |
my $in = {}; |
537 |
my $filters = shift; |
$in->{nodename} = shift; |
538 |
|
$in->{filters} = shift; |
539 |
|
$in->{sorting} = shift; |
540 |
|
|
541 |
my @results; |
my @results; |
542 |
$logger->debug( __PACKAGE__ . "->getListFiltered( nodename => '" . $nodename . "' )" ); |
$logger->debug( __PACKAGE__ . "->getListFiltered( nodename => '" . $in->{nodename} . "' )" ); |
543 |
|
|
544 |
#print Dumper($filters); |
#print "Filter_payload: " . Dumper($in->{filters}) . "\n"; |
545 |
|
|
546 |
|
# 1. "Remote Object Handle" - get set of objects from odbms by object name |
547 |
|
my $remote = $self->{_COREHANDLE}->remote($in->{nodename}); |
548 |
|
|
549 |
|
# 2. Transfer $in to $orm_query |
550 |
|
my $orm_query = {}; |
551 |
|
|
552 |
|
# 2.a. Filters |
553 |
my @tfilters; |
my @tfilters; |
554 |
|
my $orm_filter = undef; |
555 |
|
|
556 |
foreach my $filter (@$filters) { |
foreach my $filter (@{$in->{filters}}) { |
557 |
|
|
558 |
# get filter - TODO: for each filter |
# get filter - TODO: for each filter |
559 |
#my $filter = $filters->[0]; |
#my $filter = $filters->[0]; |
560 |
|
|
561 |
# build filter |
# 1. The parts of a filter source entry |
562 |
my $lexpr = $filter->{key}; |
my $lexpr = $filter->{key}; |
563 |
#my $op = $filter->{op}; |
#my $op = $filter->{op}; |
564 |
my $op = '='; |
my $op = '='; |
565 |
my $rexpr = $filter->{val}; |
my $rexpr = $filter->{val}; |
566 |
my $tight = 100; |
my $tight = 100; |
567 |
|
|
568 |
|
# 2. Build filter target entry |
569 |
|
|
570 |
# my $tfilter = Tangram::Filter->new( |
# Test 1 - didn't work out! |
571 |
# expr => "t1.$lexpr $op '$rexpr'", |
# my $tfilter = Tangram::Filter->new( |
572 |
# tight => $tight, |
# expr => "t1.$lexpr $op '$rexpr'", |
573 |
# objects => $objects, |
# tight => $tight, |
574 |
# ); |
# objects => $objects, |
575 |
|
# ); |
576 |
|
|
577 |
|
my $orm_filter_tmp = undef; |
578 |
|
# was: |
579 |
|
# TODO: is_op? |
580 |
|
# dispatch un-common operators if exists |
581 |
|
if ($filter->{op} eq "ref") { |
582 |
|
# do nothing, results will be filtered later cause 'tangram-filter' doesn't support 'ref' query |
583 |
|
#print "Filter->op eq 'ref'.\n"; |
584 |
|
#push @tfilters, 'ref($remote->{' . $filter->{key} . '})' . " eq '$filter->{val}'"; |
585 |
|
} else { |
586 |
|
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
587 |
|
#push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'"; |
588 |
|
# better: calculate expression right here! |
589 |
|
#push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'"; |
590 |
|
|
591 |
|
#print "key: ", $filter->{key}, "\n"; |
592 |
|
|
593 |
|
my $left = $remote->{$filter->{key}}; |
594 |
|
#my $r = Tangram::Expr->new( 'string' => "'" . $filter->{val} . "'" ); |
595 |
|
my $right = $filter->{val}; |
596 |
|
my $op = $filter->{op}; |
597 |
|
$orm_filter_tmp = $left->$op($right); |
598 |
|
} |
599 |
|
|
600 |
|
if (!ref($orm_filter)) { |
601 |
|
$orm_filter = $orm_filter_tmp; |
602 |
|
} else { |
603 |
|
$orm_filter = $orm_filter->and($orm_filter_tmp); |
604 |
|
} |
605 |
|
|
606 |
|
} |
607 |
|
|
608 |
|
$orm_query->{filter} = $orm_filter; |
609 |
|
|
610 |
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
# debug point: |
611 |
push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'"; |
#print "Filter: " . Dumper($orm_query->{filter}) . "\n"; |
612 |
|
|
613 |
|
# was: |
614 |
|
|
615 |
|
# 2.b. sorting [new as of 2003-06-17] |
616 |
|
if ($in->{sorting}) { |
617 |
|
my $sorting_rules = []; |
618 |
|
my $sorting_order = 'ASC'; |
619 |
|
foreach my $sorting_column (keys %{$in->{sorting}}) { |
620 |
|
$sorting_order = $in->{sorting}->{$sorting_column} if $in->{sorting}->{$sorting_column}; |
621 |
|
push @$sorting_rules, Tangram::Expr->new( 'string' => $sorting_column ); |
622 |
|
} |
623 |
|
$orm_query->{order} = $sorting_rules; |
624 |
|
if ($sorting_order eq 'DESC') { |
625 |
|
$orm_query->{desc} = 1; |
626 |
|
} |
627 |
} |
} |
628 |
|
|
|
my $tfilter = join(' & ', @tfilters); |
|
629 |
|
|
630 |
# get set of objects from odbms by object name |
# 3. build and issue query - return result as Tangram::Cursor |
|
my $remote = $self->{_COREHANDLE}->remote($nodename); |
|
631 |
|
|
632 |
# was: |
# coerce hash into array (This is valid in Perl) |
633 |
#@results = $self->{COREHANDLE}->select($object_set, $tfilter); |
my @orm_query_args = %$orm_query; |
634 |
|
# send query (arguments) to orm |
635 |
|
@results = $self->{_COREHANDLE}->select($remote, @orm_query_args); |
636 |
|
|
637 |
|
#my $cursor = $self->{_COREHANDLE}->cursor($remote, @orm_query_args); |
638 |
|
#return $cursor; |
639 |
|
#print Dumper(@results); |
640 |
|
|
641 |
# is: |
# is: |
642 |
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
# HACK: build eval-string (sorry) to get filtered list - please give advice here |
643 |
my $evalstring = 'return $self->{_COREHANDLE}->select($remote, ' . $tfilter . ');'; |
#my $evalstring = 'return $self->{_COREHANDLE}->select($remote, ' . $tfilter . $sorting . ');'; |
644 |
|
#print "eval: $evalstring", "\n"; |
645 |
#print "eval: $evalstring", "\n"; |
# get filtered list/set |
646 |
|
#@results = eval($evalstring); |
647 |
# get filtered list/set |
#die $@ if $@; |
648 |
@results = eval($evalstring); |
|
649 |
die $@ if $@; |
# filter results - NEEDED for e.g. UserManagment !! |
650 |
|
if ($in->{filters}->[0]->{op} && ($in->{filters}->[0]->{op} eq "ref")) { |
651 |
|
#print "Filter->op eq 'ref'.\n"; |
652 |
|
my $att_name = $in->{filters}->[0]->{key}; |
653 |
|
my $att_val = $in->{filters}->[0]->{val}; |
654 |
|
my @filtered; |
655 |
|
foreach(@results) { |
656 |
|
if(ref($_->{$att_name}) eq $att_val) { |
657 |
|
push @filtered, $_; |
658 |
|
} |
659 |
|
} |
660 |
|
@results = @filtered; |
661 |
|
} |
662 |
|
|
663 |
|
#print "results: " . Dumper(\@results); |
664 |
|
|
665 |
return \@results; |
return \@results; |
666 |
} |
} |
690 |
return $result; |
return $result; |
691 |
} |
} |
692 |
|
|
693 |
|
sub createResult { |
694 |
|
my $self = shift; |
695 |
|
my $rh = shift; |
696 |
|
my $result = Data::Storage::Result::Tangram->new( RESULTHANDLE => $rh ); |
697 |
|
return $result; |
698 |
|
} |
699 |
|
|
700 |
sub sendQuery { |
sub sendQuery { |
701 |
my $self = shift; |
my $self = shift; |
702 |
my $query = shift; |
my $query = shift; |
708 |
# mode = OID|SPECIAL |
# mode = OID|SPECIAL |
709 |
my $mode = ''; |
my $mode = ''; |
710 |
my $ident = ''; |
my $ident = ''; |
711 |
my $action = ''; |
my $crud = ''; |
712 |
|
|
713 |
|
|
714 |
# dispatch type and mode |
# dispatch type and mode |
715 |
|
|
716 |
# defaults - 1 |
# defaults - 1 |
717 |
if ($query->{options}) { |
if ($query->{options}) { |
718 |
$action = $query->{options}->{action}; |
$crud = $query->{options}->{crud}; |
719 |
|
$crud ||= $query->{options}->{action}; |
720 |
} |
} |
721 |
|
|
722 |
# defaults - 2 |
# defaults - 2 |
723 |
$type ||= 'TRANSPARENT'; |
$type ||= 'TRANSPARENT'; |
724 |
$action ||= 'load'; |
$crud ||= 'RETRIEVE'; |
725 |
|
|
726 |
if ($query->{options}->{OID}) { |
if ($query->{options}->{OID}) { |
727 |
$type = 'ITEM'; |
$type = 'ITEM'; |
730 |
|
|
731 |
} elsif (my $guid = $query->{options}->{GUID}) { |
} elsif (my $guid = $query->{options}->{GUID}) { |
732 |
$type = 'TRANSPARENT'; |
$type = 'TRANSPARENT'; |
733 |
$query->{criterias} = [ { key => 'guid', op => 'eq', val => $guid } ]; |
if(ref($query->{criterias}) eq 'ARRAY') { |
734 |
|
push @{$query->{criterias}}, { key => 'guid', op => 'eq', val => $guid }; |
735 |
|
} else { |
736 |
|
$query->{criterias} = [ { key => 'guid', op => 'eq', val => $guid } ]; |
737 |
|
} |
738 |
|
} |
739 |
|
# if operator is different (dispatcher for 'getListFiltered') |
740 |
|
if (my $op = $query->{options}->{op}) { |
741 |
|
$type = 'TRANSPARENT'; |
742 |
|
if(ref($query->{criterias}) eq 'ARRAY') { |
743 |
|
push @{$query->{criterias}}, { key => $query->{options}->{meta_label}, op => $op, val => $query->{options}->{meta_value} }; |
744 |
|
} else { |
745 |
|
$query->{criterias} = [ { key => $query->{options}->{meta_label}, op => $op, val => $query->{options}->{meta_value} } ]; |
746 |
|
} |
747 |
} |
} |
748 |
|
|
749 |
# HACK: special case: querying by id does not translate into a common tangram query |
# HACK: special case: querying by id does not translate into a common tangram query |
761 |
if ($type eq 'ITEM' && $ident) { |
if ($type eq 'ITEM' && $ident) { |
762 |
|
|
763 |
if ($mode eq 'OID') { |
if ($mode eq 'OID') { |
764 |
|
# TODO: review this case! |
765 |
$result = $self->getObject($ident, $query->{options}); |
$result = $self->getObject($ident, $query->{options}); |
766 |
|
|
767 |
} elsif ($mode eq 'SPECIAL.SYNC') { |
} elsif ($mode eq 'SPECIAL.SYNC') { |
793 |
|
|
794 |
} elsif ($type eq 'TRANSPARENT') { |
} elsif ($type eq 'TRANSPARENT') { |
795 |
|
|
796 |
if ($action eq 'load') { |
if ($crud eq 'RETRIEVE') { |
797 |
|
|
798 |
my $list = $self->getListFiltered($query->{node}, $query->{criterias}); |
my $list = $self->getListFiltered($query->{node}, $query->{criterias}, $query->{sorting}); |
799 |
|
#return $list; |
800 |
|
return $self->createResult($list); |
801 |
|
|
802 |
#return $self->createSet($object); |
#return $self->createSet($object); |
803 |
#return $self->createSet($list); |
#return $self->createSet($list); |
804 |
return $self->createSet(@$list); |
return $self->createSet(@$list); |
823 |
#my $res = $self->{COREHANDLE}->select($h, $h->{); |
#my $res = $self->{COREHANDLE}->select($h, $h->{); |
824 |
$result = $self->createCursor($query->{node}); |
$result = $self->createCursor($query->{node}); |
825 |
|
|
826 |
} elsif ($action eq 'save') { |
} elsif ($crud eq 'UPDATE') { |
827 |
|
|
828 |
# Patch current query to be a loader (e.g. change action, remove payload) ... |
# Patch current query to be a loader (e.g. change action, remove payload) ... |
829 |
my $childquery = deep_copy($query); |
my $childquery = deep_copy($query); |
830 |
$childquery->{options}->{action} = 'load'; |
$childquery->{options}->{crud} = 'RETRIEVE'; |
831 |
delete $childquery->{payload}; |
delete $childquery->{payload}; |
832 |
|
|
833 |
# ... to use it to fetch fresh object using ourselves (sendQuery). |
# ... to use it to fetch a fresh object using ourselves (sendQuery). |
834 |
my $cursor = $self->sendQuery($childquery); |
my $cursor = $self->sendQuery($childquery); |
835 |
my $status = $cursor->getStatus(); |
my $status = $cursor->getStatus(); |
836 |
my $object = $cursor->getNextEntry(); |
my $object = $cursor->getNextEntry(); |
839 |
my $options = { utf8 => 1, php => 1 }; |
my $options = { utf8 => 1, php => 1 }; |
840 |
merge_to($object, $query->{payload}, $options); |
merge_to($object, $query->{payload}, $options); |
841 |
|
|
842 |
|
#print Dumper($object); |
843 |
|
|
844 |
# Execute update operation at orm. |
# Execute update operation at orm. |
845 |
$self->update($object); |
$self->update($object); |
846 |
|
$result = $self->createResult([ $object ]); |
847 |
|
|
848 |
|
} elsif ($crud eq 'DELETE') { |
849 |
|
|
850 |
|
# Patch current query to be a loader (e.g. change action) ... |
851 |
|
my $childquery = deep_copy($query); |
852 |
|
$childquery->{options}->{crud} = 'RETRIEVE'; |
853 |
|
|
854 |
|
# ... to use it to fetch a fresh object using ourselves (sendQuery). |
855 |
|
my $cursor = $self->sendQuery($childquery); |
856 |
|
my $status = $cursor->getStatus(); |
857 |
|
my $object = $cursor->getNextEntry(); |
858 |
|
|
859 |
|
$self->erase($object); |
860 |
|
$self->unload($object); |
861 |
|
|
862 |
|
} elsif ($crud eq 'CREATE') { |
863 |
|
|
864 |
|
my $nodename = $query->{node}; |
865 |
|
my $newnode = $self->createNode($nodename); |
866 |
|
my $id = $self->{_COREHANDLE}->insert($newnode); |
867 |
|
|
868 |
|
$logger->info( __PACKAGE__ . "->sendQuery: Saved new node $nodename with GUID $newnode->{guid}, OID '$id'."); |
869 |
|
|
870 |
|
return $newnode; |
871 |
|
|
872 |
} |
} |
873 |
|
|
874 |
} |
} |
1023 |
$self->{dataStorageLayer}->disconnect(); |
$self->{dataStorageLayer}->disconnect(); |
1024 |
} |
} |
1025 |
|
|
1026 |
|
|
1027 |
|
sub createNode { |
1028 |
|
my $self = shift; |
1029 |
|
my $classname = shift; |
1030 |
|
|
1031 |
|
my $obj = $classname->new(); |
1032 |
|
|
1033 |
|
my $attr_options = Class::Tangram::attribute_options($classname); |
1034 |
|
#print "Attribute Options: " . Dumper($attr_options); |
1035 |
|
|
1036 |
|
my $attr_types = Class::Tangram::attribute_types($classname); |
1037 |
|
#print "Attribute Types: " . Dumper($attr_types); |
1038 |
|
|
1039 |
|
foreach(keys %{$attr_types}) { |
1040 |
|
if($attr_types->{$_} eq 'string') { |
1041 |
|
$obj->{$_} = ''; |
1042 |
|
} elsif($attr_types->{$_} eq 'int') { |
1043 |
|
$obj->{$_} = 0; |
1044 |
|
} elsif($attr_types->{$_} eq 'real') { |
1045 |
|
$obj->{$_} = 0; |
1046 |
|
} elsif($attr_types->{$_} eq 'rawdatetime') { |
1047 |
|
$obj->{$_} = '0000-00-00 00:00:00'; |
1048 |
|
} elsif($attr_types->{$_} eq 'ref') { |
1049 |
|
if($attr_options->{$_}->{class}) { |
1050 |
|
# HACK!!! |
1051 |
|
# STANDALONE Objects (objects which make sense to instanciat alone) should not created automaticly |
1052 |
|
# because they maybe exists and should only be SETTED not CREATED! |
1053 |
|
# TODO: Create a flag at the scheme for that reason! |
1054 |
|
# (e.g child_node => 1 for child-nodes only like e.g. UserData) |
1055 |
|
if($attr_options->{$_}->{class} eq 'NetPerson' || $attr_options->{$_}->{class} eq 'Event' || $attr_options->{$_}->{class} eq 'BetRule') { |
1056 |
|
#$obj->{$_} = undef(); |
1057 |
|
} else { |
1058 |
|
$obj->{$_} = $self->createNode($attr_options->{$_}->{class}); |
1059 |
|
} |
1060 |
|
} else { |
1061 |
|
#$obj->{$_} = undef(); |
1062 |
|
} |
1063 |
|
} elsif($attr_types->{$_} eq 'iarray') { |
1064 |
|
$obj->{$_} = [ ]; |
1065 |
|
} elsif($attr_types->{$_} eq 'hash') { |
1066 |
|
$obj->{$_} = { }; |
1067 |
|
} elsif($attr_types->{$_} eq 'flat_hash') { |
1068 |
|
$obj->{$_} = { }; |
1069 |
|
} |
1070 |
|
} |
1071 |
|
|
1072 |
|
#print "New Object: " . Dumper($obj); |
1073 |
|
|
1074 |
|
return $obj; |
1075 |
|
} |
1076 |
|
|
1077 |
|
|
1078 |
|
sub insertChildNode { |
1079 |
|
my $self = shift; |
1080 |
|
my $child_entry = shift; |
1081 |
|
my $query_args = shift; |
1082 |
|
|
1083 |
|
my $core = $self->{_COREHANDLE}; |
1084 |
|
my $nodename = $query_args->{nodename}; |
1085 |
|
|
1086 |
|
# get parent object |
1087 |
|
my $query = { |
1088 |
|
node => $query_args->{parent}->{nodename}, |
1089 |
|
options => { GUID => $query_args->{parent}->{guid}, }, |
1090 |
|
}; |
1091 |
|
my $cursor = $self->sendQuery($query); |
1092 |
|
my $parent = $cursor->getNextEntry(); |
1093 |
|
|
1094 |
|
# debug |
1095 |
|
#print "Parent_org: " . Dumper($parent); |
1096 |
|
|
1097 |
|
# Create child node object if isn't already done |
1098 |
|
# ($child_entry have to be the class name then...) |
1099 |
|
if(!ref($child_entry)) { |
1100 |
|
$child_entry = $self->createNode($child_entry); |
1101 |
|
# it could be insert 'manually' or will be insert 'transparent' if parent will be updated |
1102 |
|
#$core->insert($child_entry); |
1103 |
|
#print "Create child object [$nodename]: " . Dumper($child_entry); |
1104 |
|
} |
1105 |
|
|
1106 |
|
# get reference of tied node (seems, only on Linux node's are tied!!) |
1107 |
|
my $tied_node = tied $parent->{$nodename}; |
1108 |
|
|
1109 |
|
# insert/change child entry at parent |
1110 |
|
#print "reference: " . ref($parent->{$nodename}) . "\n"; |
1111 |
|
if(ref($parent->{$nodename}) eq 'ARRAY') { |
1112 |
|
# (seems, only on Linux node's are tied!!) |
1113 |
|
if($tied_node) { |
1114 |
|
# all tangram types are tied as 'SCALAR' with special 'FETCH', 'STORE' methods per type, |
1115 |
|
# so a 'PUSH' is not implemented (which could be then done transparently) |
1116 |
|
my $array = $tied_node->FETCH; |
1117 |
|
push @$array, $child_entry; |
1118 |
|
$tied_node->STORE($array); |
1119 |
|
# node will be normaly untied at 'STORE' |
1120 |
|
if(tied $parent->{$nodename}) { print "already tied !!\n"; } |
1121 |
|
else { undef $tied_node; } |
1122 |
|
} else { |
1123 |
|
push @{$parent->{$nodename}}, $child_entry; |
1124 |
|
} |
1125 |
|
} |
1126 |
|
elsif(ref($parent->{$nodename}) eq 'HASH') { |
1127 |
|
if(my $key = $query_args->{hash_key}) { |
1128 |
|
# (seems, only on Linux node's are tied!!) |
1129 |
|
if($tied_node) { |
1130 |
|
# same problem as with 'ARRAY': |
1131 |
|
# all tangram types are tied as 'SCALAR' with special 'FETCH', 'STORE' methods per type. |
1132 |
|
my $hash = $tied_node->FETCH; |
1133 |
|
$hash->{$key} = $child_entry; |
1134 |
|
$tied_node->STORE($hash); |
1135 |
|
# node will be normaly untied at 'STORE' |
1136 |
|
if(tied $parent->{$nodename}) { print "already tied !!\n"; } |
1137 |
|
else { undef $tied_node; } |
1138 |
|
} else { |
1139 |
|
$parent->{$nodename}->{$key} = $child_entry; |
1140 |
|
} |
1141 |
|
} else { |
1142 |
|
print "ERROR: No HASH KEY given, so not able to insert hash entry!"; |
1143 |
|
} |
1144 |
|
} |
1145 |
|
else { |
1146 |
|
$parent->{$nodename} = $child_entry; |
1147 |
|
} |
1148 |
|
|
1149 |
|
# debug |
1150 |
|
#print "Parent_new: " . Dumper($parent); |
1151 |
|
|
1152 |
|
# save parent |
1153 |
|
$core->update($parent); |
1154 |
|
|
1155 |
|
# debug |
1156 |
|
#print "Saved Parent: ". Dumper($parent); |
1157 |
|
|
1158 |
|
return $child_entry; |
1159 |
|
} |
1160 |
|
|
1161 |
|
|
1162 |
1; |
1; |
1163 |
__END__ |
__END__ |