[Bio] / Sprout / ERDBObject.pm Repository:
ViewVC logotype

Annotation of /Sprout/ERDBObject.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download) (as text)

1 : parrello 1.1 package ERDBObject;
2 :    
3 :     use strict;
4 :     use DBKernel;
5 :     use Tracer;
6 :    
7 :     =head1 Entity-Relationship Database Package Instance Object
8 :    
9 :     =head2 Introduction
10 :    
11 :     This package defines the instance object for the Entity-Relationship Database Package.
12 :     This object can be created directly, returned by the C<Fetch>
13 :     method of the B<DBQuery> object, or returned by the C<Cross> method of this object.
14 :     An object created directly is considered I<transient>. An object created by one of the
15 :     database methods is considered I<persistent>. A transient object can be made persistent
16 :     using the C<Insert> method of the B<ERDB> object.
17 :    
18 :     An instance object allows the user to access the fields in the current instance. The
19 :     instance consists of zero or more entity and/or relationship objects and a map of field
20 :     names to locations. Some entity fields require additional queries to the database. If
21 :     the entity object is present, the additional queries are executed automatically. Otherwise,
22 :     the value is treated as missing.
23 :    
24 :     =head2 Public Methods
25 :    
26 :     =head3 new
27 :    
28 :     C<< my $dbObject = ERDBObject::new($name1 => \@list1, $name2 => \@list2, ... $nameN => \@listN); >>
29 :    
30 :     Create a new transient object. A transient object maps fields to values, but is not
31 :     associated with a database. The parameter list should be an entity name followed by
32 :     a set of key-value pairs. Each key should be in the standard I<objectName>C<(>I<attributeName>C<)>
33 :     format used by all of the ERDB methods. All values must be list references. For example,
34 :     the following code fragment creates an pseudo-Feature named C<peg.1> with two aliases.
35 :    
36 :     C<< my $feature = ERDBObject::new('Feature(id)' => ['peg.1'], >>
37 :     C<< 'Feature(alias)' => ['NC1004', 'PC1006']); >>
38 :    
39 :     =cut
40 :    
41 :     sub new {
42 :     # Create the value list.
43 :     my %values = ();
44 :     # Loop through the parameters.
45 :     my @parms = @_;
46 :     while (@parms > 0) {
47 :     # Get the current key-value pair.
48 :     my $list = pop @parms;
49 :     my $name = pop @parms;
50 :     # Put this key-value pair in the value hash
51 :     $values{$name} = $list;
52 :     }
53 :     # Create this object and bless it.
54 :     my $retVal = { _values => \%values, _newObjectFlag => 1 };
55 :     bless $retVal;
56 :     return $retVal;
57 :     }
58 :    
59 :     =head3 SetDB
60 :    
61 :     C<< my = $dbObject->SetDB($db, $target); >>
62 :    
63 :     Attach a database to this object. This method is useful if you have to create an
64 :     object manually (using L</new>) but want to be able to use the database methods
65 :     (e.g. L</Cross>) to retrieve additional data.
66 :    
67 :     =over 4
68 :    
69 :     =item db
70 :    
71 :     B<ERDB> object for the database to use.
72 :    
73 :     =item target
74 :    
75 :     Name of the entity relevant to this object. This parameter is important for cases where
76 :     a single B<ERDBObject> actually has data from multiple tables. The parameter indicates
77 :     the table from which a relationship crossing should occur. So, for example, a ERDBObject
78 :     could contain data from the I<IsLocatedIn> and I<Contig> tables; we would specify a
79 :     target of I<Contig> so that the L</Cross> method crosses from there.
80 :    
81 :     =back
82 :    
83 :     =cut
84 :     #: Return Type ;
85 :     sub SetDB {
86 :     # Get the parameters.
87 :     my ($self, $db, $target) = @_;
88 :     # Store the database and target entity data.
89 :     $self->{_db} = $db;
90 :     $self->{_targetEntity} = $target;
91 :     }
92 :    
93 :     =head3 Attributes
94 :    
95 :     C<< my @attrNames = $dbObject->Attributes(); >>
96 :    
97 :     This method will return a sorted list of the attributes present in this object.
98 :     The list can be used in the L</Values> method to get all the values stored.
99 :    
100 :     If the ERDBObject was created by a database query, the attributes returned will
101 :     only be those which occur on the primary relation. Additional fields may get
102 :     loaded into the object if the client has asked for them in a L</Value> or
103 :     L</Values> command. Initially, however, only the primary fields-- each of which
104 :     has one and only one value-- will be found in the attribute list.
105 :    
106 :     =cut
107 :     #: Return Type @;
108 :     sub Attributes {
109 :     # Get the parameters.
110 :     my ($self) = @_;
111 :     # Get the keys of the value hash.
112 :     my @retVal = sort keys %{$self->{_values}};
113 :     # Return the result.
114 :     return @retVal;
115 :     }
116 :    
117 :     =head3 HasField
118 :    
119 :     C<< my $flag = $dbObject->HasField($fieldSpec); >>
120 :    
121 :     Return TRUE if this object has the specified field available, else FALSE.
122 :     This method can be used to determine if a value is available without
123 :     requiring an additional database query.
124 :    
125 :     =over 4
126 :    
127 :     =item fieldSpec
128 :    
129 :     A standard field specifier, as is used to specify fields to the B<Get>
130 :     method of the B<Sprout> object.
131 :    
132 :     =item RETURN
133 :    
134 :     Returns TRUE if there's a value for the field in this object, else FALSE.
135 :    
136 :     =back
137 :    
138 :     =cut
139 :    
140 :     sub HasField {
141 :     # Get the parameters.
142 :     my ($self, $fieldName) = @_;
143 :     # Get the field hash.
144 :     my $fields = $self->{_values};
145 :     # Return the result.
146 :     return exists $fields->{$fieldName};
147 :     }
148 :    
149 :     =head3 AddValues
150 :    
151 :     C<< $dbObject->AddValues($name, @values); >>
152 :    
153 :     Add one or more values to a specified field.
154 :    
155 :     =over 4
156 :    
157 :     =item name
158 :    
159 :     Name of the field to receive the new values. If the field does
160 :     not exist, it will be created.
161 :    
162 :     =item values
163 :    
164 :     List of values to put in the field.
165 :    
166 :     =back
167 :    
168 :     =cut
169 :    
170 :     sub AddValues {
171 :     # Get the parameters.
172 :     my ($self, $name, @values) = @_;
173 :     # Get the field hash.
174 :     my $fields = $self->{_values};
175 :     # Add the new values.
176 :     Tracer::AddToListMap($fields, $name, @values);
177 :     }
178 :    
179 :     =head3 Value
180 :    
181 :     C<< my @values = $dbObject->Value($attributeName); >>
182 :    
183 :     Return a list of the values for the specified attribute.
184 :    
185 :     =over 4
186 :    
187 :     =item attributeName
188 :    
189 :     Name of the desired attribute, in the form B<I<objectName>(I<fieldName>)>.
190 :    
191 :     =item RETURN
192 :    
193 :     Returns a list of the values for the specified attribute, which may have 0, 1, or
194 :     multiple values.
195 :    
196 :     =back
197 :    
198 :     =cut
199 :    
200 :     sub Value {
201 :     # Get the parameters.
202 :     my ($self, $attributeName) = @_;
203 :     # Declare the return variable.
204 :     my @retVal = ();
205 :     # Look for the field in the values hash.
206 :     my $fieldHash = $self->{_values};
207 :     my $retValRef = $fieldHash->{$attributeName};
208 :     Trace("retValRef for $attributeName is \"$retValRef\".") if T(Fields => 3);
209 :     if (defined $retValRef) {
210 :     # Here we have the field already, so return it.
211 :     @retVal = @{$retValRef};
212 :     } else {
213 :     # Here the field is not in the hash. If we don't have a database, we are
214 :     # done. The user will automatically get an empty list handed back to him.
215 :     if (exists $self->{_db}) {
216 :     # We have a database, so we can look for the value in a secondary relation.
217 :     # We start by getting the object name and the attribute name. Note
218 :     # that the object must be an entity, since relationships don't have
219 :     # secondary relations.
220 :     $attributeName =~ /^([^(]*)\(([^)]*)\)/;
221 :     my ($entityName, $fieldName) = ($1, $2);
222 :     my $entityData = $self->{_db}->{_metaData}->{Entities}->{$entityName};
223 :     # Determine the name of the relation that contains this field.
224 :     my $relationName = $entityData->{Fields}->{$fieldName}->{relation};
225 :     # Get the actual name of the field.
226 :     my $fixedFieldName = ERDB::_FixName($fieldName);
227 :     # Get the entity instance's ID.
228 :     my $id = $fieldHash->{"$entityName(id)"}->[0];
229 :     # Create the SELECT statement for the desired relation and execute it.
230 :     my $command = "SELECT $fixedFieldName FROM $relationName WHERE id = ?";
231 :     Trace("SQL subquery for '$id': $command") if T(SQL => 4);
232 :     my $sth = $self->{_db}->{_dbh}->prepare_command($command);
233 :     $sth->execute($id) || Confess("Subquery for $attributeName failed: " . $sth->errstr);
234 :     # Loop through the query results creating a list of the values found.
235 :     my $rows = $sth->fetchall_arrayref;
236 :     for my $row (@{$rows}) {
237 :     # Note we un-escape the value before stuffing it in the result list.
238 :     my $realValue = Tracer::UnEscape($row->[0]);
239 :     push @retVal, $row->[0];
240 :     }
241 :     # Put the list in the field hash for future use.
242 :     $fieldHash->{"$entityName($fieldName)"} = \@retVal;
243 :     }
244 :     }
245 :     # Return the field values found.
246 :     return @retVal;
247 :     }
248 :    
249 :     =head3 Values
250 :    
251 :     C<< my @values = $dbObject->Values(\@attributeNames); >>
252 :    
253 :     This method returns a list of all the values for a list of field specifiers. Essentially, it calls
254 :     the L</Value> method for each element in the parameter list and returns a flattened list of all
255 :     the results.
256 :    
257 :     For example, let us say that C<$feature> contains a feature with two aliases and a translation.
258 :     The following call will put the aliases in C<$alias1> and C<$alias2> and the translation in
259 :     C<$translation>.
260 :    
261 :     C<< my ($alias1, $alias2, $translation) = $feature->Values(['Feature(alias)', 'Feature(translation)']); >>
262 :    
263 :     =over 4
264 :    
265 :     =item attributeNames
266 :    
267 :     List of attribute names.
268 :    
269 :     =item RETURN
270 :    
271 :     Returns a flattened list of all the results found for each specified field.
272 :    
273 :     =back
274 :    
275 :     =cut
276 :    
277 :     sub Values {
278 :     # Get the parameters.
279 :     my ($self, $attributeNames) = @_;
280 :     # Create the return list.
281 :     my @retVal = ();
282 :     # Loop through the specifiers, pushing their values into the return list.
283 :     for my $specifier (@{$attributeNames}) {
284 :     push @retVal, $self->Value($specifier);
285 :     }
286 :     # Return the resulting list.
287 :     return @retVal;
288 :     }
289 :    
290 :     =head3 Cross
291 :    
292 :     C<< my $query = $dbObject->Cross($relationshipName, $filterClause, $param1, $param2, ... $paramN); >>
293 :    
294 :     Return a query object for instances related to this one via a specified relationship.
295 :    
296 :     =over 4
297 :    
298 :     =item relationshipName
299 :    
300 :     Name of the relationship to cross.
301 :    
302 :     =item filterClause
303 :    
304 :     WHERE clause (without the WHERE) to be used to filter the query. The WHERE clause can be
305 :     parameterized with parameter markers (C<?>). Each field used in the WHERE clause must be
306 :     specified in the standard form B<I<objectName>(I<fieldName>)>.
307 :    
308 :     =item param1, param2, ..., paramN
309 :    
310 :     Parameters for the filter clause.
311 :    
312 :     =back
313 :    
314 :     =cut
315 :    
316 :     sub Cross {
317 :     # Get the parameters.
318 :     my ($self, $relationshipName, $filterClause, @params) = @_;
319 :     # Make sure the filter clause is not undefined. Empty is okay, just not undefined.
320 :     if (! defined($filterClause)) {
321 :     $filterClause = "";
322 :     }
323 :     # Get access to the key metadata structures.
324 :     my $db = $self->{_db};
325 :     my $metadata = $db->{_metaData};
326 :     my $entities = $metadata->{Entities};
327 :     my $relationships = $metadata->{Relationships};
328 :     # Determine whether we are using the from-link or the to-link, and get the name of the
329 :     # entity on the other side of the relationship.
330 :     my ($startLinkName, $targetLinkName, $targetEntity);
331 :     my $relationship = $relationships->{$relationshipName};
332 :     my $startingEntity = $self->{_targetEntity};
333 :     if ($relationship->{from} eq $startingEntity) {
334 :     # Here we're starting at the FROM entity.
335 :     $startLinkName = "$relationshipName(from-link)";
336 :     $targetEntity = $relationship->{to};
337 :     } else {
338 :     # Here we're starting at the TO entity.
339 :     $startLinkName = "$relationshipName(to-link)";
340 :     $targetEntity = $relationship->{from};
341 :     }
342 :     # Get the ID of the starting instance.
343 :     my ($id) = $self->Value("$startingEntity(id)");
344 :     # Create the WHERE clause.
345 :     my $superFilter = "$startLinkName = ?";
346 :     # Analyze the filter clause. We need to pull out any strings and put them in parameters.
347 :     # Then we need to look for ORDER BY and LIMIT to position any parentheses we need. This
348 :     # will require a major parse of the filter string. The first step is to find the last
349 :     # single quote. Note that if there are no quotes, this will return -1.
350 :     my $lastQuote = rindex $filterClause, "'";
351 :     # Compute the position in the string after the last quote. All our searches will start
352 :     # from there.
353 :     my $startPos = $lastQuote + 1;
354 :     # Look for ORDER BY.
355 :     my $orderBy = index $filterClause, "ORDER BY", $startPos;
356 :     # Look for LIMIT.
357 :     my $limit = index $filterClause, "LIMIT", $startPos;
358 :     # Choose the first of these two clauses. That's where the real filter ends.
359 :     my $addendaPos = ($orderBy < 0 ? $limit : ($limit < 0 ? $orderBy :
360 :     ($orderBy < $limit ? $orderBy : $limit)));
361 :     # We have four cases: no ORDER BY or LIMIT, only ORDER BY or LIMIT, no filter at
362 :     # all, or ORDER BY or LIMIT present in the middle of the filter string. If we're
363 :     # only ORDER BY or LIMIT , no additional parentheses are needed. Similarly if there's
364 :     # no filter string at all. Hwever, in the other cases we need to put
365 :     # parentheses around the WHERE part of the filter.
366 :     if ($addendaPos < 0 && length($filterClause) > 0) {
367 :     # No ORDER BY or LIMIT: parentheses surround the whole clause.
368 :     $filterClause = "AND ($filterClause)";
369 :     } elsif ($addendaPos > 0) {
370 :     # Open parentheses at the beginning, and close them right before the ORDER BY
371 :     # or LIMIT part.
372 :     $filterClause = "AND (" . substr($filterClause, 0, $addendaPos) . ") " .
373 :     substr($filterClause, $addendaPos);
374 :     }
375 :     # Add the incoming filter to the filter we've built.
376 :     $superFilter .= " $filterClause";
377 :     # Create a relation-crossing query and return it.
378 :     Trace("Calling GET from CROSS. Filter is $superFilter.") if T(4);
379 :     my $retVal = $db->Get([$relationshipName, $targetEntity], $superFilter, [$id, @params]);
380 :     return $retVal;
381 :     }
382 :    
383 :     =head3 IsNew
384 :    
385 :     C<< my $boolean = $dbObject->IsNew(); >>
386 :    
387 :     Return TRUE if this is a new object inserted into the database, or FALSE if it was loaded from
388 :     the input data files.
389 :    
390 :     =cut
391 :    
392 :     sub IsNew {
393 :     # Get the parameters.
394 :     my ($self) = @_;
395 :     return $self->{_newObjectFlag};
396 :     }
397 :    
398 :     =head2 Utility Methods
399 :    
400 :     =head3 _new
401 :    
402 :     Create a new instance object.
403 :    
404 :     This is a static method.
405 :    
406 :     =over 4
407 :    
408 :     =item dbquery
409 :    
410 :     B<DBQuery> object for the relevant query.
411 :    
412 :     =item value, value2, ... valueN
413 :    
414 :     List of values returned by the query for the current object.
415 :    
416 :     =back
417 :    
418 :     =cut
419 :    
420 :     sub _new {
421 :     # Get the parameters.
422 :     my ($dbquery, @values) = @_;
423 :     # Pull out the ERDB object and the relationship map.
424 :     my $database = $dbquery->{_db};
425 :     my $relationMap = $dbquery->{_objectNames};
426 :     # Get the metadata.
427 :     my $metadata = $database->{_metaData};
428 :     my $entities = $metadata->{Entities};
429 :     my $relationships = $metadata->{Relationships};
430 :     # This variable will be used to save the name of the last entity in the object list.
431 :     # That entity is the one we'll start from when crossing relationships.
432 :     my $target;
433 :     # Create the field hash table.
434 :     my %fieldHash = ();
435 :     # Check for search relevance.
436 :     if ($dbquery->{_fullText}) {
437 :     # Create the special search relevance field from the first element of the row values.
438 :     # Note that the object name is the value of the _fullText property.
439 :     my $relevanceName = "$dbquery->{_fullText}(search-relevance)";
440 :     $fieldHash{$relevanceName} = [shift @values];
441 :     }
442 :     # Denote that so far this does not appear to be a new object (as opposed to a loaded object).
443 :     my $newObjectFlag = 0;
444 :     # Loop through the object names, extracting its fields. We will strip each field from
445 :     # the value array and add it to the hash table using the ERDB-format field name.
446 :     for my $mappingPair (@{$relationMap}) {
447 :     # Get the real object name for this mapped name.
448 :     my ($mappedObjectName, $objectName) = @{$mappingPair};
449 :     # Declare the variable to hold the field list and the entity flag.
450 :     my ($fieldList, $entityFlag);
451 :     # Get the descriptor for this object.
452 :     my $objectDescriptor = $entities->{$objectName};
453 :     if ($objectDescriptor) {
454 :     # Here we have an entity object.
455 :     $target = $objectName;
456 :     $fieldList = $objectDescriptor->{Relations}->{$objectName}->{Fields};
457 :     $entityFlag = 1;
458 :     } else {
459 :     $objectDescriptor = $relationships->{$objectName};
460 :     if ($objectDescriptor) {
461 :     # Here we have a relationship object.
462 :     $fieldList = $objectDescriptor->{Relations}->{$objectName}->{Fields};
463 :     $entityFlag = 0;
464 :     } else {
465 :     Confess("Object $objectName not found in database.");
466 :     }
467 :     }
468 :     # Loop through the field list.
469 :     for my $field (@{$fieldList}) {
470 :     # Get the current value from the array.
471 :     my $thisValue = shift @values;
472 :     # Un-escape its text.
473 :     my $realValue = Tracer::UnEscape($thisValue);
474 :     # Get the current field's name.
475 :     my $fieldName = $field->{name};
476 :     # Add the field's name and value to the hash table.
477 :     my $fieldKey = "$mappedObjectName($fieldName)";
478 :     $fieldHash{$fieldKey} = [$realValue];
479 :     Trace("$fieldKey = '$thisValue'") if T(Fields => 3);
480 :     }
481 :     # Save the new-object flag.
482 :     $newObjectFlag = shift @values;
483 :     }
484 :     # Create the result object.
485 :     my $self = { _db => $database, _targetEntity => $target, _values => \%fieldHash,
486 :     _newObjectFlag => $newObjectFlag };
487 :     # Bless and return it.
488 :     bless $self;
489 :     return $self;
490 :     }
491 :    
492 :     1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3