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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3