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

Annotation of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.48 - (view) (download) (as text)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3