/[cvs]/nfo/perl/libs/Data/Storage/Handler/Tangram.pm
ViewVC logotype

Contents of /nfo/perl/libs/Data/Storage/Handler/Tangram.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.13 - (show annotations)
Thu Dec 5 07:59:04 2002 UTC (21 years, 7 months ago) by joko
Branch: MAIN
Changes since 1.12: +31 -18 lines
+ now using Tie::SecureHash as a base for the COREHANDLE
+ former public COREHANDLE becomes private _COREHANDLE now
+ sub getCOREHANDLE

1 ############################################
2 #
3 # $Id: Tangram.pm,v 1.12 2002/12/04 11:34:49 joko Exp $
4 #
5 # $Log: Tangram.pm,v $
6 # Revision 1.12 2002/12/04 11:34:49 joko
7 # - $schema_tangram doesn't have to be in class?
8 #
9 # Revision 1.11 2002/12/04 08:54:08 jonen
10 # + untested bugfix: undef($object) after transform to hash at getObjectAsHash
11 #
12 # Revision 1.10 2002/12/03 15:53:23 joko
13 # + small bugfix regarding object hierarchy
14 #
15 # Revision 1.9 2002/12/03 05:29:40 joko
16 # + sub getObject
17 # + sub getObjectAsHash
18 #
19 # Revision 1.8 2002/12/01 22:25:51 joko
20 # + now utilizing metadata from storage locator when connecting to DBI in "raw"-mode
21 #
22 # Revision 1.7 2002/12/01 04:46:19 joko
23 # + sub eraseAll
24 #
25 # Revision 1.6 2002/11/29 05:02:30 joko
26 # - sub getNewPerlObjectByPkgName (moved to libp.pm)
27 # + sub getMetaInfo
28 # - sub existsChildNode (moved to Abstract.pm)
29 # + sub getListUnfiltered
30 # + sub getListFiltered
31 # + sub createCursor
32 # + sub createSet
33 # + sub sendQuery
34 #
35 # Revision 1.5 2002/11/17 06:35:18 joko
36 # + locator metadata can now be reached via ->{locator}
37 # - getChildNodes is now wrapped via COREHANDLE
38 #
39 # Revision 1.4 2002/10/25 11:44:44 joko
40 # + sub _initSchema
41 # + sub existsChildNode
42 # + sub testIntegrity
43 # + sub rebuildDbAndSchema
44 #
45 # Revision 1.3 2002/10/17 03:56:55 joko
46 # + bugfix: trapped eval error
47 #
48 # Revision 1.2 2002/10/17 00:10:05 joko
49 # + removed dependency from tsobj.pm, schema is now independent
50 # + sub getNewPerlObjectByPkgName
51 # + sub deploySchema
52 # + sub retreatSchema
53 #
54 # Revision 1.1 2002/10/10 03:44:07 cvsjoko
55 # + new
56 #
57 ############################################
58
59
60 package Data::Storage::Handler::Tangram;
61
62 use strict;
63 use warnings;
64
65 use base ("Data::Storage::Handler");
66 use base ("Data::Storage::Handler::Abstract");
67
68 use Tangram;
69 use Data::Dumper;
70 use libp qw( getNewPerlObjectByPkgName );
71 use Data::Storage::Result::Tangram;
72 use Data::Compare::Struct qw( isEmpty );
73 use Data::Transform::Deep qw( var_deref );
74 use Data::Transform::Encode qw( var2utf8 );
75
76
77 # get logger instance
78 my $logger = Log::Dispatch::Config->instance;
79
80
81 # this holds the complete instantiated schema from tangram
82 my $schema_tangram;
83
84 sub getMetaInfo {
85 my $self = shift;
86 $logger->debug( __PACKAGE__ . "->getMetaInfo()" );
87 return {
88 'disconnectMethod' => 'disconnect',
89 };
90 }
91
92 sub _initSchema {
93 my $self = shift;
94 $logger->debug( __PACKAGE__ . "->_initSchema()" );
95 #if (!$schema_tangram) {
96 my $obj = getNewPerlObjectByPkgName($self->{locator}->{schema}, { EXPORT_OBJECTS => $self->{locator}->{classnames}, want_transactions => $self->{locator}->{want_transactions} } );
97 $schema_tangram = $obj->getSchema();
98 #}
99 if (!$schema_tangram) {
100 $logger->error( __PACKAGE__ . "->_initSchema: No Schema available for $self->{schema}" );
101 return 0;
102 }
103 return 1;
104 }
105
106 sub connect {
107
108 my $self = shift;
109
110 my $dsn = shift;
111 $dsn ||= $self->{locator}->{dbi}->{dsn};
112
113 $logger->debug( __PACKAGE__ . "->connect( dsn $dsn )" );
114
115 #my $storage = Tangram::Relational->connect( $schema, $dsn );
116 #my $storage = Tangram::mysql->connect( $schema, $dsn );
117 #$storage = Tangram::Relational->connect( Project->schema, $dsn );
118
119 # if (!testDsn($dsn)) {
120 # croak("Database at \"$dsn\" is not available");
121 # return;
122 # }
123
124 return unless $self->_initSchema();
125
126 # create the main tangram storage object
127 #$self->{COREHANDLE} = Tangram::Relational->connect( $schema, $dsn );
128 $self->{_COREHANDLE} = Tangram::Relational->connect( $schema_tangram, $dsn );
129
130 #print "connect", "\n";
131 #my $core = $self->{_COREHANDLE};
132 #print Dumper($core);
133
134 # some attempts for configuring the wrapped underlying dbi.....
135 #$self->{STORAGEHANDLE_UNDERLYING} = $self->getUnderlyingStorage();
136 #$self->{STORAGEHANDLE_UNDERLYING}->_configureCOREHANDLE();
137 #$self->_configureUnderlyingStorage;
138
139 # ..... encapsulation wins!
140 $self->configureCOREHANDLE();
141
142 $self->{locator}->{status}->{connected} = 1;
143
144 return 1;
145
146 }
147
148 sub getChildNodes {
149
150 my $self = shift;
151 my @nodes;
152
153 $logger->debug( __PACKAGE__ . "->getChildNodes()" );
154
155 # create new DBI - Data::Storage - object from already connected DBI::db - handle inside the current COREHANDLE
156 #my $loc = new Data::Storage::Locator( type => "DBI", dbi => { db => $self->{COREHANDLE}->{db} });
157 #my $loc = new Data::Storage::Locator( type => "DBI", COREHANDLE => $self->{COREHANDLE}->{db} );
158
159 # todo: should we retrieve information from the schema here
160 # rather than poorly getting table names from underlying dbi?
161 my $storage = $self->_getSubLayerHandle();
162 @nodes = @{$storage->getChildNodes()};
163 #$storage->_configureCOREHANDLE();
164 #print "getchildnodes\n";
165 #print Dumper($self);
166 #if (my $result = $self->sendCommand( 'SHOW TABLES;' ) ) {
167
168 # TODO: REVIEW
169 #$storage->disconnect();
170
171 $self->{meta}->{childnodes} = \@nodes;
172
173 return \@nodes;
174
175 }
176
177
178 sub testIntegrity {
179
180 my $self = shift;
181
182 $logger->debug( __PACKAGE__ . "->testIntegrity()" );
183
184 # 1st test: are there tables?
185 if (!$self->getChildNodes()) {
186 $logger->warning( __PACKAGE__ . "->testIntegrity no childnodes exist" );
187 return;
188 }
189
190 # 2nd test: is there a table named "Tangram"?
191 if (!$self->existsChildNode("Tangram")) {
192 $logger->warning( __PACKAGE__ . "->testIntegrity childnode \"Tangram\" doesn't exist" );
193 return;
194 }
195
196 $self->{locator}->{status}->{integrity} = 1;
197 return 1;
198
199 }
200
201
202 sub _getSubLayerHandle {
203
204 my $self = shift;
205
206 $logger->debug( __PACKAGE__ . "->_getSubLayerHandle()" );
207
208 #print Dumper($self);
209
210 # hack, make more generic!
211 if (!$self->{dataStorageLayer}) {
212 $logger->debug( __PACKAGE__ . "->_getSubLayerHandle() creating new dataStorageLayer" );
213 #my $loc = Data::Storage::Locator->new( type => "DBI", dbi => $self->{dbi}, COREHANDLE => $self->{COREHANDLE}->{db} );
214 my $loc = Data::Storage::Locator->new( { type => "DBI", dbi => $self->{locator}->{dbi} } );
215 $self->{dataStorageLayer} = Data::Storage->new( $loc, { protected => 1 } );
216 #$self->{STORAGE_UNDER_THE_HOOD}->{STORAGEHANDLE}->_configureCOREHANDLE();
217 #$self->{STORAGE_UNDER_THE_HOOD}->_configureCOREHANDLE();
218 }
219
220 #print Dumper($self->{STORAGE_UNDER_THE_HOOD});
221
222 return $self->{dataStorageLayer};
223
224 }
225
226 sub _configureUnderlyingStorage {
227
228 my $self = shift;
229
230 $logger->debug( __PACKAGE__ . "->_configureUnderlyingStorage" );
231
232 $self->_configureCOREHANDLE_DBI();
233 return;
234
235 foreach my $key (keys %{$self->{dbi}}) {
236 my $val = $self->{dbi}->{$key};
237 print "entry: $key; $val", "\n";
238 $self->{_COREHANDLE}->{db}->{$key} = $val;
239 }
240 #print Dumper($self->{COREHANDLE}->{db});
241 }
242
243
244 sub configureCOREHANDLE {
245
246 my $self = shift;
247
248 $logger->debug( __PACKAGE__ . "->configureCOREHANDLE" );
249
250 #my $subLayer = $self->_getSubLayerHandle();
251
252 # apply configured modifications
253 if (exists $self->{dbi}->{trace_level} && exists $self->{dbi}->{trace_file}) {
254 $self->{_COREHANDLE}->{db}->trace($self->{dbi}->{trace_level}, $self->{dbi}->{trace_file});
255 }
256 if (exists $self->{dbi}->{RaiseError}) {
257 $self->{_COREHANDLE}->{db}->{RaiseError} = $self->{dbi}->{RaiseError};
258 }
259 if (exists $self->{dbi}->{PrintError}) {
260 $self->{_COREHANDLE}->{db}->{PrintError} = $self->{dbi}->{PrintError};
261 }
262 if (exists $self->{dbi}->{HandleError}) {
263 $self->{_COREHANDLE}->{db}->{HandleError} = $self->{dbi}->{HandleError};
264 }
265
266 }
267
268 sub deploySchema {
269 my $self = shift;
270 my $args = shift;
271
272 my $dsn = $self->{locator}->{dbi}->{dsn};
273
274 $logger->debug( __PACKAGE__ . "->deploySchema( dsn $dsn )" );
275
276 my $ok;
277 if ( my $dbh = DBI->connect($dsn, '', '', $self->{locator}->{dbi} ) ) {
278 return unless $self->_initSchema();
279 $ok = Tangram::Relational->deploy($schema_tangram, $dbh );
280 $dbh->disconnect();
281 }
282 return $ok;
283 }
284
285 sub retreatSchema {
286
287 my $self = shift;
288 my $dsn = $self->{locator}->{dbi}->{dsn};
289
290 $logger->debug( __PACKAGE__ . "->retreatSchema( dsn $dsn )" );
291
292 my $ok;
293 if ( my $dbh = DBI->connect($dsn, '', '', $self->{locator}->{dbi} ) ) {
294
295 return unless $self->_initSchema();
296
297 #use Data::Dumper; print Dumper($self);
298 $self->{dataStorageLayer}->removeLogDispatchHandler("Tangram11");
299
300 $ok = Tangram::Relational->retreat($schema_tangram, $dbh );
301
302 # answer "$ok=2" means "maybe" for now - we have to patch this to a constant here because...
303 # - ... Tangram::Relational->retreat doesn't seem to return a valid status
304 # - possible improvement:
305 # - test this by checking for count of tables in database
306 # - problem with this: there may be some left not having been included to the schema
307 # - maybe better: use "->getChildNodes"?
308 $ok = 2;
309
310 $dbh->disconnect();
311
312 }
313 return $ok;
314 }
315
316 sub rebuildDbAndSchema {
317 my $self = shift;
318 $logger->info( __PACKAGE__ . "->rebuildDbAndSchema()" );
319 my @results;
320
321 # sum up results (bool (0/1)) in array
322 push @results, $self->retreatSchema();
323 push @results, $self->{dataStorageLayer}->dropDb();
324 push @results, $self->{dataStorageLayer}->createDb();
325 push @results, $self->deploySchema();
326
327 # scan array for "bad ones"
328 my $res = 1;
329 map {
330 $res = 0 if (!$_);
331 } @results;
332
333 return $res;
334 }
335
336 sub getListUnfiltered {
337 my $self = shift;
338 my $nodename = shift;
339 my @results;
340 $logger->debug( __PACKAGE__ . "->getListUnfiltered( nodename => '" . $nodename . "' )" );
341 # get set of objects from odbms by object name
342 my $object_set = $self->{_COREHANDLE}->remote($nodename);
343 @results = $self->{_COREHANDLE}->select($object_set);
344 return \@results;
345 }
346
347 sub getListFiltered {
348 my $self = shift;
349
350 # redirect to unfiltered mode
351 #return $self->getListUnfiltered(@_);
352
353 my $nodename = shift;
354 my $filters = shift;
355 my @results;
356 $logger->debug( __PACKAGE__ . "->getListFiltered( nodename => '" . $nodename . "' )" );
357
358 #print Dumper($filters);
359
360 my @tfilters;
361
362 foreach my $filter (@$filters) {
363
364 # get filter - TODO: for each filter
365 #my $filter = $filters->[0];
366
367 # build filter
368 my $lexpr = $filter->{key};
369 #my $op = $filter->{op};
370 my $op = '=';
371 my $rexpr = $filter->{val};
372 my $tight = 100;
373
374 # my $tfilter = Tangram::Filter->new(
375 # expr => "t1.$lexpr $op '$rexpr'",
376 # tight => $tight,
377 # objects => $objects,
378 # );
379
380 # HACK: build eval-string (sorry) to get filtered list - please give advice here
381 push @tfilters, '$remote->{' . $filter->{key} . '}' . " $filter->{op} '$filter->{val}'";
382
383 }
384
385 my $tfilter = join(' & ', @tfilters);
386
387 # get set of objects from odbms by object name
388 my $remote = $self->{_COREHANDLE}->remote($nodename);
389
390 # was:
391 #@results = $self->{COREHANDLE}->select($object_set, $tfilter);
392
393 # is:
394 # HACK: build eval-string (sorry) to get filtered list - please give advice here
395 my $evalstring = 'return $self->{_COREHANDLE}->select($remote, ' . $tfilter . ');';
396
397 # get filtered list/set
398 @results = eval($evalstring);
399 die $@ if $@;
400
401 return \@results;
402 }
403
404 sub createCursor {
405 my $self = shift;
406 my $node = shift;
407 my $cmdHandle = $self->{_COREHANDLE}->cursor($node);
408 my $result = Data::Storage::Result::Tangram->new( RESULTHANDLE => $cmdHandle );
409 return $result;
410 }
411
412 sub createSet {
413 my $self = shift;
414 my @objects = @_;
415 my $rh = Set::Object->new();
416 foreach (@objects) {
417 #print Dumper($_);
418 $rh->insert($_) if !isEmpty($_);
419 }
420 #print Dumper($rh->members());
421 my $result = Data::Storage::Result::Tangram->new( RESULTHANDLE => $rh );
422 return $result;
423 }
424
425 sub sendQuery {
426 my $self = shift;
427 my $query = shift;
428 #my $sql = "SELECT cs FROM $self->{metainfo}->{$descent}->{node} WHERE $self->{metainfo}->{$descent}->{IdentProvider}->{arg}='$self->{entry}->{source}->{ident}';";
429 #my $result = $self->{metainfo}->{$descent}->{storage}->sendCommand($sql);
430
431 #print Dumper($query);
432
433 # HACK: special case: querying by id does not translate into a common tangram query
434 # just load the object by given id(ent)
435 if ($query->{criterias}->[0]->{key} eq 'id' && $query->{criterias}->[0]->{op} eq 'eq') {
436 #print "LOAD!!!", "\n";
437 #exit;
438 #return Set::Object->new( $self->{COREHANDLE}->load($query->{criterias}->[0]->{val}) );
439 my $ident = $query->{criterias}->[0]->{val};
440 #print "load obj", "\n";
441 #return $self->createSet() if $ident == 5;
442 my $object = $self->{_COREHANDLE}->load($ident);
443 #print "get id", "\n";
444 my $oid = $self->{_COREHANDLE}->id($object);
445 return $self->createSet($object);
446 #return $self->createSet( $self->{COREHANDLE}->load('300090018') );
447 }
448
449 die("This should not be reached for now - redirect to \$self->getListFiltered() here!");
450
451 # TODO: do a common tangram query here
452
453 my @crits;
454 foreach (@{$query->{criterias}}) {
455 my $op = '';
456 $op = '=' if lc $_->{op} eq 'eq';
457 push @crits, "$_->{key}$op'$_->{val}'";
458 }
459 my $subnodes = {};
460 map { $subnodes->{$_}++ } @{$query->{subnodes}};
461 # HACK: this is hardcoded ;( expand possibilities!
462 #my $crit = join(' AND ', @crits);
463 #my $sql = hash2Sql($query->{node}, $subnodes, 'SELECT', $crit);
464 #return $self->sendCommand($sql);
465 #my $h = $self->{COREHANDLE}->remote($query->{node});
466 #my $res = $self->{COREHANDLE}->select($h, $h->{);
467 return $self->createCursor($query->{node});
468 }
469
470 sub eraseAll {
471 my $self = shift;
472 my $classname = shift;
473 my $remote = $self->{_COREHANDLE}->remote($classname);
474 my @objs = $self->{_COREHANDLE}->select($remote);
475 $self->{_COREHANDLE}->erase(@objs);
476 }
477
478 sub createDb {
479 my $self = shift;
480 my $storage = $self->_getSubLayerHandle();
481 return $storage->createDb();
482 }
483
484 sub getObject {
485 my $self = shift;
486 my $oid = shift;
487 # TODO: review this
488 #if (!$self->{COREHANDLE}) { return; }
489 return $self->{_COREHANDLE}->load($oid);
490 }
491
492 sub getObjectAsHash {
493 my $self = shift;
494 my $oid = shift;
495 my $options = shift;
496 my $obj = $self->getObject($oid);
497 my $deref = var_deref($obj);
498 var2utf8($deref) if ($options->{utf8});
499 undef($obj) if($options->{destroy});
500 return $deref;
501 }
502
503 sub getSchema {
504 return $schema_tangram;
505 }
506
507 sub getCOREHANDLE {
508 my $self = shift;
509 return $self->{_COREHANDLE};
510 }
511
512 1;

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed