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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3