Annotation of /Sprout/CustomAttributes.pm

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

MCS Webmaster	ViewVC Help
Powered by ViewVC 1.0.3