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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3