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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3