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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3