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

Diff of /Sprout/CustomAttributes.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.35

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3