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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (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 : parrello 1.13 use Stats;
12 : parrello 1.1
13 :     =head1 Custom SEED Attribute Manager
14 :    
15 :     =head2 Introduction
16 :    
17 :     The Custom SEED Attributes Manager allows the user to upload and retrieve
18 :     custom data for SEED objects. It uses the B<ERDB> database system to
19 : parrello 1.10 store the attributes.
20 :    
21 :     Attributes are organized by I<attribute key>. Attribute values are
22 :     assigned to I<objects>. In the real world, objects have types and IDs;
23 :     however, to the attribute database only the ID matters. This will create
24 :     a problem if we have a single ID that applies to two objects of different
25 :     types, but it is more consistent with the original attribute implementation
26 : parrello 1.11 in the SEED (which this implementation replaces).
27 : parrello 1.10
28 : parrello 1.11 The actual attribute values are stored as a relationship between the attribute
29 :     keys and the objects. There can be multiple values for a single key/object pair.
30 : parrello 1.1
31 :     The full suite of ERDB retrieval capabilities is provided. In addition,
32 :     custom methods are provided specific to this application. To get all
33 : parrello 1.6 the values of the attribute C<essential> in a specified B<Feature>, you
34 : parrello 1.1 would code
35 :    
36 : parrello 1.10 my @values = $attrDB->GetAttributes($fid, 'essential');
37 : parrello 1.1
38 : parrello 1.10 where I<$fid> contains the ID of the desired feature.
39 : parrello 1.1
40 : parrello 1.10 New attribute keys must be defined before they can be used. A web interface
41 :     is provided for this purpose.
42 : parrello 1.1
43 :     =head2 FIG_Config Parameters
44 :    
45 :     The following configuration parameters are used to manage custom attributes.
46 :    
47 :     =over 4
48 :    
49 :     =item attrDbms
50 :    
51 :     Type of database manager used: C<mysql> for MySQL or C<pg> for PostGres.
52 :    
53 :     =item attrDbName
54 :    
55 :     Name of the attribute database.
56 :    
57 :     =item attrHost
58 :    
59 :     Name of the host server for the database. If omitted, the current host
60 :     is used.
61 :    
62 :     =item attrUser
63 :    
64 :     User name for logging in to the database.
65 :    
66 :     =item attrPass
67 :    
68 :     Password for logging in to the database.
69 :    
70 :     =item attrPort
71 :    
72 :     TCP/IP port for accessing the database.
73 :    
74 :     =item attrSock
75 :    
76 :     Socket name used to access the database. If omitted, the default socket
77 :     will be used.
78 :    
79 :     =item attrDBD
80 :    
81 :     Fully-qualified file name for the database definition XML file. This file
82 :     functions as data to the attribute management process, so if the data is
83 :     moved, this file must go with it.
84 :    
85 :     =back
86 :    
87 :     =head2 Public Methods
88 :    
89 :     =head3 new
90 :    
91 : parrello 1.3 C<< my $attrDB = CustomAttributes->new($splitter); >>
92 : parrello 1.1
93 : parrello 1.10 Construct a new CustomAttributes object.
94 : parrello 1.3
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.10 =head3 StoreAttributeKey
126 :    
127 :     C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>
128 :    
129 :     Create or update an attribute for the database.
130 :    
131 :     =over 4
132 : parrello 1.1
133 :     =item attributeName
134 :    
135 :     Name of the attribute. It must be a valid ERDB field name, consisting entirely of
136 :     letters, digits, and hyphens, with a letter at the beginning. If it does not
137 :     exist already, it will be created.
138 :    
139 :     =item type
140 :    
141 :     Data type of the attribute. This must be a valid ERDB data type name.
142 :    
143 :     =item notes
144 :    
145 :     Descriptive notes about the attribute. It is presumed to be raw text, not HTML.
146 :    
147 : parrello 1.10 =item groups
148 : parrello 1.1
149 : parrello 1.10 Reference to a list of the groups to which the attribute should be associated.
150 :     This will replace any groups to which the attribute is currently attached.
151 : parrello 1.1
152 :     =back
153 :    
154 :     =cut
155 :    
156 : parrello 1.3 sub StoreAttributeKey {
157 : parrello 1.1 # Get the parameters.
158 : parrello 1.10 my ($self, $attributeName, $type, $notes, $groups) = @_;
159 : parrello 1.8 # Declare the return variable.
160 :     my $retVal;
161 : parrello 1.1 # Get the data type hash.
162 :     my %types = ERDB::GetDataTypes();
163 :     # Validate the initial input values.
164 :     if (! ERDB::ValidateFieldName($attributeName)) {
165 :     Confess("Invalid attribute name \"$attributeName\" specified.");
166 :     } elsif (! $notes || length($notes) < 25) {
167 :     Confess("Missing or incomplete description for $attributeName.");
168 :     } elsif (! exists $types{$type}) {
169 :     Confess("Invalid data type \"$type\" for $attributeName.");
170 :     } else {
171 : parrello 1.10 # Okay, we're ready to begin. See if this key exists.
172 :     my $attribute = $self->GetEntity('AttributeKey', $attributeName);
173 :     if (defined($attribute)) {
174 :     # It does, so we do an update.
175 :     $self->UpdateEntity('AttributeKey', $attributeName,
176 :     { description => $notes, 'data-type' => $type });
177 :     # Detach the key from its current groups.
178 :     $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
179 :     } else {
180 :     # It doesn't, so we do an insert.
181 :     $self->InsertObject('AttributeKey', { id => $attributeName,
182 :     description => $notes, 'data-type' => $type });
183 : parrello 1.8 }
184 : parrello 1.10 # Attach the key to the specified groups. (We presume the groups already
185 :     # exist.)
186 :     for my $group (@{$groups}) {
187 :     $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
188 :     'to-link' => $group });
189 : parrello 1.1 }
190 :     }
191 :     }
192 :    
193 : parrello 1.3 =head3 LoadAttributeKey
194 : parrello 1.1
195 : parrello 1.10 C<< my $stats = $attrDB->LoadAttributeKey($keyName, $fh, $keyCol, $dataCol, %options); >>
196 : parrello 1.1
197 :     Load the specified attribute from the specified file. The file should be a
198 :     tab-delimited file with internal tab and new-line characters escaped. This is
199 :     the typical TBL-style file used by most FIG applications. One of the columns
200 : parrello 1.10 in the input file must contain the appropriate object id value and the other the
201 : parrello 1.1 corresponding attribute value.
202 :    
203 :     =over 4
204 :    
205 : parrello 1.10 =item keyName
206 : parrello 1.1
207 : parrello 1.10 Key of the attribute to load.
208 : parrello 1.1
209 :     =item fh
210 :    
211 :     Open file handle for the input file.
212 :    
213 : parrello 1.10 =item idCol
214 : parrello 1.1
215 : parrello 1.10 Index (0-based) of the column containing the ID field. The ID field should
216 : parrello 1.1 contain the ID of an instance of the named entity.
217 :    
218 :     =item dataCol
219 :    
220 :     Index (0-based) of the column containing the data value field.
221 :    
222 : parrello 1.10 =item options
223 :    
224 :     Hash specifying the options for this load.
225 :    
226 : parrello 1.1 =item RETURN
227 :    
228 :     Returns a statistics object for the load process.
229 :    
230 :     =back
231 :    
232 : parrello 1.10 The available options are as follows.
233 :    
234 :     =over 4
235 :    
236 :     =item erase
237 :    
238 :     If TRUE, the key's values will all be erased before loading. (Doing so
239 :     makes for a faster load.)
240 :    
241 :     =back
242 :    
243 : parrello 1.1 =cut
244 :    
245 : parrello 1.3 sub LoadAttributeKey {
246 : parrello 1.1 # Get the parameters.
247 : parrello 1.10 my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;
248 : parrello 1.1 # Create the return variable.
249 : parrello 1.11 my $retVal = Stats->new("lineIn", "shortLine", "newObject");
250 : parrello 1.10 # Compute the minimum number of fields required in each input line.
251 :     my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;
252 :     # Insure the attribute key exists.
253 :     my $found = $self->GetEntity('AttributeKey', $keyName);
254 :     if (! defined $found) {
255 :     Confess("Attribute key \"$keyName\" not found in database.");
256 : parrello 1.1 } else {
257 : parrello 1.11 # Erase the key's current values.
258 :     $self->EraseAttribute($keyName);
259 :     # Save a list of the object IDs we need to add.
260 :     my %objectIDs = ();
261 : parrello 1.10 # Loop through the input file.
262 :     while (! eof $fh) {
263 :     # Get the next line of the file.
264 :     my @fields = Tracer::GetLine($fh);
265 :     $retVal->Add(lineIn => 1);
266 :     # Now we need to validate the line.
267 :     if (scalar(@fields) < $minCols) {
268 :     $retVal->Add(shortLine => 1);
269 :     } else {
270 :     # It's valid, so get the ID and value.
271 :     my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
272 :     # Denote we're using this input line.
273 :     $retVal->Add(lineUsed => 1);
274 : parrello 1.11 # Now we insert the attribute.
275 : parrello 1.15 $self->InsertObject('HasValueFor', { from => $keyName, to => $id,
276 :     keywords => $self->_KeywordString($keyName, $value),
277 :     value => $value });
278 : parrello 1.11 $retVal->Add(newValue => 1);
279 : parrello 1.1 }
280 :     }
281 :     }
282 :     # Return the statistics.
283 :     return $retVal;
284 :     }
285 :    
286 :    
287 : parrello 1.3 =head3 DeleteAttributeKey
288 :    
289 : parrello 1.10 C<< my $stats = $attrDB->DeleteAttributeKey($attributeName); >>
290 : parrello 1.1
291 :     Delete an attribute from the custom attributes database.
292 :    
293 :     =over 4
294 :    
295 : parrello 1.10 =item attributeName
296 : parrello 1.1
297 : parrello 1.10 Name of the attribute to delete.
298 : parrello 1.1
299 : parrello 1.10 =item RETURN
300 : parrello 1.1
301 : parrello 1.10 Returns a statistics object describing the effects of the deletion.
302 : parrello 1.1
303 :     =back
304 :    
305 :     =cut
306 :    
307 : parrello 1.3 sub DeleteAttributeKey {
308 : parrello 1.1 # Get the parameters.
309 : parrello 1.10 my ($self, $attributeName) = @_;
310 :     # Delete the attribute key.
311 :     my $retVal = $self->Delete('AttributeKey', $attributeName);
312 :     # Return the result.
313 :     return $retVal;
314 :    
315 :     }
316 :    
317 :     =head3 NewName
318 :    
319 :     C<< my $text = CustomAttributes::NewName(); >>
320 :    
321 :     Return the string used to indicate the user wants to add a new attribute.
322 :    
323 :     =cut
324 :    
325 :     sub NewName {
326 :     return "(new)";
327 : parrello 1.1 }
328 :    
329 :     =head3 ControlForm
330 :    
331 : parrello 1.10 C<< my $formHtml = $attrDB->ControlForm($cgi, $name, \%keys); >>
332 : parrello 1.1
333 :     Return a form that can be used to control the creation and modification of
334 : parrello 1.10 attributes. Only a subset of the attribute keys will be displayed, as
335 :     determined by the incoming list.
336 : parrello 1.1
337 :     =over 4
338 :    
339 :     =item cgi
340 :    
341 :     CGI query object used to create HTML.
342 :    
343 :     =item name
344 :    
345 :     Name to give to the form. This should be unique for the web page.
346 :    
347 : parrello 1.10 =item keys
348 :    
349 :     Reference to a hash mapping attribute keys to n-tuples. Each tuple will contain the
350 :     attribute's data type, its description, and a list of the groups in which it participates.
351 :    
352 : parrello 1.1 =item RETURN
353 :    
354 : parrello 1.10 Returns the HTML for a form that can be used to submit instructions to the C<Attributes.cgi> script
355 :     for loading, creating, displaying, changing, or deleting an attribute. Note that only the form
356 :     controls are generated. The form tags are left to the caller.
357 : parrello 1.1
358 :     =back
359 :    
360 :     =cut
361 :    
362 :     sub ControlForm {
363 :     # Get the parameters.
364 : parrello 1.10 my ($self, $cgi, $name, $keys) = @_;
365 : parrello 1.1 # Declare the return list.
366 :     my @retVal = ();
367 :     # We'll put the controls in a table. Nothing else ever seems to look nice.
368 :     push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });
369 :     # The first row is for selecting the field name.
370 :     push @retVal, $cgi->Tr($cgi->th("Select a Field"),
371 : parrello 1.10 $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', $keys,
372 :     new => 1,
373 :     notes => "document.$name.notes.value",
374 :     type => "document.$name.dataType.value",
375 :     groups => "document.$name.groups")));
376 : parrello 1.1 # Now we set up a dropdown for the data types. The values will be the
377 :     # data type names, and the labels will be the descriptions.
378 :     my %types = ERDB::GetDataTypes();
379 :     my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;
380 :     my $typeMenu = $cgi->popup_menu(-name => 'dataType',
381 :     -values => [sort keys %types],
382 : parrello 1.10 -labels => \%labelMap,
383 :     -default => 'string');
384 :     # Allow the user to specify a new field name. This is required if the
385 :     # user has selected the "(new)" marker. We put a little scriptlet in here that
386 :     # selects the (new) marker when the user enters the field.
387 :     push @retVal, "<script language=\"javaScript\">";
388 :     my $fieldField = "document.$name.fieldName";
389 :     my $newName = "\"" . NewName() . "\"";
390 :     push @retVal, $cgi->Tr($cgi->th("New Field Name"),
391 :     $cgi->td($cgi->textfield(-name => 'newName',
392 :     -size => 30,
393 :     -value => "",
394 :     -onFocus => "setIfEmpty($fieldField, $newName);")),
395 :     );
396 : parrello 1.1 push @retVal, $cgi->Tr($cgi->th("Data type"),
397 :     $cgi->td($typeMenu));
398 :     # The next row is for the notes.
399 :     push @retVal, $cgi->Tr($cgi->th("Description"),
400 :     $cgi->td($cgi->textarea(-name => 'notes',
401 :     -rows => 6,
402 :     -columns => 80))
403 :     );
404 : parrello 1.10 # Now we have the groups, which are implemented as a checkbox group.
405 :     my @groups = $self->GetGroups();
406 :     push @retVal, $cgi->Tr($cgi->th("Groups"),
407 :     $cgi->td($cgi->checkbox_group(-name=>'groups',
408 :     -values=> \@groups))
409 :     );
410 : parrello 1.1 # If the user wants to upload new values for the field, then we have
411 :     # an upload file name and column indicators.
412 :     push @retVal, $cgi->Tr($cgi->th("Upload Values"),
413 :     $cgi->td($cgi->filefield(-name => 'newValueFile',
414 :     -size => 20) .
415 :     " Key&nbsp;" .
416 :     $cgi->textfield(-name => 'keyCol',
417 :     -size => 3,
418 :     -default => 0) .
419 :     " Value&nbsp;" .
420 :     $cgi->textfield(-name => 'valueCol',
421 :     -size => 3,
422 :     -default => 1)
423 :     ),
424 :     );
425 : parrello 1.10 # Now the three buttons: STORE, SHOW, and DELETE.
426 : parrello 1.1 push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
427 :     $cgi->td({align => 'center'},
428 :     $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .
429 : parrello 1.7 $cgi->submit(-name => 'Store', -value => 'STORE') . " " .
430 :     $cgi->submit(-name => 'Show', -value => 'SHOW')
431 : parrello 1.1 )
432 :     );
433 :     # Close the table and the form.
434 :     push @retVal, $cgi->end_table();
435 :     # Return the assembled HTML.
436 :     return join("\n", @retVal, "");
437 :     }
438 :    
439 : parrello 1.11 =head3 LoadAttributesFrom
440 :    
441 :     C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
442 :    
443 :     Load attributes from the specified tab-delimited file. Each line of the file must
444 :     contain an object ID in the first column, an attribute key name in the second
445 :     column, and attribute values in the remaining columns. The attribute values will
446 :     be assembled into a single value using the splitter code.
447 :    
448 :     =over 4
449 :    
450 :     =item fileName
451 :    
452 :     Name of the file from which to load the attributes.
453 :    
454 :     =item options
455 :    
456 :     Hash of options for modifying the load process.
457 :    
458 :     =item RETURN
459 :    
460 :     Returns a statistics object describing the load.
461 :    
462 :     =back
463 :    
464 :     Permissible option values are as follows.
465 :    
466 :     =over 4
467 :    
468 :     =item append
469 :    
470 :     If TRUE, then the attributes will be appended to existing data; otherwise, the
471 :     first time a key name is encountered, it will be erased.
472 :    
473 :     =back
474 :    
475 :     =cut
476 :    
477 :     sub LoadAttributesFrom {
478 :     # Get the parameters.
479 :     my ($self, $fileName, %options) = @_;
480 :     # Declare the return variable.
481 :     my $retVal = Stats->new('keys', 'values');
482 :     # Check for append mode.
483 :     my $append = ($options{append} ? 1 : 0);
484 :     # Create a hash of key names found.
485 :     my %keyHash = ();
486 :     # Open the file for input.
487 :     my $fh = Open(undef, "<$fileName");
488 :     # Loop through the file.
489 :     while (! eof $fh) {
490 :     my ($id, $key, @values) = Tracer::GetLine($fh);
491 :     $retVal->Add(linesIn => 1);
492 :     # Do some validation.
493 :     if (! defined($id)) {
494 :     # We ignore blank lines.
495 :     $retVal->Add(blankLines => 1);
496 :     } elsif (! defined($key)) {
497 :     # An ID without a key is a serious error.
498 :     my $lines = $retVal->Ask('linesIn');
499 :     Confess("Line $lines in $fileName has no attribute key.");
500 :     } else {
501 :     # Now we need to check for a new key.
502 :     if (! exists $keyHash{$key}) {
503 :     # This is a new key. Verify that it exists.
504 :     if (! $self->Exists('AttributeKey', $key)) {
505 :     my $line = $retVal->Ask('linesIn');
506 :     Confess("Attribute \"$key\" on line $line of $fileName not found in database.");
507 :     } else {
508 :     # Make sure we know this is no longer a new key.
509 :     $keyHash{$key} = 1;
510 :     $retVal->Add(keys => 1);
511 :     # If this is NOT append mode, erase the key.
512 :     if (! $append) {
513 :     $self->EraseAttribute($key);
514 :     }
515 :     }
516 :     Trace("Key $key found.") if T(3);
517 :     }
518 :     # Now we know the key is valid. Add this value.
519 :     $self->AddAttribute($id, $key, @values);
520 :     my $progress = $retVal->Add(values => 1);
521 :     Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
522 :    
523 :     }
524 :     }
525 :     # Return the result.
526 :     return $retVal;
527 :     }
528 :    
529 : parrello 1.13 =head3 BackupKeys
530 :    
531 :     C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
532 :    
533 :     Backup the attribute key information from the attribute database.
534 :    
535 :     =over 4
536 :    
537 :     =item fileName
538 :    
539 :     Name of the output file.
540 :    
541 :     =item options
542 :    
543 :     Options for modifying the backup process.
544 :    
545 :     =item RETURN
546 :    
547 :     Returns a statistics object for the backup.
548 :    
549 :     =back
550 :    
551 :     Currently there are no options. The backup is straight to a text file in
552 :     tab-delimited format. Each key is backup up to two lines. The first line
553 :     is all of the data from the B<AttributeKey> table. The second is a
554 :     tab-delimited list of all the groups.
555 :    
556 :     =cut
557 :    
558 :     sub BackupKeys {
559 :     # Get the parameters.
560 :     my ($self, $fileName, %options) = @_;
561 :     # Declare the return variable.
562 :     my $retVal = Stats->new();
563 :     # Open the output file.
564 :     my $fh = Open(undef, ">$fileName");
565 :     # Set up to read the keys.
566 :     my $keyQuery = $self->Get(['AttributeKey'], "", []);
567 :     # Loop through the keys.
568 :     while (my $keyData = $keyQuery->Fetch()) {
569 :     $retVal->Add(key => 1);
570 :     # Get the fields.
571 :     my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
572 :     'AttributeKey(description)']);
573 :     # Escape any tabs or new-lines in the description.
574 :     my $escapedDescription = Tracer::Escape($description);
575 :     # Write the key data to the output.
576 :     Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
577 :     # Get the key's groups.
578 :     my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
579 :     'IsInGroup(to-link)');
580 :     $retVal->Add(memberships => scalar(@groups));
581 :     # Write them to the output. Note we put a marker at the beginning to insure the line
582 :     # is nonempty.
583 :     Tracer::PutLine($fh, ['#GROUPS', @groups]);
584 :     }
585 :     # Return the result.
586 :     return $retVal;
587 :     }
588 :    
589 :     =head3 RestoreKeys
590 :    
591 :     C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
592 :    
593 :     Restore the attribute keys and groups from a backup file.
594 :    
595 :     =over 4
596 :    
597 :     =item fileName
598 :    
599 :     Name of the file containing the backed-up keys. Each key has a pair of lines,
600 :     one containing the key data and one listing its groups.
601 :    
602 :     =back
603 :    
604 :     =cut
605 :    
606 :     sub RestoreKeys {
607 :     # Get the parameters.
608 :     my ($self, $fileName, %options) = @_;
609 :     # Declare the return variable.
610 :     my $retVal = Stats->new();
611 :     # Set up a hash to hold the group IDs.
612 :     my %groups = ();
613 :     # Open the file.
614 :     my $fh = Open(undef, "<$fileName");
615 :     # Loop until we're done.
616 :     while (! eof $fh) {
617 :     # Get a key record.
618 :     my ($id, $dataType, $description) = Tracer::GetLine($fh);
619 :     if ($id eq '#GROUPS') {
620 :     Confess("Group record found when key record expected.");
621 :     } elsif (! defined($description)) {
622 :     Confess("Invalid format found for key record.");
623 :     } else {
624 :     $retVal->Add("keyIn" => 1);
625 :     # Add this key to the database.
626 :     $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
627 :     description => Tracer::UnEscape($description) });
628 :     Trace("Attribute $id stored.") if T(3);
629 :     # Get the group line.
630 :     my ($marker, @groups) = Tracer::GetLine($fh);
631 :     if (! defined($marker)) {
632 :     Confess("End of file found where group record expected.");
633 :     } elsif ($marker ne '#GROUPS') {
634 :     Confess("Group record not found after key record.");
635 :     } else {
636 :     $retVal->Add(memberships => scalar(@groups));
637 :     # Connect the groups.
638 :     for my $group (@groups) {
639 :     # Find out if this is a new group.
640 :     if (! $groups{$group}) {
641 :     $retVal->Add(newGroup => 1);
642 :     # Add the group.
643 :     $self->InsertObject('AttributeGroup', { id => $group });
644 :     Trace("Group $group created.") if T(3);
645 :     # Make sure we know it's not new.
646 :     $groups{$group} = 1;
647 :     }
648 :     # Connect the group to our key.
649 :     $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
650 :     }
651 :     Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
652 :     }
653 :     }
654 :     }
655 :     # Return the result.
656 :     return $retVal;
657 :     }
658 :    
659 :    
660 : parrello 1.11 =head3 BackupAllAttributes
661 :    
662 :     C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
663 :    
664 :     Backup all of the attributes to a file. The attributes will be stored in a
665 :     tab-delimited file suitable for reloading via L</LoadAttributesFrom>.
666 :    
667 :     =over 4
668 :    
669 :     =item fileName
670 :    
671 :     Name of the file to which the attribute data should be backed up.
672 :    
673 :     =item options
674 :    
675 :     Hash of options for the backup.
676 :    
677 :     =item RETURN
678 :    
679 :     Returns a statistics object describing the backup.
680 :    
681 :     =back
682 :    
683 :     Currently there are no options defined.
684 :    
685 :     =cut
686 :    
687 :     sub BackupAllAttributes {
688 :     # Get the parameters.
689 :     my ($self, $fileName, %options) = @_;
690 :     # Declare the return variable.
691 :     my $retVal = Stats->new();
692 :     # Get a list of the keys.
693 :     my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
694 :     Trace(scalar(@keys) . " keys found during backup.") if T(2);
695 :     # Open the file for output.
696 : parrello 1.12 my $fh = Open(undef, ">$fileName");
697 : parrello 1.11 # Loop through the keys.
698 :     for my $key (@keys) {
699 :     Trace("Backing up attribute $key.") if T(3);
700 :     $retVal->Add(keys => 1);
701 :     # Loop through this key's values.
702 : parrello 1.12 my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
703 : parrello 1.11 my $valuesFound = 0;
704 :     while (my $line = $query->Fetch()) {
705 :     $valuesFound++;
706 :     # Get this row's data.
707 : parrello 1.13 my @row = $line->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
708 : parrello 1.11 'HasValueFor(value)']);
709 :     # Write it to the file.
710 :     Tracer::PutLine($fh, \@row);
711 :     }
712 :     Trace("$valuesFound values backed up for key $key.") if T(3);
713 :     $retVal->Add(values => $valuesFound);
714 :     }
715 :     # Return the result.
716 :     return $retVal;
717 :     }
718 :    
719 : parrello 1.1 =head3 FieldMenu
720 :    
721 : parrello 1.10 C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>
722 : parrello 1.1
723 :     Return the HTML for a menu to select an attribute field. The menu will
724 :     be a standard SELECT/OPTION thing which is called "popup menu" in the
725 :     CGI package, but actually looks like a list. The list will contain
726 : parrello 1.10 one selectable row per field.
727 : parrello 1.1
728 :     =over 4
729 :    
730 :     =item cgi
731 :    
732 :     CGI query object used to generate HTML.
733 :    
734 :     =item height
735 :    
736 :     Number of lines to display in the list.
737 :    
738 :     =item name
739 :    
740 :     Name to give to the menu. This is the name under which the value will
741 :     appear when the form is submitted.
742 :    
743 : parrello 1.10 =item keys
744 :    
745 :     Reference to a hash mapping each attribute key name to a list reference,
746 :     the list itself consisting of the attribute data type, its description,
747 :     and a list of its groups.
748 :    
749 :     =item options
750 :    
751 :     Hash containing options that modify the generation of the menu.
752 :    
753 :     =item RETURN
754 :    
755 :     Returns the HTML to create a form field that can be used to select an
756 :     attribute from the custom attributes system.
757 :    
758 :     =back
759 :    
760 :     The permissible options are as follows.
761 :    
762 :     =over 4
763 :    
764 :     =item new
765 : parrello 1.1
766 :     If TRUE, then extra rows will be provided to allow the user to select
767 :     a new attribute. In other words, the user can select an existing
768 :     attribute, or can choose a C<(new)> marker to indicate a field to
769 :     be created in the parent entity.
770 :    
771 : parrello 1.10 =item notes
772 : parrello 1.1
773 :     If specified, the name of a variable for displaying the notes attached
774 :     to the field. This must be in Javascript form ready for assignment.
775 :     So, for example, if you have a variable called C<notes> that
776 :     represents a paragraph element, you should code C<notes.innerHTML>.
777 :     If it actually represents a form field you should code C<notes.value>.
778 :     If an C<innerHTML> coding is used, the text will be HTML-escaped before
779 :     it is copied in. Specifying this parameter generates Javascript for
780 :     displaying the field description when a field is selected.
781 :    
782 : parrello 1.10 =item type
783 : parrello 1.1
784 :     If specified, the name of a variable for displaying the field's
785 :     data type. Data types are a much more controlled vocabulary than
786 :     notes, so there is no worry about HTML translation. Instead, the
787 :     raw value is put into the specified variable. Otherwise, the same
788 :     rules apply to this value that apply to I<$noteControl>.
789 :    
790 : parrello 1.10 =item groups
791 : parrello 1.1
792 : parrello 1.10 If specified, the name of a multiple-selection list control (also called
793 :     a popup menu) which shall be used to display the selected groups.
794 : parrello 1.1
795 :     =back
796 :    
797 :     =cut
798 :    
799 :     sub FieldMenu {
800 :     # Get the parameters.
801 : parrello 1.10 my ($self, $cgi, $height, $name, $keys, %options) = @_;
802 :     # Reformat the list of keys.
803 :     my %keys = %{$keys};
804 :     # Add the (new) key, if needed.
805 :     if ($options{new}) {
806 :     $keys{NewName()} = ["string", ""];
807 : parrello 1.1 }
808 : parrello 1.10 # Get a sorted list of key.
809 :     my @keys = sort keys %keys;
810 :     # We need to create the name for the onChange function. This function
811 : parrello 1.1 # may not do anything, but we need to know the name to generate the HTML
812 :     # for the menu.
813 :     my $changeName = "${name}_setNotes";
814 :     my $retVal = $cgi->popup_menu({name => $name,
815 :     size => $height,
816 :     onChange => "$changeName(this.value)",
817 : parrello 1.10 values => \@keys,
818 :     });
819 : parrello 1.1 # Create the change function.
820 :     $retVal .= "\n<script language=\"javascript\">\n";
821 :     $retVal .= " function $changeName(fieldValue) {\n";
822 : parrello 1.10 # The function only has a body if we have a control to store data about the
823 :     # attribute.
824 :     if ($options{notes} || $options{type} || $options{groups}) {
825 : parrello 1.1 # Check to see if we're storing HTML or text into the note control.
826 : parrello 1.10 my $noteControl = $options{notes};
827 : parrello 1.1 my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);
828 :     # We use a CASE statement based on the newly-selected field value. The
829 :     # field description will be stored in the JavaScript variable "myText"
830 :     # and the data type in "myType". Note the default data type is a normal
831 :     # string, but the default notes is an empty string.
832 :     $retVal .= " var myText = \"\";\n";
833 :     $retVal .= " var myType = \"string\";\n";
834 :     $retVal .= " switch (fieldValue) {\n";
835 : parrello 1.10 # Loop through the keys.
836 :     for my $key (@keys) {
837 :     # Generate this case.
838 :     $retVal .= " case \"$key\" :\n";
839 :     # Here we either want to update the note display, the
840 :     # type display, the group list, or a combination of them.
841 :     my ($type, $notes, @groups) = @{$keys{$key}};
842 :     if ($noteControl) {
843 :     # Insure it's in the proper form.
844 :     if ($htmlMode) {
845 :     $notes = ERDB::HTMLNote($notes);
846 : parrello 1.1 }
847 : parrello 1.10 # Escape it for use as a string literal.
848 :     $notes =~ s/\n/\\n/g;
849 :     $notes =~ s/"/\\"/g;
850 :     $retVal .= " myText = \"$notes\";\n";
851 :     }
852 :     if ($options{type}) {
853 :     # Here we want the type updated.
854 :     $retVal .= " myType = \"$type\";\n";
855 :     }
856 :     if ($options{groups}) {
857 :     # Here we want the groups shown. Get a list of this attribute's groups.
858 :     # We'll search through this list for each group to see if it belongs with
859 :     # our attribute.
860 :     my $groupLiteral = "=" . join("=", @groups) . "=";
861 :     # Now we need some variables containing useful code for the javascript. It's
862 :     # worth knowing we go through a bit of pain to insure $groupField[i] isn't
863 :     # parsed as an array element.
864 :     my $groupField = $options{groups};
865 :     my $currentField = $groupField . "[i]";
866 :     # Do the javascript.
867 :     $retVal .= " var groupList = \"$groupLiteral\";\n";
868 :     $retVal .= " for (var i = 0; i < $groupField.length; i++) {\n";
869 :     $retVal .= " var srchString = \"=\" + $currentField.value + \"=\";\n";
870 :     $retVal .= " var srchLoc = groupList.indexOf(srchString);\n";
871 :     $retVal .= " $currentField.checked = (srchLoc >= 0);\n";
872 :     $retVal .= " }\n";
873 : parrello 1.1 }
874 : parrello 1.10 # Close this case.
875 :     $retVal .= " break;\n";
876 : parrello 1.1 }
877 :     # Close the CASE statement and make the appropriate assignments.
878 :     $retVal .= " }\n";
879 :     if ($noteControl) {
880 :     $retVal .= " $noteControl = myText;\n";
881 :     }
882 : parrello 1.10 if ($options{type}) {
883 :     $retVal .= " $options{type} = myType;\n";
884 : parrello 1.1 }
885 :     }
886 :     # Terminate the change function.
887 :     $retVal .= " }\n";
888 :     $retVal .= "</script>\n";
889 :     # Return the result.
890 :     return $retVal;
891 :     }
892 :    
893 : parrello 1.10 =head3 GetGroups
894 : parrello 1.3
895 : parrello 1.10 C<< my @groups = $attrDB->GetGroups(); >>
896 : parrello 1.3
897 : parrello 1.10 Return a list of the available groups.
898 : parrello 1.3
899 :     =cut
900 :    
901 : parrello 1.10 sub GetGroups {
902 : parrello 1.3 # Get the parameters.
903 : parrello 1.10 my ($self) = @_;
904 :     # Get the groups.
905 :     my @retVal = $self->GetFlat(['AttributeGroup'], "", [], 'AttributeGroup(id)');
906 :     # Return them.
907 :     return @retVal;
908 : parrello 1.3 }
909 :    
910 : parrello 1.10 =head3 GetAttributeData
911 : parrello 1.3
912 : parrello 1.10 C<< my %keys = $attrDB->GetAttributeData($type, @list); >>
913 : parrello 1.3
914 : parrello 1.10 Return attribute data for the selected attributes. The attribute
915 :     data is a hash mapping each attribute key name to a n-tuple containing the
916 :     data type, the description, and the groups. This is the same format expected in
917 :     the L</FieldMenu> and L</ControlForm> methods for the list of attributes to display.
918 : parrello 1.3
919 :     =over 4
920 :    
921 : parrello 1.10 =item type
922 : parrello 1.4
923 : parrello 1.10 Type of attribute criterion: C<name> for attributes whose names begin with the
924 :     specified string, or C<group> for attributes in the specified group.
925 : parrello 1.4
926 : parrello 1.10 =item list
927 : parrello 1.4
928 : parrello 1.10 List containing the names of the groups or keys for the desired attributes.
929 : parrello 1.4
930 :     =item RETURN
931 :    
932 : parrello 1.10 Returns a hash mapping each attribute key name to its data type, description, and
933 :     parent groups.
934 : parrello 1.4
935 :     =back
936 :    
937 :     =cut
938 :    
939 : parrello 1.10 sub GetAttributeData {
940 : parrello 1.4 # Get the parameters.
941 : parrello 1.10 my ($self, $type, @list) = @_;
942 :     # Set up a hash to store the attribute data.
943 :     my %retVal = ();
944 :     # Loop through the list items.
945 :     for my $item (@list) {
946 :     # Set up a query for the desired attributes.
947 :     my $query;
948 :     if ($type eq 'name') {
949 :     # Here we're doing a generic name search. We need to escape it and then tack
950 :     # on a %.
951 :     my $parm = $item;
952 :     $parm =~ s/_/\\_/g;
953 :     $parm =~ s/%/\\%/g;
954 :     $parm .= "%";
955 :     # Ask for matching attributes. (Note that if the user passed in a null string
956 :     # he'll get everything.)
957 :     $query = $self->Get(['AttributeKey'], "AttributeKey(id) LIKE ?", [$parm]);
958 :     } elsif ($type eq 'group') {
959 :     $query = $self->Get(['IsInGroup', 'AttributeKey'], "IsInGroup(to-link) = ?", [$item]);
960 : parrello 1.4 } else {
961 : parrello 1.10 Confess("Unknown attribute query type \"$type\".");
962 :     }
963 :     while (my $row = $query->Fetch()) {
964 :     # Get this attribute's data.
965 :     my ($key, $type, $notes) = $row->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
966 :     'AttributeKey(description)']);
967 :     # If it's new, get its groups and add it to the return hash.
968 :     if (! exists $retVal{$key}) {
969 :     my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",
970 :     [$key], 'IsInGroup(to-link)');
971 :     $retVal{$key} = [$type, $notes, @groups];
972 : parrello 1.4 }
973 :     }
974 :     }
975 :     # Return the result.
976 : parrello 1.10 return %retVal;
977 : parrello 1.4 }
978 :    
979 : parrello 1.15 =head2 Internal Utility Methods
980 :    
981 :     =head3 _KeywordString
982 :    
983 :     C<< my $keywordString = $ca->_KeywordString($key, $value); >>
984 :    
985 :     Compute the keyword string for a specified key/value pair. This consists of the
986 :     key name and value converted to lower case with underscores translated to spaces.
987 :    
988 :     This method is for internal use only. It is called whenever we need to update or
989 :     insert a B<HasValueFor> record.
990 :    
991 :     =over 4
992 :    
993 :     =item key
994 :    
995 :     Name of the relevant attribute key.
996 :    
997 :     =item target
998 :    
999 :     ID of the target object to which this key/value pair will be associated.
1000 :    
1001 :     =item value
1002 :    
1003 :     The value to store for this key/object combination.
1004 :    
1005 :     =item RETURN
1006 :    
1007 :     Returns the value that should be stored as the keyword string for the specified
1008 :     key/value pair.
1009 :    
1010 :     =back
1011 :    
1012 :     =cut
1013 :    
1014 :     sub _KeywordString {
1015 :     # Get the parameters.
1016 :     my ($self, $key, $value) = @_;
1017 :     # Get a copy of the key name and convert underscores to spaces.
1018 :     my $keywordString = $key;
1019 :     $keywordString =~ s/_/ /g;
1020 :     # Add the value convert it all to lower case.
1021 :     my $retVal = lc "$keywordString $value";
1022 :     # Return the result.
1023 :     return $retVal;
1024 :     }
1025 :    
1026 :     =head3 _QueryResults
1027 :    
1028 :     C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1029 :    
1030 :     Match the results of a B<HasValueFor> query against value criteria and return
1031 :     the results. This is an internal method that splits the values coming back
1032 :     and matches the sections against the specified section patterns. It serves
1033 :     as the back end to L</GetAttributes> and L</FindAttributes>.
1034 :    
1035 :     =over 4
1036 :    
1037 :     =item query
1038 :    
1039 :     A query object that will return the desired B<HasValueFor> records.
1040 :    
1041 :     =item values
1042 :    
1043 :     List of the desired attribute values, section by section. If C<undef>
1044 :     or an empty string is specified, all values in that section will match. A
1045 :     generic match can be requested by placing a percent sign (C<%>) at the end.
1046 :     In that case, all values that match up to and not including the percent sign
1047 :     will match. You may also specify a regular expression enclosed
1048 :     in slashes. All values that match the regular expression will be returned. For
1049 :     performance reasons, only values have this extra capability.
1050 :    
1051 :     =item RETURN
1052 :    
1053 :     Returns a list of tuples. The first element in the tuple is an object ID, the
1054 :     second is an attribute key, and the remaining elements are the sections of
1055 :     the attribute value. All of the tuples will match the criteria set forth in
1056 :     the parameter list.
1057 :    
1058 :     =back
1059 :    
1060 :     =cut
1061 :    
1062 :     sub _QueryResults {
1063 :     # Get the parameters.
1064 :     my ($self, $query, @values) = @_;
1065 :     # Declare the return value.
1066 :     my @retVal = ();
1067 :     # Get the number of value sections we have to match.
1068 :     my $sectionCount = scalar(@values);
1069 :     # Loop through the assignments found.
1070 :     while (my $row = $query->Fetch()) {
1071 :     # Get the current row's data.
1072 :     my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1073 :     'HasValueFor(value)']);
1074 :     # Break the value into sections.
1075 :     my @sections = split($self->{splitter}, $valueString);
1076 :     # Match each section against the incoming values. We'll assume we're
1077 :     # okay unless we learn otherwise.
1078 :     my $matching = 1;
1079 :     for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1080 :     # We need to check to see if this section is generic.
1081 :     my $value = $values[$i];
1082 :     Trace("Current value pattern is \"$value\".") if T(4);
1083 :     if (substr($value, -1, 1) eq '%') {
1084 :     Trace("Generic match used.") if T(4);
1085 :     # Here we have a generic match.
1086 :     my $matchLen = length($values[$i] - 1);
1087 :     $matching = substr($sections[$i], 0, $matchLen) eq
1088 :     substr($values[$i], 0, $matchLen);
1089 :     } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1090 :     Trace("Regular expression detected.") if T(4);
1091 :     # Here we have a regular expression match.
1092 :     my $section = $sections[$i];
1093 :     $matching = eval("\$section =~ $value");
1094 :     } else {
1095 :     # Here we have a strict match.
1096 :     Trace("Strict match used.") if T(4);
1097 :     $matching = ($sections[$i] eq $values[$i]);
1098 :     }
1099 :     }
1100 :     # If we match, output this row to the return list.
1101 :     if ($matching) {
1102 :     push @retVal, [$id, $key, @sections];
1103 :     }
1104 :     }
1105 :     # Return the rows found.
1106 :     return @retVal;
1107 :     }
1108 :    
1109 : parrello 1.3 =head2 FIG Method Replacements
1110 :    
1111 :     The following methods are used by B<FIG.pm> to replace the previous attribute functionality.
1112 : parrello 1.10 Some of the old functionality is no longer present: controlled vocabulary is no longer
1113 : parrello 1.3 supported and there is no longer any searching by URL. Fortunately, neither of these
1114 :     capabilities were used in the old system.
1115 :    
1116 : parrello 1.4 The methods here are the only ones supported by the B<RemoteCustomAttributes> object.
1117 :     The idea is that these methods represent attribute manipulation allowed by all users, while
1118 :     the others are only for privileged users with access to the attribute server.
1119 :    
1120 : parrello 1.3 In the previous implementation, an attribute had a value and a URL. In the new implementation,
1121 :     there is only a value. In this implementation, each attribute has only a value. These
1122 :     methods will treat the value as a list with the individual elements separated by the
1123 :     value of the splitter parameter on the constructor (L</new>). The default is double
1124 :     colons C<::>.
1125 :    
1126 : parrello 1.10 So, for example, an old-style keyword with a value of C<essential> and a URL of
1127 : parrello 1.3 C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default
1128 :     splitter value would be stored as
1129 :    
1130 :     essential::http://www.sciencemag.org/cgi/content/abstract/293/5538/2266
1131 :    
1132 :     The best performance is achieved by searching for a particular key for a specified
1133 :     feature or genome.
1134 :    
1135 :     =head3 GetAttributes
1136 :    
1137 : parrello 1.10 C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @values); >>
1138 : parrello 1.3
1139 :     In the database, attribute values are sectioned into pieces using a splitter
1140 :     value specified in the constructor (L</new>). This is not a requirement of
1141 :     the attribute system as a whole, merely a convenience for the purpose of
1142 : parrello 1.10 these methods. If a value has multiple sections, each section
1143 :     is matched against the corresponding criterion in the I<@valuePatterns> list.
1144 : parrello 1.3
1145 :     This method returns a series of tuples that match the specified criteria. Each tuple
1146 :     will contain an object ID, a key, and one or more values. The parameters to this
1147 : parrello 1.10 method therefore correspond structurally to the values expected in each tuple. In
1148 :     addition, you can ask for a generic search by suffixing a percent sign (C<%>) to any
1149 :     of the parameters. So, for example,
1150 : parrello 1.3
1151 : parrello 1.10 my @attributeList = $attrDB->GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);
1152 : parrello 1.3
1153 :     would return something like
1154 :    
1155 :     ['fig}100226.1.peg.1004', 'structure', 1, 2]
1156 :     ['fig}100226.1.peg.1004', 'structure1', 1, 2]
1157 :     ['fig}100226.1.peg.1004', 'structure2', 1, 2]
1158 :     ['fig}100226.1.peg.1004', 'structureA', 1, 2]
1159 :    
1160 : parrello 1.10 Use of C<undef> in any position acts as a wild card (all values). You can also specify
1161 :     a list reference in the ID column. Thus,
1162 :    
1163 :     my @attributeList = $attrDB->GetAttributes(['100226.1', 'fig|100226.1.%'], 'PUBMED');
1164 :    
1165 :     would get the PUBMED attribute data for Streptomyces coelicolor A3(2) and all its
1166 :     features.
1167 : parrello 1.3
1168 :     In addition to values in multiple sections, a single attribute key can have multiple
1169 :     values, so even
1170 :    
1171 : parrello 1.10 my @attributeList = $attrDB->GetAttributes($peg, 'virulent');
1172 : parrello 1.3
1173 :     which has no wildcard in the key or the object ID, may return multiple tuples.
1174 :    
1175 : parrello 1.10 Value matching in this system works very poorly, because of the way multiple values are
1176 :     stored. For the object ID and key name, we create queries that filter for the desired
1177 :     results. For the values, we do a comparison after the attributes are retrieved from the
1178 :     database. As a result, queries in which filter only on value end up reading the entire
1179 :     attribute table to find the desired results.
1180 : parrello 1.3
1181 :     =over 4
1182 :    
1183 :     =item objectID
1184 :    
1185 : parrello 1.10 ID of object whose attributes are desired. If the attributes are desired for multiple
1186 :     objects, this parameter can be specified as a list reference. If the attributes are
1187 :     desired for all objects, specify C<undef> or an empty string. Finally, you can specify
1188 :     attributes for a range of object IDs by putting a percent sign (C<%>) at the end.
1189 : parrello 1.3
1190 :     =item key
1191 :    
1192 : parrello 1.10 Attribute key name. A value of C<undef> or an empty string will match all
1193 :     attribute keys. If the values are desired for multiple keys, this parameter can be
1194 :     specified as a list reference. Finally, you can specify attributes for a range of
1195 :     keys by putting a percent sign (C<%>) at the end.
1196 : parrello 1.3
1197 : parrello 1.10 =item values
1198 : parrello 1.3
1199 :     List of the desired attribute values, section by section. If C<undef>
1200 : parrello 1.10 or an empty string is specified, all values in that section will match. A
1201 :     generic match can be requested by placing a percent sign (C<%>) at the end.
1202 :     In that case, all values that match up to and not including the percent sign
1203 : parrello 1.14 will match. You may also specify a regular expression enclosed
1204 :     in slashes. All values that match the regular expression will be returned. For
1205 :     performance reasons, only values have this extra capability.
1206 : parrello 1.3
1207 :     =item RETURN
1208 :    
1209 :     Returns a list of tuples. The first element in the tuple is an object ID, the
1210 :     second is an attribute key, and the remaining elements are the sections of
1211 :     the attribute value. All of the tuples will match the criteria set forth in
1212 :     the parameter list.
1213 :    
1214 :     =back
1215 :    
1216 :     =cut
1217 :    
1218 :     sub GetAttributes {
1219 : parrello 1.4 # Get the parameters.
1220 : parrello 1.10 my ($self, $objectID, $key, @values) = @_;
1221 :     # We will create one big honking query. The following hash will build the filter
1222 :     # clause and a parameter list.
1223 : parrello 1.11 my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);
1224 : parrello 1.10 my @filter = ();
1225 :     my @parms = ();
1226 :     # This next loop goes through the different fields that can be specified in the
1227 :     # parameter list and generates filters for each.
1228 :     for my $field (keys %data) {
1229 :     # Accumulate filter information for this field. We will OR together all the
1230 :     # elements accumulated to create the final result.
1231 :     my @fieldFilter = ();
1232 :     # Get the specified data from the caller.
1233 :     my $fieldPattern = $data{$field};
1234 :     # Only proceed if the pattern is one that won't match everything.
1235 :     if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {
1236 :     # Convert the pattern to an array.
1237 :     my @patterns = ();
1238 :     if (ref $fieldPattern eq 'ARRAY') {
1239 :     push @patterns, @{$fieldPattern};
1240 :     } else {
1241 :     push @patterns, $fieldPattern;
1242 :     }
1243 :     # Only proceed if the array is nonempty. The loop will work fine if the
1244 :     # array is empty, but when we build the filter string at the end we'll
1245 :     # get "()" in the filter list, which will result in an SQL syntax error.
1246 :     if (@patterns) {
1247 :     # Loop through the individual patterns.
1248 :     for my $pattern (@patterns) {
1249 :     # Check for a generic request.
1250 :     if (substr($pattern, -1, 1) ne '%') {
1251 :     # Here we have a normal request.
1252 :     push @fieldFilter, "$field = ?";
1253 :     push @parms, $pattern;
1254 :     } else {
1255 :     # Here we have a generate request, so we will use the LIKE operator to
1256 :     # filter the field to this value pattern.
1257 :     push @fieldFilter, "$field LIKE ?";
1258 :     # We must convert the pattern value to an SQL match pattern. First
1259 : parrello 1.11 # we get a copy of it.
1260 :     my $actualPattern = $pattern;
1261 : parrello 1.10 # Now we escape the underscores. Underscores are an SQL wild card
1262 :     # character, but they are used frequently in key names and object IDs.
1263 : parrello 1.11 $actualPattern =~ s/_/\\_/g;
1264 : parrello 1.10 # Add the escaped pattern to the bound parameter list.
1265 :     push @parms, $actualPattern;
1266 :     }
1267 :     }
1268 :     # Form the filter for this field.
1269 :     my $fieldFilterString = join(" OR ", @fieldFilter);
1270 :     push @filter, "($fieldFilterString)";
1271 :     }
1272 :     }
1273 :     }
1274 :     # Now @filter contains one or more filter strings and @parms contains the parameter
1275 :     # values to bind to them.
1276 :     my $actualFilter = join(" AND ", @filter);
1277 :     # Now we're ready to make our query.
1278 : parrello 1.11 my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1279 : parrello 1.15 # Format the results.
1280 :     my @retVal = $self->_QueryResults($query, @values);
1281 : parrello 1.10 # Return the rows found.
1282 : parrello 1.3 return @retVal;
1283 :     }
1284 :    
1285 : parrello 1.15 =head3 FindAttributes
1286 :    
1287 :     C<< my @attributeList = $attrDB->FindAttributes($searchString); >>
1288 :    
1289 :     Search for attributes relevant to a specified keyword. This method performs
1290 :     a full-text search for attribute data. It returns the same information as
1291 :     L</GetAttributes>, except instead of filtering on specific keys or objects we do
1292 :     a text search of the entire <strong>HasValueFor</strong> table.
1293 :    
1294 :     =over 4
1295 :    
1296 :     =item searchString
1297 :    
1298 :     Search string to use. The syntax is the same as it is for any ERDB keyword
1299 :     search.
1300 :    
1301 :     =item RETURN
1302 :    
1303 :     Returns a list of tuples. The first element in the tuple is an object ID, the
1304 :     second is an attribute key, and the remaining elements are the sections of
1305 :     the attribute value. All of the tuples will match the criteria expressed in
1306 :     the search string.
1307 :    
1308 :     =back
1309 :    
1310 :     =cut
1311 :    
1312 :     sub FindAttributes {
1313 :     # Get the parameters.
1314 :     my ($self, $searchString) = @_;
1315 :     # Search the database.
1316 :     my $query = $self->Search($searchString, 0, ['HasValueFor'], "", []);
1317 :     # Build the results from the query.
1318 :     my @retVal = $self->_QueryResults($query);
1319 :     # Return the result.
1320 :     return @retVal;
1321 :     }
1322 :    
1323 : parrello 1.3 =head3 AddAttribute
1324 :    
1325 :     C<< $attrDB->AddAttribute($objectID, $key, @values); >>
1326 :    
1327 :     Add an attribute key/value pair to an object. This method cannot add a new key, merely
1328 :     add a value to an existing key. Use L</StoreAttributeKey> to create a new key.
1329 :    
1330 :     =over 4
1331 :    
1332 :     =item objectID
1333 :    
1334 : parrello 1.10 ID of the object to which the attribute is to be added.
1335 : parrello 1.3
1336 :     =item key
1337 :    
1338 : parrello 1.10 Attribute key name.
1339 : parrello 1.3
1340 :     =item values
1341 :    
1342 :     One or more values to be associated with the key. The values are joined together with
1343 :     the splitter value before being stored as field values. This enables L</GetAttributes>
1344 :     to split them apart during retrieval. The splitter value defaults to double colons C<::>.
1345 :    
1346 :     =back
1347 :    
1348 :     =cut
1349 :    
1350 :     sub AddAttribute {
1351 :     # Get the parameters.
1352 : parrello 1.4 my ($self, $objectID, $key, @values) = @_;
1353 : parrello 1.3 # Don't allow undefs.
1354 :     if (! defined($objectID)) {
1355 :     Confess("No object ID specified for AddAttribute call.");
1356 :     } elsif (! defined($key)) {
1357 :     Confess("No attribute key specified for AddAttribute call.");
1358 :     } elsif (! @values) {
1359 :     Confess("No values specified in AddAttribute call for key $key.");
1360 :     } else {
1361 : parrello 1.11 # Okay, now we have some reason to believe we can do this. Form the values
1362 :     # into a scalar.
1363 : parrello 1.3 my $valueString = join($self->{splitter}, @values);
1364 : parrello 1.11 # Connect the object to the key.
1365 :     $self->InsertObject('HasValueFor', { 'from-link' => $key,
1366 :     'to-link' => $objectID,
1367 : parrello 1.15 'keywords' => $self->_KeywordString($key, $valueString),
1368 : parrello 1.11 'value' => $valueString,
1369 :     });
1370 : parrello 1.3 }
1371 : parrello 1.10 # Return a one, indicating success. We do this for backward compatability.
1372 : parrello 1.3 return 1;
1373 :     }
1374 :    
1375 :     =head3 DeleteAttribute
1376 :    
1377 :     C<< $attrDB->DeleteAttribute($objectID, $key, @values); >>
1378 :    
1379 :     Delete the specified attribute key/value combination from the database.
1380 :    
1381 :     =over 4
1382 :    
1383 :     =item objectID
1384 :    
1385 : parrello 1.10 ID of the object whose attribute is to be deleted.
1386 : parrello 1.3
1387 :     =item key
1388 :    
1389 : parrello 1.10 Attribute key name.
1390 : parrello 1.3
1391 :     =item values
1392 :    
1393 : parrello 1.10 One or more values associated with the key. If no values are specified, then all values
1394 :     will be deleted. Otherwise, only a matching value will be deleted.
1395 : parrello 1.3
1396 :     =back
1397 :    
1398 :     =cut
1399 :    
1400 :     sub DeleteAttribute {
1401 :     # Get the parameters.
1402 : parrello 1.4 my ($self, $objectID, $key, @values) = @_;
1403 : parrello 1.3 # Don't allow undefs.
1404 :     if (! defined($objectID)) {
1405 :     Confess("No object ID specified for DeleteAttribute call.");
1406 :     } elsif (! defined($key)) {
1407 :     Confess("No attribute key specified for DeleteAttribute call.");
1408 : parrello 1.11 } elsif (scalar(@values) == 0) {
1409 :     # Here we erase the entire key.
1410 :     $self->EraseAttribute($key);
1411 : parrello 1.3 } else {
1412 : parrello 1.11 # Here we erase the matching values.
1413 :     my $valueString = join($self->{splitter}, @values);
1414 :     $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });
1415 : parrello 1.3 }
1416 :     # Return a one. This is for backward compatability.
1417 :     return 1;
1418 :     }
1419 :    
1420 :     =head3 ChangeAttribute
1421 :    
1422 :     C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
1423 :    
1424 :     Change the value of an attribute key/value pair for an object.
1425 :    
1426 :     =over 4
1427 :    
1428 :     =item objectID
1429 :    
1430 :     ID of the genome or feature to which the attribute is to be changed. In general, an ID that
1431 :     starts with C<fig|> is treated as a feature ID, and an ID that is all digits and periods
1432 :     is treated as a genome ID. For IDs of other types, this parameter should be a reference
1433 :     to a 2-tuple consisting of the entity type name followed by the object ID.
1434 :    
1435 :     =item key
1436 :    
1437 :     Attribute key name. This corresponds to the name of a field in the database.
1438 :    
1439 :     =item oldValues
1440 :    
1441 :     One or more values identifying the key/value pair to change.
1442 :    
1443 :     =item newValues
1444 :    
1445 :     One or more values to be put in place of the old values.
1446 :    
1447 :     =back
1448 :    
1449 :     =cut
1450 :    
1451 :     sub ChangeAttribute {
1452 :     # Get the parameters.
1453 : parrello 1.4 my ($self, $objectID, $key, $oldValues, $newValues) = @_;
1454 : parrello 1.3 # Don't allow undefs.
1455 :     if (! defined($objectID)) {
1456 :     Confess("No object ID specified for ChangeAttribute call.");
1457 :     } elsif (! defined($key)) {
1458 :     Confess("No attribute key specified for ChangeAttribute call.");
1459 :     } elsif (! defined($oldValues) || ref $oldValues ne 'ARRAY') {
1460 :     Confess("No old values specified in ChangeAttribute call for key $key.");
1461 :     } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {
1462 :     Confess("No new values specified in ChangeAttribute call for key $key.");
1463 :     } else {
1464 : parrello 1.10 # We do the change as a delete/add.
1465 : parrello 1.3 $self->DeleteAttribute($objectID, $key, @{$oldValues});
1466 :     $self->AddAttribute($objectID, $key, @{$newValues});
1467 :     }
1468 :     # Return a one. We do this for backward compatability.
1469 :     return 1;
1470 :     }
1471 :    
1472 : parrello 1.7 =head3 EraseAttribute
1473 :    
1474 : parrello 1.11 C<< $attrDB->EraseAttribute($key); >>
1475 : parrello 1.7
1476 :     Erase all values for the specified attribute key. This does not remove the
1477 :     key from the database; it merely removes all the values.
1478 :    
1479 :     =over 4
1480 :    
1481 :     =item key
1482 :    
1483 :     Key to erase.
1484 :    
1485 :     =back
1486 :    
1487 :     =cut
1488 :    
1489 :     sub EraseAttribute {
1490 :     # Get the parameters.
1491 : parrello 1.10 my ($self, $key) = @_;
1492 :     # Delete everything connected to the key. The "keepRoot" option keeps the key in the
1493 :     # datanase while deleting everything attached to it.
1494 :     $self->Delete('AttributeKey', $key, keepRoot => 1);
1495 : parrello 1.7 # Return a 1, for backward compatability.
1496 :     return 1;
1497 :     }
1498 :    
1499 : parrello 1.9 =head3 GetAttributeKeys
1500 :    
1501 : parrello 1.10 C<< my @keyList = $attrDB->GetAttributeKeys($groupName); >>
1502 : parrello 1.9
1503 : parrello 1.10 Return a list of the attribute keys for a particular group.
1504 : parrello 1.9
1505 :     =over 4
1506 :    
1507 : parrello 1.10 =item groupName
1508 : parrello 1.9
1509 : parrello 1.10 Name of the group whose keys are desired.
1510 : parrello 1.9
1511 :     =item RETURN
1512 :    
1513 : parrello 1.10 Returns a list of the attribute keys for the specified group.
1514 : parrello 1.9
1515 :     =back
1516 :    
1517 :     =cut
1518 :    
1519 :     sub GetAttributeKeys {
1520 :     # Get the parameters.
1521 : parrello 1.10 my ($self, $groupName) = @_;
1522 :     # Get the attributes for the specified group.
1523 :     my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(to-link) = ?", [$groupName],
1524 :     'IsInGroup(from-link)');
1525 : parrello 1.9 # Return the keys.
1526 : parrello 1.10 return sort @groups;
1527 : parrello 1.9 }
1528 :    
1529 : parrello 1.1 1;

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3