3 |
# $Id$ |
# $Id$ |
4 |
# |
# |
5 |
# $Log$ |
# $Log$ |
6 |
|
# Revision 1.22 2002/12/18 22:28:16 jonen |
7 |
|
# + added extended logging at 'getObjectByGuid()' |
8 |
|
# |
9 |
|
# Revision 1.21 2002/12/16 22:20:49 jonen |
10 |
|
# + fixed bug at 'getObjectByGuid()' |
11 |
|
# |
12 |
|
# Revision 1.20 2002/12/16 20:49:17 jonen |
13 |
|
# + added sub 'getObjectByGuid()' |
14 |
|
# + added functionality to use 'getObjectByGuid' at 'getObjectAsHash()' |
15 |
|
# |
16 |
|
# Revision 1.19 2002/12/16 06:46:09 joko |
17 |
|
# + attempt to introduce a generic '_patchSchema' - cancelled! |
18 |
|
# |
19 |
|
# Revision 1.18 2002/12/13 21:48:07 joko |
20 |
|
# + fix to 'sub sendQuery' |
21 |
|
# |
22 |
|
# Revision 1.17 2002/12/12 02:51:09 joko |
23 |
|
# + cosmetics |
24 |
|
# |
25 |
# Revision 1.16 2002/12/11 06:54:10 joko |
# Revision 1.16 2002/12/11 06:54:10 joko |
26 |
# + fix: encapsulated object-loading inside an 'eval' |
# + fix: encapsulated object-loading inside an 'eval' |
27 |
# |
# |
134 |
$logger->error( __PACKAGE__ . "->_initSchema: No Schema available for $self->{schema}" ); |
$logger->error( __PACKAGE__ . "->_initSchema: No Schema available for $self->{schema}" ); |
135 |
return 0; |
return 0; |
136 |
} |
} |
137 |
|
#$self->_patchSchema(); |
138 |
return 1; |
return 1; |
139 |
} |
} |
140 |
|
|
141 |
|
sub _patchSchema { |
142 |
|
my $self = shift; |
143 |
|
foreach (keys %{$schema_tangram->{classes}}) { |
144 |
|
next if $schema_tangram->{classes}->{$_}->{abstract}; |
145 |
|
#next if ($_ ne 'TsBankAccount'); |
146 |
|
#$_ ne 'AbstractAccount' && |
147 |
|
print "class: $_", "\n"; |
148 |
|
#print Dumper($schema_tangram->{classes}->{$_}); |
149 |
|
# create new string property named 'guid' |
150 |
|
my $tstring = Tangram::String->new(); |
151 |
|
$tstring->{name} = $tstring->{col} = 'guid'; |
152 |
|
# inject property into schema |
153 |
|
#$schema_tangram->{classes}->{$_}->{root}->{SPECS}->[0]->{fields}->{string}->{$tstring->{name}} = $tstring; |
154 |
|
print Dumper($schema_tangram->{classes}->{$_}->{root}->{SPECS}->[0]->{fields}); |
155 |
|
} |
156 |
|
} |
157 |
|
|
158 |
sub connect { |
sub connect { |
159 |
|
|
160 |
my $self = shift; |
my $self = shift; |
463 |
|
|
464 |
sub createSet { |
sub createSet { |
465 |
my $self = shift; |
my $self = shift; |
466 |
|
#print "-" x 80, "\n"; |
467 |
|
#print Dumper(@_); |
468 |
my @objects = @_; |
my @objects = @_; |
469 |
my $rh = Set::Object->new(); |
my $rh = Set::Object->new(); |
470 |
foreach (@objects) { |
foreach (@objects) { |
471 |
#print Dumper($_); |
if (!isEmpty($_)) { |
472 |
$rh->insert($_) if !isEmpty($_); |
#print Dumper($_); |
473 |
|
$rh->insert($_); |
474 |
|
} |
475 |
} |
} |
476 |
#print Dumper($rh->members()); |
#print Dumper($rh->members()); |
477 |
my $result = Data::Storage::Result::Tangram->new( RESULTHANDLE => $rh ); |
my $result = Data::Storage::Result::Tangram->new( RESULTHANDLE => $rh ); |
495 |
my $ident = $query->{criterias}->[0]->{val}; |
my $ident = $query->{criterias}->[0]->{val}; |
496 |
#print "load obj", "\n"; |
#print "load obj", "\n"; |
497 |
#return $self->createSet() if $ident == 5; |
#return $self->createSet() if $ident == 5; |
498 |
|
$self->{_COREHANDLE}->unload($ident); |
499 |
my $object = $self->{_COREHANDLE}->load($ident); |
my $object = $self->{_COREHANDLE}->load($ident); |
500 |
#print "get id", "\n"; |
#print "get id", "\n"; |
501 |
my $oid = $self->{_COREHANDLE}->id($object); |
my $oid = $self->{_COREHANDLE}->id($object); |
502 |
|
#print Dumper($object); |
503 |
|
#print "oid: $oid", "\n"; |
504 |
return $self->createSet($object); |
return $self->createSet($object); |
505 |
#return $self->createSet( $self->{COREHANDLE}->load('300090018') ); |
#return $self->createSet( $self->{COREHANDLE}->load('300090018') ); |
506 |
} |
} |
547 |
|
|
548 |
# TODO: create a deep_unload method (currently _all_ objects are unloaded) |
# TODO: create a deep_unload method (currently _all_ objects are unloaded) |
549 |
# unload($oid) will only unload object, not deep object hashes |
# unload($oid) will only unload object, not deep object hashes |
550 |
$self->{_COREHANDLE}->unload() if($options->{destroy}); |
$self->{_COREHANDLE}->unload() if ($options->{destroy}); |
551 |
|
|
552 |
# TODO: review this |
# TODO: review this |
553 |
#if (!$self->{COREHANDLE}) { return; } |
#if (!$self->{COREHANDLE}) { return; } |
559 |
return $object if $object; |
return $object if $object; |
560 |
} |
} |
561 |
|
|
562 |
|
sub getObjectByGuid { |
563 |
|
my $self = shift; |
564 |
|
my $guid = shift; |
565 |
|
my $options = shift; |
566 |
|
|
567 |
|
# Guid and Classname is needed |
568 |
|
if(!$guid || !$options->{classname}) { |
569 |
|
$logger->error( __PACKAGE__ . "->getObjectByGuid: No 'guid' OR no Classname in options hash was given but needed!" ); |
570 |
|
return; |
571 |
|
} |
572 |
|
|
573 |
|
# TODO: create a deep_unload method (currently _all_ objects are unloaded) |
574 |
|
# unload($oid) will only unload object, not deep object hashes |
575 |
|
$self->{_COREHANDLE}->unload() if ($options->{destroy}); |
576 |
|
|
577 |
|
# search for object with given Classname and Guid |
578 |
|
my $obj_tmp = $self->{_COREHANDLE}->remote($options->{classname}); |
579 |
|
my @result = $self->{_COREHANDLE}->select($obj_tmp, $obj_tmp->{guid} eq $guid); |
580 |
|
|
581 |
|
# we searched for global unique identifer of some object, |
582 |
|
# so I think we can trust there would be only one result |
583 |
|
if($result[0]) { |
584 |
|
return $result[0]; |
585 |
|
} else { |
586 |
|
$logger->error( __PACKAGE__ . "->getObjectByGuid: No Object with Classname $options->{classname} and GUID $guid found!" ); |
587 |
|
return; |
588 |
|
} |
589 |
|
|
590 |
|
} |
591 |
|
|
592 |
sub getObjectAsHash { |
sub getObjectAsHash { |
593 |
my $self = shift; |
my $self = shift; |
594 |
my $oid = shift; |
my $oid = shift; |
595 |
my $options = shift; |
my $options = shift; |
596 |
my $obj = $self->getObject($oid, $options); |
my $obj; |
597 |
|
|
598 |
|
if($options->{guid}) { |
599 |
|
$obj = $self->getObjectByGuid($oid, $options); |
600 |
|
} else { |
601 |
|
$obj = $self->getObject($oid, $options); |
602 |
|
} |
603 |
|
|
604 |
# build options (a callback to unload autovivified objects) for 'expand' |
# build options (a callback to unload autovivified objects) for 'expand' |
605 |
# TODO: use $logger to write to debug here! |
# TODO: use $logger to write to debug here! |