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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : parrello 1.1 #!/usr/bin/perl -w
2 :    
3 :     package CustomAttributes;
4 :    
5 :     require Exporter;
6 :     use ERDB;
7 :     @ISA = qw(Exporter ERDB);
8 : parrello 1.3 @EXPORT = qw(GetAttributes AddAttribute DeleteAttribute ChangeAttribute MatchSqlPattern);
9 : parrello 1.1 use strict;
10 :     use Tracer;
11 :     use FIG;
12 :     use ERDBLoad;
13 :    
14 :     =head1 Custom SEED Attribute Manager
15 :    
16 :     =head2 Introduction
17 :    
18 :     The Custom SEED Attributes Manager allows the user to upload and retrieve
19 :     custom data for SEED objects. It uses the B<ERDB> database system to
20 :     store the attributes, which are implemented as multi-valued fields
21 :     of ERDB entities.
22 :    
23 :     The full suite of ERDB retrieval capabilities is provided. In addition,
24 :     custom methods are provided specific to this application. To get all
25 :     the values of the attribute C<essential> in the B<Feature> entity, you
26 :     would code
27 :    
28 : parrello 1.3 my @values = $attrDB->GetAttributeValues($fid, Feature => 'essential');
29 : parrello 1.1
30 : parrello 1.2 where I<$fid> contains the ID of the desired feature. Each attribute has
31 :     an alternate index to allow searching for attributes by value.
32 : parrello 1.1
33 :     New attributes are introduced by updating the database definition at
34 :     run-time. Attribute values are stored by uploading data from files.
35 :     A web interface is provided for both these activities.
36 :    
37 :     =head2 FIG_Config Parameters
38 :    
39 :     The following configuration parameters are used to manage custom attributes.
40 :    
41 :     =over 4
42 :    
43 :     =item attrDbms
44 :    
45 :     Type of database manager used: C<mysql> for MySQL or C<pg> for PostGres.
46 :    
47 :     =item attrDbName
48 :    
49 :     Name of the attribute database.
50 :    
51 :     =item attrHost
52 :    
53 :     Name of the host server for the database. If omitted, the current host
54 :     is used.
55 :    
56 :     =item attrUser
57 :    
58 :     User name for logging in to the database.
59 :    
60 :     =item attrPass
61 :    
62 :     Password for logging in to the database.
63 :    
64 :     =item attrPort
65 :    
66 :     TCP/IP port for accessing the database.
67 :    
68 :     =item attrSock
69 :    
70 :     Socket name used to access the database. If omitted, the default socket
71 :     will be used.
72 :    
73 :     =item attrDBD
74 :    
75 :     Fully-qualified file name for the database definition XML file. This file
76 :     functions as data to the attribute management process, so if the data is
77 :     moved, this file must go with it.
78 :    
79 :     =back
80 :    
81 : parrello 1.3 =head2 Implementation Note
82 : parrello 1.1
83 :     The L</Refresh> method reloads the entities in the database. If new
84 :     entity types are added, that method will need to be adjusted accordingly.
85 :    
86 :     =head2 Public Methods
87 :    
88 :     =head3 new
89 :    
90 : parrello 1.3 C<< my $attrDB = CustomAttributes->new($splitter); >>
91 : parrello 1.1
92 : parrello 1.3 Construct a new CustomAttributes object. This object cannot be used to add or
93 :     delete keys because that requires modifying the database design. To do that,
94 :     you need to use the static L</StoreAttributeKey> or L</DeleteAttributeKey>
95 :     methods.
96 :    
97 :     =over 4
98 :    
99 :     =item splitter
100 :    
101 :     Value to be used to split attribute values into sections in the
102 :     L</Fig Replacement Methods>. The default is a double colon C<::>.
103 :     If you do not use the replacement methods, you do not need to
104 :     worry about this parameter.
105 :    
106 :     =back
107 : parrello 1.1
108 :     =cut
109 :    
110 :     sub new {
111 :     # Get the parameters.
112 : parrello 1.3 my ($class, $splitter) = @_;
113 : parrello 1.1 # Connect to the database.
114 :     my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
115 :     $FIG_Config::attrUser, $FIG_Config::attrPass,
116 :     $FIG_Config::attrPort, $FIG_Config::attrHost,
117 :     $FIG_Config::attrSock);
118 :     # Create the ERDB object.
119 :     my $xmlFileName = $FIG_Config::attrDBD;
120 :     my $retVal = ERDB::new($class, $dbh, $xmlFileName);
121 : parrello 1.3 # Store the splitter value.
122 :     $retVal->{splitter} = (defined($splitter) ? $splitter : '::');
123 : parrello 1.1 # Return the result.
124 :     return $retVal;
125 :     }
126 :    
127 : parrello 1.3 =head3 GetAttributeValues
128 : parrello 1.1
129 : parrello 1.3 C<< my @values = $attrDB->GetAttributeValues($id, $entityName => $attributeName); >>
130 : parrello 1.1
131 :     Return all the values of the specified attribute for the specified entity instance.
132 :     A list of vaues will be returned. If the entity instance does not exist or the
133 :     attribute has no values, an empty list will be returned. If the attribute name
134 :     does not exist, an SQL error will occur.
135 :    
136 :     A typical invocation would look like this:
137 :    
138 : parrello 1.3 my @values = $sttrDB->GetAttributeValues($fid, Feature => 'essential');
139 : parrello 1.1
140 :     Here the user is asking for the values of the C<essential> attribute for the
141 :     B<Feature> with the specified ID. If the identified feature is not essential,
142 :     the list returned will be empty. If it is essential, then one or more values
143 :     will be returned that describe the essentiality.
144 :    
145 :     =over 4
146 :    
147 :     =item id
148 :    
149 :     ID of the desired entity instance. This identifies the specific object to
150 :     be interrogated for attribute values.
151 :    
152 :     =item entityName
153 :    
154 :     Name of the entity. This identifies the the type of the object to be
155 :     interrogated for attribute values.
156 :    
157 :     =item attributeName
158 :    
159 :     Name of the desired attribute.
160 :    
161 :     =item RETURN
162 :    
163 :     Returns zero or more strings, each representing a value of the named attribute
164 :     for the specified entity instance.
165 :    
166 :     =back
167 :    
168 :     =cut
169 :    
170 : parrello 1.3 sub GetAttributeValues {
171 : parrello 1.1 # Get the parameters.
172 :     my ($self, $id, $entityName, $attributeName) = @_;
173 :     # Get the data.
174 :     my @retVal = $self->GetEntityValues($entityName, $id, ["$entityName($attributeName)"]);
175 :     # Return the result.
176 :     return @retVal;
177 :     }
178 :    
179 : parrello 1.3 =head3 StoreAttributeKey
180 : parrello 1.1
181 : parrello 1.3 C<< my $attrDB = CustomAttributes::StoreAttributeKey($entityName, $attributeName, $type, $notes); >>
182 : parrello 1.1
183 :     Create or update an attribute for the database. This method will update the database definition
184 :     XML, but it will not create the table. It will connect to the database so that the caller
185 :     can upload the attribute values.
186 :    
187 :     =over 4
188 :    
189 :     =item entityName
190 :    
191 :     Name of the entity containing the attribute. The entity must exist.
192 :    
193 :     =item attributeName
194 :    
195 :     Name of the attribute. It must be a valid ERDB field name, consisting entirely of
196 :     letters, digits, and hyphens, with a letter at the beginning. If it does not
197 :     exist already, it will be created.
198 :    
199 :     =item type
200 :    
201 :     Data type of the attribute. This must be a valid ERDB data type name.
202 :    
203 :     =item notes
204 :    
205 :     Descriptive notes about the attribute. It is presumed to be raw text, not HTML.
206 :    
207 :     =item RETURN
208 :    
209 :     Returns a Custom Attribute Database object if successful. If unsuccessful, an
210 :     error will be thrown.
211 :    
212 :     =back
213 :    
214 :     =cut
215 :    
216 : parrello 1.3 sub StoreAttributeKey {
217 : parrello 1.1 # Get the parameters.
218 :     my ($entityName, $attributeName, $type, $notes) = @_;
219 :     # Get the data type hash.
220 :     my %types = ERDB::GetDataTypes();
221 :     # Validate the initial input values.
222 :     if (! ERDB::ValidateFieldName($attributeName)) {
223 :     Confess("Invalid attribute name \"$attributeName\" specified.");
224 :     } elsif (! $notes || length($notes) < 25) {
225 :     Confess("Missing or incomplete description for $attributeName.");
226 :     } elsif (! exists $types{$type}) {
227 :     Confess("Invalid data type \"$type\" for $attributeName.");
228 :     }
229 :     # Our next step is to read in the XML for the database defintion. We
230 :     # need to verify that the named entity exists.
231 :     my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);
232 :     my $entityHash = $metadata->{Entities};
233 :     if (! exists $entityHash->{$entityName}) {
234 :     Confess("Entity $entityName not found.");
235 :     } else {
236 : parrello 1.2 # Okay, we're ready to begin. Get the entity hash and the field hash.
237 :     my $entityData = $entityHash->{$entityName};
238 : parrello 1.1 my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);
239 :     # Compute the attribute's relation name.
240 : parrello 1.3 my $relName = join("", $entityName, map { ucfirst $_ } split(/-|_/, $attributeName));
241 : parrello 1.1 # Store the attribute's field data. Note the use of the "content" hash for
242 :     # the notes. This is how the XML writer knows Notes is a text tag instead of
243 :     # an attribute.
244 :     $fieldHash->{$attributeName} = { type => $type, relation => $relName,
245 :     Notes => { content => $notes } };
246 : parrello 1.2 # Insure we have an index for this attribute.
247 :     my $index = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);
248 :     if (! defined($index)) {
249 :     push @{$entityData->{Indexes}}, { IndexFields => [ { name => $attributeName, order => 'ascending' } ],
250 :     Notes => "Alternate index provided for access by $attributeName." };
251 :     }
252 : parrello 1.1 # Write the XML back out.
253 :     ERDB::WriteMetaXML($metadata, $FIG_Config::attrDBD);
254 :     }
255 :     # Open a database with the new XML.
256 :     my $retVal = CustomAttributes->new();
257 :     return $retVal;
258 :     }
259 :    
260 :     =head3 Refresh
261 :    
262 : parrello 1.3 C<< $attrDB->Refresh($fig); >>
263 : parrello 1.1
264 :     Refresh the primary entity tables from the FIG data store. This method basically
265 :     drops and reloads the main tables of the custom attributes database.
266 :    
267 : parrello 1.3 =over 4
268 :    
269 :     =item fig
270 :    
271 :     FIG-like object that can be used to find genomes and features.
272 :    
273 :     =back
274 :    
275 : parrello 1.1 =cut
276 :    
277 :     sub Refresh {
278 :     # Get the parameters.
279 : parrello 1.3 my ($self, $fig) = @_;
280 : parrello 1.1 # Create load objects for the genomes and the features.
281 :     my $loadGenome = ERDBLoad->new($self, 'Genome', $FIG_Config::temp);
282 :     my $loadFeature = ERDBLoad->new($self, 'Feature', $FIG_Config::temp);
283 :     # Get the genome list.
284 :     my @genomes = $fig->genomes();
285 :     # Loop through the genomes.
286 :     for my $genomeID (@genomes) {
287 :     # Put this genome in the genome table.
288 :     $loadGenome->Put($genomeID);
289 :     Trace("Processing Genome $genomeID") if T(3);
290 :     # Put its features into the feature table. Note we have to use a hash to
291 :     # remove duplicates.
292 :     my %featureList = map { $_ => 1 } $fig->all_features($genomeID);
293 :     for my $fid (keys %featureList) {
294 :     $loadFeature->Put($fid);
295 :     }
296 :     }
297 :     # Get a variable for holding statistics objects.
298 :     my $stats;
299 :     # Finish the genome load.
300 :     Trace("Loading Genome relation.") if T(2);
301 :     $stats = $loadGenome->FinishAndLoad();
302 :     Trace("Genome table load statistics:\n" . $stats->Show()) if T(3);
303 :     # Finish the feature load.
304 :     Trace("Loading Feature relation.") if T(2);
305 :     $stats = $loadFeature->FinishAndLoad();
306 :     Trace("Feature table load statistics:\n" . $stats->Show()) if T(3);
307 :     }
308 :    
309 : parrello 1.3 =head3 LoadAttributeKey
310 : parrello 1.1
311 : parrello 1.3 C<< my $stats = $attrDB->LoadAttributeKey($entityName, $fieldName, $fh, $keyCol, $dataCol); >>
312 : parrello 1.1
313 :     Load the specified attribute from the specified file. The file should be a
314 :     tab-delimited file with internal tab and new-line characters escaped. This is
315 :     the typical TBL-style file used by most FIG applications. One of the columns
316 :     in the input file must contain the appropriate key value and the other the
317 :     corresponding attribute value.
318 :    
319 :     =over 4
320 :    
321 :     =item entityName
322 :    
323 :     Name of the entity containing the attribute.
324 :    
325 :     =item fieldName
326 :    
327 :     Name of the actual attribute.
328 :    
329 :     =item fh
330 :    
331 :     Open file handle for the input file.
332 :    
333 :     =item keyCol
334 :    
335 :     Index (0-based) of the column containing the key field. The key field should
336 :     contain the ID of an instance of the named entity.
337 :    
338 :     =item dataCol
339 :    
340 :     Index (0-based) of the column containing the data value field.
341 :    
342 :     =item RETURN
343 :    
344 :     Returns a statistics object for the load process.
345 :    
346 :     =back
347 :    
348 :     =cut
349 :    
350 : parrello 1.3 sub LoadAttributeKey {
351 : parrello 1.1 # Get the parameters.
352 :     my ($self, $entityName, $fieldName, $fh, $keyCol, $dataCol) = @_;
353 :     # Create the return variable.
354 :     my $retVal;
355 :     # Insure the entity exists.
356 :     my $found = grep { $_ eq $entityName } $self->GetEntityTypes();
357 :     if (! $found) {
358 :     Confess("Entity \"$entityName\" not found in database.");
359 :     } else {
360 :     # Get the field structure for the named entity.
361 :     my $fieldHash = $self->GetFieldTable($entityName);
362 :     # Verify that the attribute exists.
363 :     if (! exists $fieldHash->{$fieldName}) {
364 : parrello 1.3 Confess("Attribute key \"$fieldName\" does not exist in entity $entityName.");
365 : parrello 1.1 } else {
366 :     # Create a loader for the specified attribute. We need the
367 :     # relation name first.
368 :     my $relName = $fieldHash->{$fieldName}->{relation};
369 :     my $loadAttribute = ERDBLoad->new($self, $relName, $FIG_Config::temp);
370 :     # Loop through the input file.
371 :     while (! eof $fh) {
372 :     # Get the next line of the file.
373 :     my @fields = Tracer::GetLine($fh);
374 :     $loadAttribute->Add("lineIn");
375 :     # Now we need to validate the line.
376 :     if ($#fields < $dataCol) {
377 :     $loadAttribute->Add("shortLine");
378 :     } elsif (! $self->Exists($entityName, $fields[$keyCol])) {
379 :     $loadAttribute->Add("badKey");
380 :     } else {
381 :     # It's valid,so send it to the loader.
382 :     $loadAttribute->Put($fields[$keyCol], $fields[$dataCol]);
383 :     $loadAttribute->Add("lineUsed");
384 :     }
385 :     }
386 :     # Finish the load.
387 :     $retVal = $loadAttribute->FinishAndLoad();
388 :     }
389 :     }
390 :     # Return the statistics.
391 :     return $retVal;
392 :     }
393 :    
394 :    
395 : parrello 1.3 =head3 DeleteAttributeKey
396 :    
397 :     C<< CustomAttributes::DeleteAttributeKey($entityName, $attributeName); >>
398 : parrello 1.1
399 :     Delete an attribute from the custom attributes database.
400 :    
401 :     =over 4
402 :    
403 :     =item entityName
404 :    
405 :     Name of the entity possessing the attribute.
406 :    
407 :     =item attributeName
408 :    
409 :     Name of the attribute to delete.
410 :    
411 :     =back
412 :    
413 :     =cut
414 :    
415 : parrello 1.3 sub DeleteAttributeKey {
416 : parrello 1.1 # Get the parameters.
417 :     my ($entityName, $attributeName) = @_;
418 :     # Read in the XML for the database defintion. We need to verify that
419 :     # the named entity exists and it has the named attribute.
420 :     my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);
421 :     my $entityHash = $metadata->{Entities};
422 :     if (! exists $entityHash->{$entityName}) {
423 :     Confess("Entity \"$entityName\" not found.");
424 :     } else {
425 :     # Get the field hash.
426 :     my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);
427 :     if (! exists $fieldHash->{$attributeName}) {
428 : parrello 1.3 Confess("Attribute key \"$attributeName\" not found in entity $entityName.");
429 : parrello 1.1 } else {
430 :     # Get the attribute's relation name.
431 :     my $relName = $fieldHash->{$attributeName}->{relation};
432 : parrello 1.2 # Check for an index.
433 :     my $indexIdx = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);
434 :     if (defined($indexIdx)) {
435 :     Trace("Index for $attributeName found at position $indexIdx for $entityName.") if T(3);
436 :     delete $entityHash->{$entityName}->{Indexes}->[$indexIdx];
437 :     }
438 : parrello 1.1 # Delete the attribute from the field hash.
439 :     Trace("Deleting attribute $attributeName from $entityName.") if T(3);
440 :     delete $fieldHash->{$attributeName};
441 :     # Write the XML back out.
442 :     ERDB::WriteMetaXML($metadata, $FIG_Config::attrDBD);
443 :     # Insure the relation does not exist in the database. This requires connecting
444 :     # since we may have to do a table drop.
445 :     my $attrDB = CustomAttributes->new();
446 : parrello 1.2 Trace("Dropping table $relName.") if T(3);
447 : parrello 1.1 $attrDB->DropRelation($relName);
448 :     }
449 :     }
450 :     }
451 :    
452 :     =head3 ControlForm
453 :    
454 :     C<< my $formHtml = $attrDB->ControlForm($cgi, $name); >>
455 :    
456 :     Return a form that can be used to control the creation and modification of
457 :     attributes.
458 :    
459 :     =over 4
460 :    
461 :     =item cgi
462 :    
463 :     CGI query object used to create HTML.
464 :    
465 :     =item name
466 :    
467 :     Name to give to the form. This should be unique for the web page.
468 :    
469 :     =item RETURN
470 :    
471 :     Returns the HTML for a form that submits instructions to the C<Attributes.cgi> script
472 :     for loading, creating, or deleting an attribute.
473 :    
474 :     =back
475 :    
476 :     =cut
477 :    
478 :     sub ControlForm {
479 :     # Get the parameters.
480 :     my ($self, $cgi, $name) = @_;
481 :     # Declare the return list.
482 :     my @retVal = ();
483 :     # Start the form. We use multipart to support the upload control.
484 :     push @retVal, $cgi->start_multipart_form(-name => $name);
485 :     # We'll put the controls in a table. Nothing else ever seems to look nice.
486 :     push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });
487 :     # The first row is for selecting the field name.
488 :     push @retVal, $cgi->Tr($cgi->th("Select a Field"),
489 :     $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', 1,
490 :     "document.$name.notes.value",
491 :     "document.$name.dataType.value")));
492 :     # Now we set up a dropdown for the data types. The values will be the
493 :     # data type names, and the labels will be the descriptions.
494 :     my %types = ERDB::GetDataTypes();
495 :     my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;
496 :     my $typeMenu = $cgi->popup_menu(-name => 'dataType',
497 :     -values => [sort keys %types],
498 :     -labels => \%labelMap);
499 :     push @retVal, $cgi->Tr($cgi->th("Data type"),
500 :     $cgi->td($typeMenu));
501 :     # The next row is for the notes.
502 :     push @retVal, $cgi->Tr($cgi->th("Description"),
503 :     $cgi->td($cgi->textarea(-name => 'notes',
504 :     -rows => 6,
505 :     -columns => 80))
506 :     );
507 :     # Allow the user to specify a new field name. This is required if the
508 :     # user has selected one of the "(new)" markers.
509 :     push @retVal, $cgi->Tr($cgi->th("New Field Name"),
510 :     $cgi->td($cgi->textfield(-name => 'newName',
511 :     -size => 30)),
512 :     );
513 :     # If the user wants to upload new values for the field, then we have
514 :     # an upload file name and column indicators.
515 :     push @retVal, $cgi->Tr($cgi->th("Upload Values"),
516 :     $cgi->td($cgi->filefield(-name => 'newValueFile',
517 :     -size => 20) .
518 :     " Key&nbsp;" .
519 :     $cgi->textfield(-name => 'keyCol',
520 :     -size => 3,
521 :     -default => 0) .
522 :     " Value&nbsp;" .
523 :     $cgi->textfield(-name => 'valueCol',
524 :     -size => 3,
525 :     -default => 1)
526 :     ),
527 :     );
528 :     # Now the two buttons: UPDATE and DELETE.
529 :     push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
530 :     $cgi->td({align => 'center'},
531 :     $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .
532 :     $cgi->submit(-name => 'Store', -value => 'STORE')
533 :     )
534 :     );
535 :     # Close the table and the form.
536 :     push @retVal, $cgi->end_table();
537 :     push @retVal, $cgi->end_form();
538 :     # Return the assembled HTML.
539 :     return join("\n", @retVal, "");
540 :     }
541 :    
542 :     =head3 FieldMenu
543 :    
544 :     C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $newFlag, $noteControl, $typeControl); >>
545 :    
546 :     Return the HTML for a menu to select an attribute field. The menu will
547 :     be a standard SELECT/OPTION thing which is called "popup menu" in the
548 :     CGI package, but actually looks like a list. The list will contain
549 :     one selectable row per field, grouped by entity.
550 :    
551 :     =over 4
552 :    
553 :     =item cgi
554 :    
555 :     CGI query object used to generate HTML.
556 :    
557 :     =item height
558 :    
559 :     Number of lines to display in the list.
560 :    
561 :     =item name
562 :    
563 :     Name to give to the menu. This is the name under which the value will
564 :     appear when the form is submitted.
565 :    
566 :     =item newFlag (optional)
567 :    
568 :     If TRUE, then extra rows will be provided to allow the user to select
569 :     a new attribute. In other words, the user can select an existing
570 :     attribute, or can choose a C<(new)> marker to indicate a field to
571 :     be created in the parent entity.
572 :    
573 :     =item noteControl (optional)
574 :    
575 :     If specified, the name of a variable for displaying the notes attached
576 :     to the field. This must be in Javascript form ready for assignment.
577 :     So, for example, if you have a variable called C<notes> that
578 :     represents a paragraph element, you should code C<notes.innerHTML>.
579 :     If it actually represents a form field you should code C<notes.value>.
580 :     If an C<innerHTML> coding is used, the text will be HTML-escaped before
581 :     it is copied in. Specifying this parameter generates Javascript for
582 :     displaying the field description when a field is selected.
583 :    
584 :     =item typeControl (optional)
585 :    
586 :     If specified, the name of a variable for displaying the field's
587 :     data type. Data types are a much more controlled vocabulary than
588 :     notes, so there is no worry about HTML translation. Instead, the
589 :     raw value is put into the specified variable. Otherwise, the same
590 :     rules apply to this value that apply to I<$noteControl>.
591 :    
592 :     =item RETURN
593 :    
594 :     Returns the HTML to create a form field that can be used to select an
595 :     attribute from the custom attributes system.
596 :    
597 :     =back
598 :    
599 :     =cut
600 :    
601 :     sub FieldMenu {
602 :     # Get the parameters.
603 :     my ($self, $cgi, $height, $name, $newFlag, $noteControl, $typeControl) = @_;
604 :     # These next two hashes make everything happen. "entities"
605 :     # maps each entity name to the list of values to be put into its
606 :     # option group. "labels" maps each entity name to a map from values
607 :     # to labels.
608 :     my @entityNames = sort ($self->GetEntityTypes());
609 :     my %entities = map { $_ => [] } @entityNames;
610 :     my %labels = map { $_ => { }} @entityNames;
611 :     # Loop through the entities, adding the existing attributes.
612 :     for my $entity (@entityNames) {
613 :     # Get this entity's field table.
614 :     my $fieldHash = $self->GetFieldTable($entity);
615 :     # Get its field list in our local hashes.
616 :     my $fieldList = $entities{$entity};
617 :     my $labelList = $labels{$entity};
618 :     # Add the NEW fields if we want them.
619 :     if ($newFlag) {
620 :     push @{$fieldList}, $entity;
621 :     $labelList->{$entity} = "(new)";
622 :     }
623 :     # Loop through the fields in the hash. We only keep the ones with a
624 :     # secondary relation name. (In other words, the name of the relation
625 :     # in which the field appears cannot be the same as the entity name.)
626 :     for my $fieldName (sort keys %{$fieldHash}) {
627 :     if ($fieldHash->{$fieldName}->{relation} ne $entity) {
628 :     my $value = "$entity/$fieldName";
629 :     push @{$fieldList}, $value;
630 :     $labelList->{$value} = $fieldName;
631 :     }
632 :     }
633 :     }
634 :     # Now we have a hash and a list for each entity, and they correspond
635 :     # exactly to what the $cgi->optgroup function expects.
636 :     # The last step is to create the name for the onChange function. This function
637 :     # may not do anything, but we need to know the name to generate the HTML
638 :     # for the menu.
639 :     my $changeName = "${name}_setNotes";
640 :     my $retVal = $cgi->popup_menu({name => $name,
641 :     size => $height,
642 :     onChange => "$changeName(this.value)",
643 :     values => [map { $cgi->optgroup(-name => $_,
644 :     -values => $entities{$_},
645 :     -labels => $labels{$_})
646 :     } @entityNames]}
647 :     );
648 :     # Create the change function.
649 :     $retVal .= "\n<script language=\"javascript\">\n";
650 :     $retVal .= " function $changeName(fieldValue) {\n";
651 :     # The function only has a body if we have a notes control to store the description.
652 :     if ($noteControl || $typeControl) {
653 :     # Check to see if we're storing HTML or text into the note control.
654 :     my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);
655 :     # We use a CASE statement based on the newly-selected field value. The
656 :     # field description will be stored in the JavaScript variable "myText"
657 :     # and the data type in "myType". Note the default data type is a normal
658 :     # string, but the default notes is an empty string.
659 :     $retVal .= " var myText = \"\";\n";
660 :     $retVal .= " var myType = \"string\";\n";
661 :     $retVal .= " switch (fieldValue) {\n";
662 :     # Loop through the entities.
663 :     for my $entity (@entityNames) {
664 :     # Get the entity's field hash. This has the notes in it.
665 :     my $fieldHash = $self->GetFieldTable($entity);
666 :     # Loop through the values we might see for this entity's fields.
667 :     my $fields = $entities{$entity};
668 :     for my $value (@{$fields}) {
669 :     # Only proceed if we have an existing field.
670 :     if ($value =~ m!/(.+)$!) {
671 :     # Get the field's hash element.
672 :     my $element = $fieldHash->{$1};
673 :     # Generate this case.
674 :     $retVal .= " case \"$value\" :\n";
675 :     # Here we either want to update the note display, the
676 :     # type display, or both.
677 :     if ($noteControl) {
678 :     # Here we want the notes updated.
679 :     my $notes = $element->{Notes}->{content};
680 :     # Insure it's in the proper form.
681 :     if ($htmlMode) {
682 :     $notes = ERDB::HTMLNote($notes);
683 :     }
684 :     # Escape it for use as a string literal.
685 :     $notes =~ s/\n/\\n/g;
686 :     $notes =~ s/"/\\"/g;
687 :     $retVal .= " myText = \"$notes\";\n";
688 :     }
689 :     if ($typeControl) {
690 :     # Here we want the type updated.
691 :     my $type = $element->{type};
692 :     $retVal .= " myType = \"$type\";\n";
693 :     }
694 :     # Close this case.
695 :     $retVal .= " break;\n";
696 :     }
697 :     }
698 :     }
699 :     # Close the CASE statement and make the appropriate assignments.
700 :     $retVal .= " }\n";
701 :     if ($noteControl) {
702 :     $retVal .= " $noteControl = myText;\n";
703 :     }
704 :     if ($typeControl) {
705 :     $retVal .= " $typeControl = myType;\n";
706 :     }
707 :     }
708 :     # Terminate the change function.
709 :     $retVal .= " }\n";
710 :     $retVal .= "</script>\n";
711 :     # Return the result.
712 :     return $retVal;
713 :     }
714 :    
715 : parrello 1.3 =head3 MatchSqlPattern
716 :    
717 :     C<< my $matched = MatchSqlPattern($value, $pattern); >>
718 :    
719 :     Determine whether or not a specified value matches an SQL pattern. An SQL
720 :     pattern has two wild card characters: C<%> that matches multiple characters,
721 :     and C<_> that matches a single character. These can be escaped using a
722 :     backslash (C<\>). We pull this off by converting the SQL pattern to a
723 :     PERL regular expression. As per SQL rules, the match is case-insensitive.
724 :    
725 :     =over 4
726 :    
727 :     =item value
728 :    
729 :     Value to be matched against the pattern. Note that an undefined value will
730 :     not match anything.
731 :    
732 :     =item pattern
733 :    
734 :     SQL pattern against which to match the value. An undefined pattern will
735 :     match everything.
736 :    
737 :     =item RETURN
738 :    
739 :     Returns TRUE if the value and pattern match, else FALSE.
740 :    
741 :     =back
742 :    
743 :     =cut
744 :    
745 :     sub MatchSqlPattern {
746 :     # Get the parameters.
747 :     my ($value, $pattern) = @_;
748 :     # Declare the return variable.
749 :     my $retVal;
750 :     # Insure we have a pattern.
751 :     if (! defined($pattern)) {
752 :     $retVal = 1;
753 :     } else {
754 :     # Break the pattern into pieces around the wildcard characters. Because we
755 :     # use parentheses in the split function's delimiter expression, we'll get
756 :     # list elements for the delimiters as well as the rest of the string.
757 :     my @pieces = split /([_%]|\\[_%])/, $pattern;
758 :     # Check some fast special cases.
759 :     if ($pattern eq '%') {
760 :     # A null pattern matches everything.
761 :     $retVal = 1;
762 :     } elsif (@pieces == 1) {
763 :     # No wildcards, so we have a literal comparison. Note we're case-insensitive.
764 :     $retVal = (lc($value) eq lc($pattern));
765 :     } elsif (@pieces == 2 && $pieces[1] eq '%') {
766 :     # A wildcard at the end, so we have a substring match. This is also case-insensitive.
767 :     $retVal = (lc(substr($value, 0, length($pieces[0]))) eq lc($pieces[0]));
768 :     } else {
769 :     # Okay, we have to do it the hard way. Convert each piece to a PERL pattern.
770 :     my $realPattern = "";
771 :     for my $piece (@pieces) {
772 :     # Determine the type of piece.
773 :     if ($piece eq "") {
774 :     # Empty pieces are ignored.
775 :     } elsif ($piece eq "%") {
776 :     # Here we have a multi-character wildcard. Note that it can match
777 :     # zero or more characters.
778 :     $realPattern .= ".*"
779 :     } elsif ($piece eq "_") {
780 :     # Here we have a single-character wildcard.
781 :     $realPattern .= ".";
782 :     } elsif ($piece eq "\\%" || $piece eq "\\_") {
783 :     # This is an escape sequence (which is a rare thing, actually).
784 :     $realPattern .= substr($piece, 1, 1);
785 :     } else {
786 :     # Here we have raw text.
787 :     $realPattern .= quotemeta($piece);
788 :     }
789 :     }
790 :     # Do the match.
791 :     $retVal = ($value =~ /^$realPattern$/i ? 1 : 0);
792 :     }
793 :     }
794 :     # Return the result.
795 :     return $retVal;
796 :     }
797 :    
798 :     =head3 MigrateAttributes
799 :    
800 :     C<< CustomAttributes::MigrateAttributes($fig); >>
801 :    
802 :     Migrate all the attributes data from the specified FIG instance. This is a long, slow
803 :     method used to convert the old attribute data to the new system. Only attribute
804 :     keys that are not already in the database will be loaded, and only for entity instances
805 :     current in the database. To get an accurate capture of the attributes in the given
806 :     instance, you may want to clear the database and the DBD before starting and
807 :     run L</Refresh> to populate the entities.
808 :    
809 :     =over 4
810 :    
811 :     =item fig
812 :    
813 :     A FIG object that can be used to retrieve attributes for migration purposes.
814 :    
815 :     =back
816 :    
817 :     =cut
818 :    
819 :     sub MigrateAttributes {
820 :     # Get the parameters.
821 :     my ($fig) = @_;
822 :     # Get a list of the objects to migrate. This requires connecting. Note we
823 :     # will map each entity type to a file name. The file will contain a list
824 :     # of the object's IDs so we can get to them when we're not connected to
825 :     # the database.
826 :     my $ca = CustomAttributes->new();
827 :     my %objects = map { $_ => "$FIG_Config::temp/$_.keys.tbl" } $ca->GetEntityTypes();
828 :     # Set up hash of the existing attribute keys for each entity type.
829 :     my %oldKeys = ();
830 :     # Finally, we have a hash that counts the IDs for each entity type.
831 :     my %idCounts = map { $_ => 0 } keys %objects;
832 :     # Loop through the list, creating key files to read back in.
833 :     for my $entityType (keys %objects) {
834 :     Trace("Retrieving keys for $entityType.") if T(2);
835 :     # Create the key file.
836 :     my $idFile = Open(undef, ">$objects{$entityType}");
837 :     # Loop through the keys.
838 :     my @ids = $ca->GetFlat([$entityType], "", [], "$entityType(id)");
839 :     for my $id (@ids) {
840 :     print $idFile "$id\n";
841 :     }
842 :     close $idFile;
843 :     # In addition to the key file, we must get a list of attributes already
844 :     # in the database. This avoids a circularity problem that might occur if the $fig
845 :     # object is retrieving from the custom attributes database already.
846 :     my %fields = $ca->GetSecondaryFields($entityType);
847 :     $oldKeys{$entityType} = \%fields;
848 :     # Finally, we have the ID count.
849 :     $idCounts{$entityType} = scalar @ids;
850 :     }
851 :     # Release the custom attributes database so we can add attributes.
852 :     undef $ca;
853 :     # Loop through the objects.
854 :     for my $entityType (keys %objects) {
855 :     # Get a hash of all the attributes already in this database. These are
856 :     # left untouched.
857 :     my $myOldKeys = $oldKeys{$entityType};
858 :     # Create a hash to control the load file names for each attribute key we find.
859 :     my %keyHash = ();
860 :     # Set up some counters so we can trace our progress.
861 :     my ($totalIDs, $processedIDs, $keyCount, $valueCount) = ($idCounts{$entityType}, 0, 0, 0);
862 :     # Open this object's ID file.
863 :     Trace("Migrating data for $entityType. $totalIDs found.") if T(3);
864 :     my $keysIn = Open(undef, "<$objects{$entityType}");
865 :     while (my $id = <$keysIn>) {
866 :     # Remove the EOL characters.
867 :     chomp $id;
868 :     # Get this object's attributes.
869 :     my @allData = $fig->get_attributes($id);
870 :     Trace(scalar(@allData) . " attribute values found for $entityType($id).") if T(4);
871 :     # Loop through the attribute values one at a time.
872 :     for my $dataTuple (@allData) {
873 :     # Get the key, value, and URL. We ignore the first element because that's the
874 :     # object ID, and we already know the object ID.
875 :     my (undef, $key, $value, $url) = @{$dataTuple};
876 :     # Only proceed if this is not an old key.
877 :     if (! $myOldKeys->{$key}) {
878 :     # See if we've run into this key before.
879 :     if (! exists $keyHash{$key}) {
880 :     # Here we need to create the attribute key in the database.
881 :     StoreAttributeKey($entityType, $key, 'text',
882 :     "Key migrated automatically from the FIG system. " .
883 :     "Please replace these notes as soon as possible " .
884 :     "with useful text."
885 :     );
886 :     # Compute the attribute's load file name and open it for output.
887 :     my $fileName = "$FIG_Config::temp/$entityType.$key.load.tbl";
888 :     my $fh = Open(undef, ">$fileName");
889 :     # Store the file name and handle.
890 :     $keyHash{$key} = {h => $fh, name => $fileName};
891 :     # Count this key.
892 :     $keyCount++;
893 :     }
894 :     # Smash the value and the URL together.
895 :     if (defined($url) && length($url) > 0) {
896 :     $value .= "::$url";
897 :     }
898 :     # Write the attribute value to the load file.
899 :     Tracer::PutLine($keyHash{$key}->{h}, [$id, $value]);
900 :     $valueCount++;
901 :     }
902 :     }
903 :     # Now we've finished all the attributes for this object. Count and trace it.
904 :     $processedIDs++;
905 :     if ($processedIDs % 500 == 0) {
906 :     Trace("$processedIDs of $totalIDs ${entityType}s processed.") if T(3);
907 :     Trace("$entityType has $keyCount keys and $valueCount values so far.") if T(3);
908 :     }
909 :     }
910 :     # Now we've finished all the attributes for all objects of this type.
911 :     Trace("$processedIDs ${entityType}s processed, with $keyCount keys and $valueCount values.") if T(2);
912 :     # Loop through the files, loading the keys into the database.
913 :     Trace("Connecting to database.") if T(2);
914 :     my $objectCA = CustomAttributes->new();
915 :     Trace("Loading key files.") if T(2);
916 :     for my $key (sort keys %keyHash) {
917 :     # Close the key's load file.
918 :     close $keyHash{$key}->{h};
919 :     # Reopen it for input.
920 :     my $fileName = $keyHash{$key}->{name};
921 :     my $fh = Open(undef, "<$fileName");
922 :     Trace("Loading $key from $fileName.") if T(3);
923 :     my $stats = $objectCA->LoadAttributeKey($entityType, $key, $fh, 0, 1);
924 :     Trace("Statistics for $key of $entityType:\n" . $stats->Show()) if T(3);
925 :     }
926 :     # All the keys for this entity type are now loaded.
927 :     Trace("Key files loaded for $entityType.") if T(2);
928 :     }
929 :     # All keys for all entity types are now loaded.
930 :     Trace("Migration complete.") if T(2);
931 :     }
932 :    
933 :     =head2 FIG Method Replacements
934 :    
935 :     The following methods are used by B<FIG.pm> to replace the previous attribute functionality.
936 :     Some of the old functionality is no longer present. Controlled vocabulary is no longer
937 :     supported and there is no longer any searching by URL. Fortunately, neither of these
938 :     capabilities were used in the old system.
939 :    
940 :     In the previous implementation, an attribute had a value and a URL. In the new implementation,
941 :     there is only a value. In this implementation, each attribute has only a value. These
942 :     methods will treat the value as a list with the individual elements separated by the
943 :     value of the splitter parameter on the constructor (L</new>). The default is double
944 :     colons C<::>.
945 :    
946 :     So, for example, an old-style keyword with a /value of C<essential> and a URL of
947 :     C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default
948 :     splitter value would be stored as
949 :    
950 :     essential::http://www.sciencemag.org/cgi/content/abstract/293/5538/2266
951 :    
952 :     The best performance is achieved by searching for a particular key for a specified
953 :     feature or genome.
954 :    
955 :     =head3 GetAttributes
956 :    
957 :     C<< my @attributeList = GetAttributes($objectID, $key, @valuePatterns); >>
958 :    
959 :     or
960 :    
961 :     C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @valuePatterns); >>
962 :    
963 :     The first form will connect to the database and release it. The second form
964 :     uses the database connection contained in the object.
965 :    
966 :     In the database, attribute values are sectioned into pieces using a splitter
967 :     value specified in the constructor (L</new>). This is not a requirement of
968 :     the attribute system as a whole, merely a convenience for the purpose of
969 :     these methods. If you are using the static method calls instead of the
970 :     object-based calls, the splitter will always be the default value of
971 :     double colons (C<::>). If a value has multiple sections, each section
972 :     is matched against the correspond criterion in the I<@valuePatterns> list.
973 :    
974 :     This method returns a series of tuples that match the specified criteria. Each tuple
975 :     will contain an object ID, a key, and one or more values. The parameters to this
976 :     method therefore correspond structurally to the values expected in each tuple.
977 :    
978 :     my @attributeList = GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);
979 :    
980 :     would return something like
981 :    
982 :     ['fig}100226.1.peg.1004', 'structure', 1, 2]
983 :     ['fig}100226.1.peg.1004', 'structure1', 1, 2]
984 :     ['fig}100226.1.peg.1004', 'structure2', 1, 2]
985 :     ['fig}100226.1.peg.1004', 'structureA', 1, 2]
986 :    
987 :     Use of C<undef> in any position acts as a wild card (all values). In addition,
988 :     the I<$key> and I<@valuePatterns> parameters can contain SQL pattern characters: C<%>, which
989 :     matches any sequence of characters, and C<_>, which matches any single character.
990 :     (You can use an escape sequence C<\%> or C<\_> to match an actual percent sign or
991 :     underscore.)
992 :    
993 :     In addition to values in multiple sections, a single attribute key can have multiple
994 :     values, so even
995 :    
996 :     my @attributeList = GetAttributes($peg, 'virulent');
997 :    
998 :     which has no wildcard in the key or the object ID, may return multiple tuples.
999 :    
1000 :     For reasons of backward compatability, we examine the structure of the object ID to
1001 :     determine the entity type. In that case the only two types allowed are C<Genome> and
1002 :     C<Feature>. An alternative method is to use a list reference, with the list consisting
1003 :     of an entity type name and the actual ID. Thus, the above example could equivalently
1004 :     be written as
1005 :    
1006 :     my @attributeList = GetAttributes([Feature => $peg], 'virulent');
1007 :    
1008 :     The list-reference approach allows us to add attributes to other entity types in
1009 :     the future. Doing so, however, will require modifying the L</Refresh> method and
1010 :     updated the database design XML.
1011 :    
1012 :     The list-reference approach also allows for a more fault-tolerant approach to
1013 :     getting all objects with a particular attribute.
1014 :    
1015 :     my @attributeList = GetAttributes([Feature => undef], 'virulent');
1016 :    
1017 :     will only return feature attributes, while
1018 :    
1019 :     my @attributeList = GetAttributes(undef, 'virulent');
1020 :    
1021 :     could at some point in the future get you attributes for genomes or even subsystems
1022 :     as well as features.
1023 :    
1024 :     =over 4
1025 :    
1026 :     =item objectID
1027 :    
1028 :     ID of the genome or feature whose attributes are desired. In general, an ID that
1029 :     starts with C<fig|> is treated as a feature ID, and an ID that is all digits with a
1030 :     single period is treated as a genome ID. For other entity types, use a list reference; in
1031 :     this case the first list element is the entity type and the second is the ID. A value of
1032 :     C<undef> here will match all objects.
1033 :    
1034 :     =item key
1035 :    
1036 :     Attribute key name. Since attributes are stored as fields in the database with a
1037 :     field name equal to the key name, it is very fast to find a list of all the
1038 :     matching keys. Each key's values require a separate query, however, which may
1039 :     be a performance problem if the pattern matches a lot of keys. Wild cards are
1040 :     acceptable here, and a value of C<undef> will match all attribute keys.
1041 :    
1042 :     =item valuePatterns
1043 :    
1044 :     List of the desired attribute values, section by section. If C<undef>
1045 :     is specified, all values in that section will match.
1046 :    
1047 :     =item RETURN
1048 :    
1049 :     Returns a list of tuples. The first element in the tuple is an object ID, the
1050 :     second is an attribute key, and the remaining elements are the sections of
1051 :     the attribute value. All of the tuples will match the criteria set forth in
1052 :     the parameter list.
1053 :    
1054 :     =back
1055 :    
1056 :     =cut
1057 :    
1058 :     sub GetAttributes {
1059 :     # Connect to the database. The tricky part is knowing whether or not we
1060 :     # are an instance method (in which case the first parameter is a
1061 :     # CustomAttributes object) or a static method (in which case we must
1062 :     # connect manually.
1063 :     my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());
1064 :     # Get the remaining parameters.
1065 :     my ($objectID, $key, @valuePatterns) = @_;
1066 :     # Declare the return variable.
1067 :     my @retVal = ();
1068 :     # Determine the entity types for our search.
1069 :     my @objects = ();
1070 :     my ($actualObjectID, $computedType);
1071 :     if (! defined($objectID)) {
1072 :     push @objects, $self->GetEntityTypes();
1073 :     } else {
1074 :     ($computedType, $actualObjectID) = ComputeObjectTypeFromID($objectID);
1075 :     push @objects, $computedType;
1076 :     }
1077 :     # Loop through the entity types.
1078 :     for my $entityType (@objects) {
1079 :     # Now we need to find all the matching keys. The keys are actually stored in
1080 :     # our database object, so this process is fast. Note that our
1081 :     # MatchSqlPattern method
1082 :     my %secondaries = $self->GetSecondaryFields($entityType);
1083 :     my @fieldList = grep { MatchSqlPattern($_, $key) } keys %secondaries;
1084 :     # Now we figure out whether or not we need to filter by object.
1085 :     my $filter = "";
1086 :     my @params = ();
1087 :     if (defined($actualObjectID)) {
1088 :     # Here the caller wants to filter on object ID.
1089 :     $filter = "$entityType(id) = ?";
1090 :     push @params, $actualObjectID;
1091 :     }
1092 :     # It's time to begin making queries. We process one attribute key at a time, because
1093 :     # each attribute is actually a different field in the database. We know here that
1094 :     # all the keys we've collected are for the correct entity because we got them from
1095 :     # the DBD. That's a good thing, because an invalid key name will cause an SQL error.
1096 :     for my $key (@fieldList) {
1097 :     # Get all of the attribute values for this key.
1098 :     my @dataRows = $self->GetAll([$entityType], $filter, \@params,
1099 :     ["$entityType(id)", "$entityType($key)"]);
1100 :     # Process each value separately. We need to verify the values and reformat the
1101 :     # tuples. Note that GetAll will give us one row per matching object ID,
1102 :     # with the ID first followed by a list of the data values. This is very
1103 :     # different from the structure we'll be returning, which has one row
1104 :     # per value.
1105 :     for my $dataRow (@dataRows) {
1106 :     # Get the object ID and the list of values.
1107 :     my ($rowObjectID, @dataValues) = @{$dataRow};
1108 :     # Loop through the values. There will be one result row per attribute value.
1109 :     for my $dataValue (@dataValues) {
1110 :     # Separate this value into sections.
1111 :     my @sections = split("::", $dataValue);
1112 :     # Loop through the value patterns, looking for a mismatch. Note that
1113 :     # since we're working through parallel arrays, we are using an index
1114 :     # loop. As soon as a match fails we stop checking. This means that
1115 :     # if the value pattern list is longer than the number of sections,
1116 :     # we will fail as soon as we run out of sections.
1117 :     my $match = 1;
1118 :     for (my $i = 0; $i <= $#valuePatterns && $match; $i++) {
1119 :     $match = MatchSqlPattern($sections[$i], $valuePatterns[$i]);
1120 :     }
1121 :     # If we match, we save this value in the output list.
1122 :     if ($match) {
1123 :     push @retVal, [$rowObjectID, $key, @sections];
1124 :     }
1125 :     }
1126 :     # Here we've processed all the attribute values for the current object ID.
1127 :     }
1128 :     # Here we've processed all the rows returned by GetAll. In general, there will
1129 :     # be one row per object ID.
1130 :     }
1131 :     # Here we've processed all the matching attribute keys.
1132 :     }
1133 :     # Here we've processed all the entity types. That means @retVal has all the matching
1134 :     # results.
1135 :     return @retVal;
1136 :     }
1137 :    
1138 :     =head3 AddAttribute
1139 :    
1140 :     C<< $attrDB->AddAttribute($objectID, $key, @values); >>
1141 :    
1142 :     or
1143 :    
1144 :     C<< AddAttribute($objectID, $key, @values); >>
1145 :    
1146 :     Add an attribute key/value pair to an object. This method cannot add a new key, merely
1147 :     add a value to an existing key. Use L</StoreAttributeKey> to create a new key.
1148 :    
1149 :     The first form will connect to the database and release it. The second form
1150 :     uses the database connection contained in the object.
1151 :    
1152 :     =over 4
1153 :    
1154 :     =item objectID
1155 :    
1156 :     ID of the genome or feature to which the attribute is to be added. In general, an ID that
1157 :     starts with C<fig|> is treated as a feature ID, and an ID that is all digits and periods
1158 :     is treated as a genome ID. For IDs of other types, this parameter should be a reference
1159 :     to a 2-tuple consisting of the entity type name followed by the object ID.
1160 :    
1161 :     =item key
1162 :    
1163 :     Attribute key name. This corresponds to the name of a field in the database.
1164 :    
1165 :     =item values
1166 :    
1167 :     One or more values to be associated with the key. The values are joined together with
1168 :     the splitter value before being stored as field values. This enables L</GetAttributes>
1169 :     to split them apart during retrieval. The splitter value defaults to double colons C<::>.
1170 :    
1171 :     =back
1172 :    
1173 :     =cut
1174 :    
1175 :     sub AddAttribute {
1176 :     # Connect to the database. The tricky part is knowing whether or not we
1177 :     # are an instance method (in which case the first parameter is a
1178 :     # CustomAttributes object) or a static method (in which case we must
1179 :     # connect manually.
1180 :     my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());
1181 :     # Get the parameters.
1182 :     my ($objectID, $key, @values) = @_;
1183 :     # Don't allow undefs.
1184 :     if (! defined($objectID)) {
1185 :     Confess("No object ID specified for AddAttribute call.");
1186 :     } elsif (! defined($key)) {
1187 :     Confess("No attribute key specified for AddAttribute call.");
1188 :     } elsif (! @values) {
1189 :     Confess("No values specified in AddAttribute call for key $key.");
1190 :     } else {
1191 :     # Okay, now we have some reason to believe we can do this. Start by
1192 :     # computing the object type and ID.
1193 :     my ($entityName, $id) = ComputeObjectTypeFromID($objectID);
1194 :     # Form the values into a scalar.
1195 :     my $valueString = join($self->{splitter}, @values);
1196 :     # Insert the value.
1197 :     $self->InsertValue($id, "$entityName($key)", $valueString);
1198 :     }
1199 :     # Return a one. We do this for backward compatability.
1200 :     return 1;
1201 :     }
1202 :    
1203 :     =head3 DeleteAttribute
1204 :    
1205 :     C<< $attrDB->DeleteAttribute($objectID, $key, @values); >>
1206 :    
1207 :     or
1208 :    
1209 :     C<< DeleteAttribute($objectID, $key, @values); >>
1210 :    
1211 :     Delete the specified attribute key/value combination from the database.
1212 :    
1213 :     The first form will connect to the database and release it. The second form
1214 :     uses the database connection contained in the object.
1215 :    
1216 :     =over 4
1217 :    
1218 :     =item objectID
1219 :    
1220 :     ID of the genome or feature to which the attribute is to be added. In general, an ID that
1221 :     starts with C<fig|> is treated as a feature ID, and an ID that is all digits and periods
1222 :     is treated as a genome ID. For IDs of other types, this parameter should be a reference
1223 :     to a 2-tuple consisting of the entity type name followed by the object ID.
1224 :    
1225 :     =item key
1226 :    
1227 :     Attribute key name. This corresponds to the name of a field in the database.
1228 :    
1229 :     =item values
1230 :    
1231 :     One or more values to be associated with the key.
1232 :    
1233 :     =back
1234 :    
1235 :     =cut
1236 :    
1237 :     sub DeleteAttribute {
1238 :     # Connect to the database. The tricky part is knowing whether or not we
1239 :     # are an instance method (in which case the first parameter is a
1240 :     # CustomAttributes object) or a static method (in which case we must
1241 :     # connect manually.
1242 :     my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());
1243 :     # Get the parameters.
1244 :     my ($objectID, $key, @values) = @_;
1245 :     # Don't allow undefs.
1246 :     if (! defined($objectID)) {
1247 :     Confess("No object ID specified for DeleteAttribute call.");
1248 :     } elsif (! defined($key)) {
1249 :     Confess("No attribute key specified for DeleteAttribute call.");
1250 :     } elsif (! @values) {
1251 :     Confess("No values specified in DeleteAttribute call for key $key.");
1252 :     } else {
1253 :     # Now compute the object type and ID.
1254 :     my ($entityName, $id) = ComputeObjectTypeFromID($objectID);
1255 :     # Form the values into a scalar.
1256 :     my $valueString = join($self->{splitter}, @values);
1257 :     # Delete the value.
1258 :     $self->DeleteValue($entityName, $id, $key, $valueString);
1259 :     }
1260 :     # Return a one. This is for backward compatability.
1261 :     return 1;
1262 :     }
1263 :    
1264 :     =head3 ComputeObjectTypeFromID
1265 :    
1266 :     C<< my ($entityName, $id) = CustomAttributes::ComputeObjectTypeFromID($objectID); >>
1267 :    
1268 :     This method will compute the entity type corresponding to a specified object ID.
1269 :     If the object ID begins with C<fig|>, it is presumed to be a feature ID. If it
1270 :     is all digits with a single period, it is presumed to by a genome ID. Otherwise,
1271 :     it must be a list reference. In this last case the first list element will be
1272 :     taken as the entity type and the second will be taken as the actual ID.
1273 :    
1274 :     =over 4
1275 :    
1276 :     =item objectID
1277 :    
1278 :     Object ID to examine.
1279 :    
1280 :     =item RETURN
1281 :    
1282 :     Returns a 2-element list consisting of the entity type followed by the specified ID.
1283 :    
1284 :     =back
1285 :    
1286 :     =cut
1287 :    
1288 :     sub ComputeObjectTypeFromID {
1289 :     # Get the parameters.
1290 :     my ($objectID) = @_;
1291 :     # Declare the return variables.
1292 :     my ($entityName, $id);
1293 :     # Only proceed if the object ID is defined. If it's not, we'll be returning a
1294 :     # pair of undefs.
1295 :     if (defined($objectID)) {
1296 :     if (ref $objectID eq 'ARRAY') {
1297 :     # Here we have the new-style list reference. Pull out its pieces.
1298 :     ($entityName, $id) = @{$objectID};
1299 :     } else {
1300 :     # Here the ID is the outgoing ID, and we need to look at its structure
1301 :     # to determine the entity type.
1302 :     $id = $objectID;
1303 :     if ($objectID =~ /^\d+\.\d+/) {
1304 :     # Digits with a single period is a genome.
1305 :     $entityName = 'Genome';
1306 :     } elsif ($objectID =~ /^fig\|/) {
1307 :     # The "fig|" prefix indicates a feature.
1308 :     $entityName = 'Feature';
1309 :     } else {
1310 :     # Anything else is illegal!
1311 :     Confess("Invalid attribute ID specification \"$objectID\".");
1312 :     }
1313 :     }
1314 :     }
1315 :     # Return the result.
1316 :     return ($entityName, $id);
1317 :     }
1318 :    
1319 :     =head3 ChangeAttribute
1320 :    
1321 :     C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
1322 :    
1323 :     or
1324 :    
1325 :     C<< ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
1326 :    
1327 :     Change the value of an attribute key/value pair for an object.
1328 :    
1329 :     The first form will connect to the database and release it. The second form
1330 :     uses the database connection contained in the object.
1331 :    
1332 :     =over 4
1333 :    
1334 :     =item objectID
1335 :    
1336 :     ID of the genome or feature to which the attribute is to be changed. In general, an ID that
1337 :     starts with C<fig|> is treated as a feature ID, and an ID that is all digits and periods
1338 :     is treated as a genome ID. For IDs of other types, this parameter should be a reference
1339 :     to a 2-tuple consisting of the entity type name followed by the object ID.
1340 :    
1341 :     =item key
1342 :    
1343 :     Attribute key name. This corresponds to the name of a field in the database.
1344 :    
1345 :     =item oldValues
1346 :    
1347 :     One or more values identifying the key/value pair to change.
1348 :    
1349 :     =item newValues
1350 :    
1351 :     One or more values to be put in place of the old values.
1352 :    
1353 :     =back
1354 :    
1355 :     =cut
1356 :    
1357 :     sub ChangeAttribute {
1358 :     # Connect to the database. The tricky part is knowing whether or not we
1359 :     # are an instance method (in which case the first parameter is a
1360 :     # CustomAttributes object) or a static method (in which case we must
1361 :     # connect manually.
1362 :     my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());
1363 :     # Get the parameters.
1364 :     my ($objectID, $key, $oldValues, $newValues) = @_;
1365 :     # Don't allow undefs.
1366 :     if (! defined($objectID)) {
1367 :     Confess("No object ID specified for ChangeAttribute call.");
1368 :     } elsif (! defined($key)) {
1369 :     Confess("No attribute key specified for ChangeAttribute call.");
1370 :     } elsif (! defined($oldValues) || ref $oldValues ne 'ARRAY') {
1371 :     Confess("No old values specified in ChangeAttribute call for key $key.");
1372 :     } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {
1373 :     Confess("No new values specified in ChangeAttribute call for key $key.");
1374 :     } else {
1375 :     # Okay, now we do the change as a delete/add.
1376 :     $self->DeleteAttribute($objectID, $key, @{$oldValues});
1377 :     $self->AddAttribute($objectID, $key, @{$newValues});
1378 :     }
1379 :     # Return a one. We do this for backward compatability.
1380 :     return 1;
1381 :     }
1382 :    
1383 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3