[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.11, Wed Nov 29 20:28:52 2006 UTC revision 1.29, Wed Oct 3 05:23:37 2007 UTC
# Line 8  Line 8 
8      use strict;      use strict;
9      use Tracer;      use Tracer;
10      use ERDBLoad;      use ERDBLoad;
11        use Stats;
12        use Time::HiRes qw(time);
13    
14  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
15    
# Line 27  Line 29 
29  The actual attribute values are stored as a relationship between the attribute  The actual attribute values are stored as a relationship between the attribute
30  keys and the objects. There can be multiple values for a single key/object pair.  keys and the objects. There can be multiple values for a single key/object pair.
31    
32    =head3 Object IDs
33    
34    The object ID is normally represented as
35    
36        I<type>:I<id>
37    
38    where I<type> is the object type (C<Role>, C<Coupling>, etc.) and I<id> is
39    the actual object ID. Note that the object type must consist of only upper- and
40    lower-case letters! Thus, C<GenomeGroup> is a valid object type, but
41    C<genome_group> is not. Given that restriction, the object ID
42    
43        Family:aclame|cluster10
44    
45    would represent the FIG family C<aclame|cluster10>. For historical reasons,
46    there are three exceptions: subsystems, genomes, and features do not need
47    a type. So, for PEG 3361 of Streptomyces coelicolor A3(2), you simply code
48    
49        fig|100226.1.peg.3361
50    
51    The methods L</ParseID> and L</FormID> can be used to make this all seem
52    more consistent. Given any object ID string, L</ParseID> will convert it to an
53    object type and ID, and given any object type and ID, L</FormID> will
54    convert it to an object ID string. The attribute database is pretty
55    freewheeling about what it will allow for an ID; however, for best
56    results, the type should match an entity type from a Sprout genetics
57    database. If this rule is followed, then the database object
58    corresponding to an ID in the attribute database could be retrieved using
59    L</GetTargetObject> method.
60    
61        my $object = CustomAttributes::GetTargetObject($sprout, $idValue);
62    
63    =head3 Retrieval and Logging
64    
65  The full suite of ERDB retrieval capabilities is provided. In addition,  The full suite of ERDB retrieval capabilities is provided. In addition,
66  custom methods are provided specific to this application. To get all  custom methods are provided specific to this application. To get all
67  the values of the attribute C<essential> in a specified B<Feature>, you  the values of the attribute C<essential> in a specified B<Feature>, you
# Line 36  Line 71 
71    
72  where I<$fid> contains the ID of the desired feature.  where I<$fid> contains the ID of the desired feature.
73    
74  New attribute keys must be defined before they can be used. A web interface  Keys can be split into two pieces using the splitter value defined in the
75  is provided for this purpose.  constructor (the default is C<::>). The first piece of the key is called
76    the I<real key>. This portion of the key must be defined using the
77    web interface (C<Attributes.cgi>). The second portion of the key is called
78    the I<sub key>, and can take any value.
79    
80    Major attribute activity is recorded in a log (C<attributes.log>) in the
81    C<$FIG_Config::var> directory. The log reports the user name, time, and
82    the details of the operation. The user name will almost always be unknown,
83    the exception being when it is specified in this object's constructor
84    (see L</new>).
85    
86  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
87    
# Line 87  Line 131 
131    
132  =head3 new  =head3 new
133    
134  C<< my $attrDB = CustomAttributes->new($splitter); >>  C<< my $attrDB = CustomAttributes->new(%options); >>
135    
136  Construct a new CustomAttributes object.  Construct a new CustomAttributes object. The following options are
137    supported.
138    
139  =over 4  =over 4
140    
141  =item splitter  =item splitter
142    
143  Value to be used to split attribute values into sections in the  Value to be used to split attribute values into sections in the
144  L</Fig Replacement Methods>. The default is a double colon C<::>.  L</Fig Replacement Methods>. The default is a double colon C<::>,
145  If you do not use the replacement methods, you do not need to  and should only be overridden in extreme circumstances.
146  worry about this parameter.  
147    =item user
148    
149    Name of the current user. This will appear in the attribute log.
150    
151  =back  =back
152    
# Line 106  Line 154 
154    
155  sub new {  sub new {
156      # Get the parameters.      # Get the parameters.
157      my ($class, $splitter) = @_;      my ($class, %options) = @_;
158      # Connect to the database.      # Connect to the database.
159      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
160                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
# Line 116  Line 164 
164      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = $FIG_Config::attrDBD;
165      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
166      # Store the splitter value.      # Store the splitter value.
167      $retVal->{splitter} = (defined($splitter) ? $splitter : '::');      $retVal->{splitter} = $options{splitter} || '::';
168        # Store the user name.
169        $retVal->{user} = $options{user} || '<unknown>';
170        Trace("User $retVal->{user} selected for attribute object.") if T(3);
171      # Return the result.      # Return the result.
172      return $retVal;      return $retVal;
173  }  }
# Line 131  Line 182 
182    
183  =item attributeName  =item attributeName
184    
185  Name of the attribute. It must be a valid ERDB field name, consisting entirely of  Name of the attribute (the real key). If it does not exist already, it will be created.
 letters, digits, and hyphens, with a letter at the beginning. If it does not  
 exist already, it will be created.  
186    
187  =item type  =item type
188    
# Line 160  Line 209 
209      # Get the data type hash.      # Get the data type hash.
210      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
211      # Validate the initial input values.      # Validate the initial input values.
212      if (! ERDB::ValidateFieldName($attributeName)) {      if ($attributeName =~ /$self->{splitter}/) {
213          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
214      } elsif (! $notes || length($notes) < 25) {      } elsif (! $notes || length($notes) < 25) {
215          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
216      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
217          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid data type \"$type\" for $attributeName.");
218      } else {      } else {
219            # Create a variable to hold the action to be displayed for the log (Add or Update).
220            my $action;
221          # Okay, we're ready to begin. See if this key exists.          # Okay, we're ready to begin. See if this key exists.
222          my $attribute = $self->GetEntity('AttributeKey', $attributeName);          my $attribute = $self->GetEntity('AttributeKey', $attributeName);
223          if (defined($attribute)) {          if (defined($attribute)) {
224              # It does, so we do an update.              # It does, so we do an update.
225                $action = "Update Key";
226              $self->UpdateEntity('AttributeKey', $attributeName,              $self->UpdateEntity('AttributeKey', $attributeName,
227                                  { description => $notes, 'data-type' => $type });                                  { description => $notes, 'data-type' => $type });
228              # Detach the key from its current groups.              # Detach the key from its current groups.
229              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
230          } else {          } else {
231              # It doesn't, so we do an insert.              # It doesn't, so we do an insert.
232                $action = "Insert Key";
233              $self->InsertObject('AttributeKey', { id => $attributeName,              $self->InsertObject('AttributeKey', { id => $attributeName,
234                                  description => $notes, 'data-type' => $type });                                  description => $notes, 'data-type' => $type });
235          }          }
# Line 186  Line 239 
239              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
240                                                 'to-link'   => $group });                                                 'to-link'   => $group });
241          }          }
242            # Log the operation.
243            $self->LogOperation($action, $attributeName, "Group list is " . join(" ", @{$groups}));
244      }      }
245  }  }
246    
 =head3 LoadAttributeKey  
   
 C<< my $stats = $attrDB->LoadAttributeKey($keyName, $fh, $keyCol, $dataCol, %options); >>  
   
 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 object id value and the other the  
 corresponding attribute value.  
   
 =over 4  
   
 =item keyName  
   
 Key of the attribute to load.  
   
 =item fh  
   
 Open file handle for the input file.  
   
 =item idCol  
   
 Index (0-based) of the column containing the ID field. The ID field should  
 contain the ID of an instance of the named entity.  
   
 =item dataCol  
   
 Index (0-based) of the column containing the data value field.  
   
 =item options  
   
 Hash specifying the options for this load.  
   
 =item RETURN  
   
 Returns a statistics object for the load process.  
   
 =back  
   
 The available options are as follows.  
   
 =over 4  
   
 =item erase  
   
 If TRUE, the key's values will all be erased before loading. (Doing so  
 makes for a faster load.)  
   
 =back  
   
 =cut  
   
 sub LoadAttributeKey {  
     # Get the parameters.  
     my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;  
     # Create the return variable.  
     my $retVal = Stats->new("lineIn", "shortLine", "newObject");  
     # Compute the minimum number of fields required in each input line.  
     my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;  
     # Insure the attribute key exists.  
     my $found = $self->GetEntity('AttributeKey', $keyName);  
     if (! defined $found) {  
         Confess("Attribute key \"$keyName\" not found in database.");  
     } else {  
         # Erase the key's current values.  
         $self->EraseAttribute($keyName);  
         # Save a list of the object IDs we need to add.  
         my %objectIDs = ();  
         # Loop through the input file.  
         while (! eof $fh) {  
             # Get the next line of the file.  
             my @fields = Tracer::GetLine($fh);  
             $retVal->Add(lineIn => 1);  
             # Now we need to validate the line.  
             if (scalar(@fields) < $minCols) {  
                 $retVal->Add(shortLine => 1);  
             } else {  
                 # It's valid, so get the ID and value.  
                 my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);  
                 # Denote we're using this input line.  
                 $retVal->Add(lineUsed => 1);  
                 # Now the fun begins. Find out if we need to create a target object record for this object ID.  
                 if (! exists $objectIDs{$id}) {  
                     my $found = $self->Exists('TargetObject', $id);  
                     if (! $found) {  
                         $self->InsertObject('TargetObject', { id => $id });  
                     }  
                     $objectIDs{$id} = 1;  
                     $retVal->Add(newObject => 1);  
                 }  
                 # Now we insert the attribute.  
                 $self->InsertObject('HasValueFor', { from => $keyName, to => $id, value => $value });  
                 $retVal->Add(newValue => 1);  
             }  
         }  
     }  
     # Return the statistics.  
     return $retVal;  
 }  
   
247    
248  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
249    
# Line 315  Line 270 
270      my ($self, $attributeName) = @_;      my ($self, $attributeName) = @_;
271      # Delete the attribute key.      # Delete the attribute key.
272      my $retVal = $self->Delete('AttributeKey', $attributeName);      my $retVal = $self->Delete('AttributeKey', $attributeName);
273        # Log this operation.
274        $self->LogOperation("Delete Key", $attributeName, "Key will no longer be available for use by anyone.");
275      # Return the result.      # Return the result.
276      return $retVal;      return $retVal;
277    
# Line 388  Line 345 
345                                      -labels => \%labelMap,                                      -labels => \%labelMap,
346                                      -default => 'string');                                      -default => 'string');
347      # Allow the user to specify a new field name. This is required if the      # Allow the user to specify a new field name. This is required if the
348      # user has selected the "(new)" marker. We put a little scriptlet in here that      # user has selected the "(new)" marker.
     # selects the (new) marker when the user enters the field.  
     push @retVal, "<script language=\"javaScript\">";  
349      my $fieldField = "document.$name.fieldName";      my $fieldField = "document.$name.fieldName";
350      my $newName = "\"" . NewName() . "\"";      my $newName = "\"" . NewName() . "\"";
351      push @retVal, $cgi->Tr($cgi->th("New Field Name"),      push @retVal, $cgi->Tr($cgi->th("New Field Name"),
# Line 413  Line 368 
368                             $cgi->td($cgi->checkbox_group(-name=>'groups',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
369                                      -values=> \@groups))                                      -values=> \@groups))
370                            );                            );
371      # If the user wants to upload new values for the field, then we have      # Now the four buttons: STORE, SHOW, ERASE, and DELETE.
     # 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 three buttons: STORE, SHOW, and DELETE.  
372      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
373                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'}, join(" ",
374                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE'),
375                                      $cgi->submit(-name => 'Store',  -value => 'STORE') . " " .                                      $cgi->submit(-name => 'Store',  -value => 'STORE'),
376                                        $cgi->submit(-name => 'Erase',  -value => 'ERASE'),
377                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')
378                                     )                                     ))
379                            );                            );
380      # Close the table and the form.      # Close the table and the form.
381      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
# Line 445  Line 386 
386  =head3 LoadAttributesFrom  =head3 LoadAttributesFrom
387    
388  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
389    s
390  Load attributes from the specified tab-delimited file. Each line of the file must  Load attributes from the specified tab-delimited file. Each line of the file must
391  contain an object ID in the first column, an attribute key name in the second  contain an object ID in the first column, an attribute key name in the second
392  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values will
393  be assembled into a single value using the splitter code.  be assembled into a single value using the splitter code. In addition, the key names may
394    contain a splitter. If this is the case, the portion of the key after the splitter is
395    treated as a subkey.
396    
397  =over 4  =over 4
398    
399  =item fileName  =item fileName
400    
401  Name of the file from which to load the attributes.  Name of the file from which to load the attributes, or an open handle for the file.
402    (This last enables the method to be used in conjunction with the CGI form upload
403    control.)
404    
405  =item options  =item options
406    
# Line 476  Line 421 
421  If TRUE, then the attributes will be appended to existing data; otherwise, the  If TRUE, then the attributes will be appended to existing data; otherwise, the
422  first time a key name is encountered, it will be erased.  first time a key name is encountered, it will be erased.
423    
424    =item archive
425    
426    If specified, the name of a file into which the incoming data file should be saved.
427    
428    =item objectType
429    
430    If specified, the specified object type will be prefixed to each object ID.
431    
432    =item resume
433    
434    If specified, key-value pairs already in the database will not be reinserted.
435    
436  =back  =back
437    
438  =cut  =cut
# Line 485  Line 442 
442      my ($self, $fileName, %options) = @_;      my ($self, $fileName, %options) = @_;
443      # Declare the return variable.      # Declare the return variable.
444      my $retVal = Stats->new('keys', 'values');      my $retVal = Stats->new('keys', 'values');
445        # Initialize the timers.
446        my ($insertTime, $eraseTime, $archiveTime, $checkTime) = (0, 0, 0, 0);
447      # Check for append mode.      # Check for append mode.
448      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
449        # Check for resume mode.
450        my $resume = ($options{resume} ? 1 : 0);
451      # Create a hash of key names found.      # Create a hash of key names found.
452      my %keyHash = ();      my %keyHash = ();
453      # Open the file for input.      # Open the file for input. Note we must anticipate the possibility of an
454      my $fh = Open(undef, "<$fileName");      # open filehandle being passed in.
455        my $fh;
456        if (ref $fileName) {
457            Trace("Using file opened by caller.") if T(3);
458            $fh = $fileName;
459        } else {
460            Trace("Attributes will be loaded from $fileName.") if T(3);
461            $fh = Open(undef, "<$fileName");
462        }
463        # Now check to see if we need to archive.
464        my $ah;
465        if ($options{archive}) {
466            $ah = Open(undef, ">$options{archive}");
467            Trace("Load file will be archived to $options{archive}.") if T(3);
468        }
469        # Insure we recover from errors.
470        eval {
471      # Loop through the file.      # Loop through the file.
472      while (! eof $fh) {      while (! eof $fh) {
473                # Read the current line.
474          my ($id, $key, @values) = Tracer::GetLine($fh);          my ($id, $key, @values) = Tracer::GetLine($fh);
475          $retVal->Add(linesIn => 1);          $retVal->Add(linesIn => 1);
476                # Check to see if we need to fix up the object ID.
477                if ($options{objectType}) {
478                    $id = "$options{objectType}:$id";
479                }
480                # Archive the line (if necessary).
481                if (defined $ah) {
482                    my $startTime = time();
483                    Tracer::PutLine($ah, [$id, $key, @values]);
484                    $archiveTime += time() - $startTime;
485                }
486          # Do some validation.          # Do some validation.
487          if (! defined($id)) {              if (! $id) {
488              # We ignore blank lines.              # We ignore blank lines.
489              $retVal->Add(blankLines => 1);              $retVal->Add(blankLines => 1);
490                } elsif (substr($id, 0, 1) eq '#') {
491                    # A line beginning with a pound sign is a comment.
492                    $retVal->Add(comments => 1);
493          } elsif (! defined($key)) {          } elsif (! defined($key)) {
494              # An ID without a key is a serious error.              # An ID without a key is a serious error.
495              my $lines = $retVal->Ask('linesIn');              my $lines = $retVal->Ask('linesIn');
496              Confess("Line $lines in $fileName has no attribute key.");              Confess("Line $lines in $fileName has no attribute key.");
497                } elsif (! @values) {
498                    # A line with no values is not allowed.
499                    my $lines = $retVal->Ask('linesIn');
500                    Trace("Line $lines for key $key has no attribute values.") if T(1);
501                    $retVal->Add(skipped => 1);
502          } else {          } else {
503                    # The key contains a real part and an optional sub-part. We need the real part.
504                    my ($realKey, $subKey) = $self->SplitKey($key);
505              # Now we need to check for a new key.              # Now we need to check for a new key.
506              if (! exists $keyHash{$key}) {                  if (! exists $keyHash{$realKey}) {
507                  # This is a new key. Verify that it exists.                      if (! $self->Exists('AttributeKey', $realKey)) {
                 if (! $self->Exists('AttributeKey', $key)) {  
508                      my $line = $retVal->Ask('linesIn');                      my $line = $retVal->Ask('linesIn');
509                      Confess("Attribute \"$key\" on line $line of $fileName not found in database.");                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
510                  } else {                  } else {
511                      # Make sure we know this is no longer a new key.                      # Make sure we know this is no longer a new key.
512                      $keyHash{$key} = 1;                          $keyHash{$realKey} = 1;
513                      $retVal->Add(keys => 1);                      $retVal->Add(keys => 1);
514                      # If this is NOT append mode, erase the key.                      # If this is NOT append mode, erase the key.
515                      if (! $append) {                      if (! $append) {
516                          $self->EraseAttribute($key);                              my $startTime = time();
517                      }                              $self->EraseAttribute($realKey);
518                  }                              $eraseTime += time() - $startTime;
519                  Trace("Key $key found.") if T(3);                              Trace("Attribute $realKey erased.") if T(3);
520              }                          }
521              # Now we know the key is valid. Add this value.                      }
522                        Trace("Key $realKey found.") if T(3);
523                    }
524                    # If we're in resume mode, check to see if this insert is redundant.
525                    my $ok = 1;
526                    if ($resume) {
527                        my $startTime = time();
528                        my $count = $self->GetAttributes($id, $key, @values);
529                        $ok = ! $count;
530                        $checkTime += time() - $startTime;
531                    }
532                    if ($ok) {
533                        # Everything is all set up, so add the value.
534                        my $startTime = time();
535              $self->AddAttribute($id, $key, @values);              $self->AddAttribute($id, $key, @values);
536                        $insertTime += time() - $startTime;
537                        # Turn off resume mode.
538                        $resume = 0;
539                    } else {
540                        # Here we skipped because of resume mode.
541                        $retVal->Add(resumeSkip => 1);
542                    }
543    
544              my $progress = $retVal->Add(values => 1);              my $progress = $retVal->Add(values => 1);
545              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
546                }
547            }
548            $retVal->Add(eraseTime   => $eraseTime);
549            $retVal->Add(insertTime  => $insertTime);
550            $retVal->Add(archiveTime => $archiveTime);
551            $retVal->Add(checkTime   => $checkTime);
552        };
553        # Check for an error.
554        if ($@) {
555            # Here we have an error. Display the error message.
556            my $message = $@;
557            Trace("Error during attribute load: $message") if T(0);
558            $retVal->AddMessage($message);
559        }
560        # Close the archive file, if any.
561        if (defined $ah) {
562            Trace("Closing archive file $options{archive}.") if T(2);
563            close $ah;
564        }
565        # Return the result.
566        return $retVal;
567    }
568    
569    =head3 BackupKeys
570    
571    C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
572    
573    Backup the attribute key information from the attribute database.
574    
575    =over 4
576    
577    =item fileName
578    
579    Name of the output file.
580    
581    =item options
582    
583    Options for modifying the backup process.
584    
585    =item RETURN
586    
587    Returns a statistics object for the backup.
588    
589    =back
590    
591    Currently there are no options. The backup is straight to a text file in
592    tab-delimited format. Each key is backup up to two lines. The first line
593    is all of the data from the B<AttributeKey> table. The second is a
594    tab-delimited list of all the groups.
595    
596    =cut
597    
598    sub BackupKeys {
599        # Get the parameters.
600        my ($self, $fileName, %options) = @_;
601        # Declare the return variable.
602        my $retVal = Stats->new();
603        # Open the output file.
604        my $fh = Open(undef, ">$fileName");
605        # Set up to read the keys.
606        my $keyQuery = $self->Get(['AttributeKey'], "", []);
607        # Loop through the keys.
608        while (my $keyData = $keyQuery->Fetch()) {
609            $retVal->Add(key => 1);
610            # Get the fields.
611            my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
612                                                              'AttributeKey(description)']);
613            # Escape any tabs or new-lines in the description.
614            my $escapedDescription = Tracer::Escape($description);
615            # Write the key data to the output.
616            Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
617            # Get the key's groups.
618            my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
619                                        'IsInGroup(to-link)');
620            $retVal->Add(memberships => scalar(@groups));
621            # Write them to the output. Note we put a marker at the beginning to insure the line
622            # is nonempty.
623            Tracer::PutLine($fh, ['#GROUPS', @groups]);
624          }          }
625        # Log the operation.
626        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
627        # Return the result.
628        return $retVal;
629      }      }
630    
631    =head3 RestoreKeys
632    
633    C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
634    
635    Restore the attribute keys and groups from a backup file.
636    
637    =over 4
638    
639    =item fileName
640    
641    Name of the file containing the backed-up keys. Each key has a pair of lines,
642    one containing the key data and one listing its groups.
643    
644    =back
645    
646    =cut
647    
648    sub RestoreKeys {
649        # Get the parameters.
650        my ($self, $fileName, %options) = @_;
651        # Declare the return variable.
652        my $retVal = Stats->new();
653        # Set up a hash to hold the group IDs.
654        my %groups = ();
655        # Open the file.
656        my $fh = Open(undef, "<$fileName");
657        # Loop until we're done.
658        while (! eof $fh) {
659            # Get a key record.
660            my ($id, $dataType, $description) = Tracer::GetLine($fh);
661            if ($id eq '#GROUPS') {
662                Confess("Group record found when key record expected.");
663            } elsif (! defined($description)) {
664                Confess("Invalid format found for key record.");
665            } else {
666                $retVal->Add("keyIn" => 1);
667                # Add this key to the database.
668                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
669                                                      description => Tracer::UnEscape($description) });
670                Trace("Attribute $id stored.") if T(3);
671                # Get the group line.
672                my ($marker, @groups) = Tracer::GetLine($fh);
673                if (! defined($marker)) {
674                    Confess("End of file found where group record expected.");
675                } elsif ($marker ne '#GROUPS') {
676                    Confess("Group record not found after key record.");
677                } else {
678                    $retVal->Add(memberships => scalar(@groups));
679                    # Connect the groups.
680                    for my $group (@groups) {
681                        # Find out if this is a new group.
682                        if (! $groups{$group}) {
683                            $retVal->Add(newGroup => 1);
684                            # Add the group.
685                            $self->InsertObject('AttributeGroup', { id => $group });
686                            Trace("Group $group created.") if T(3);
687                            # Make sure we know it's not new.
688                            $groups{$group} = 1;
689                        }
690                        # Connect the group to our key.
691                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
692                    }
693                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
694                }
695            }
696        }
697        # Log the operation.
698        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
699        # Return the result.
700        return $retVal;
701    }
702    
703    =head3 ArchiveFileName
704    
705    C<< my $fileName = $ca->ArchiveFileName(); >>
706    
707    Compute a file name for archiving attribute input data. The file will be in the attribute log directory
708    
709    =cut
710    
711    sub ArchiveFileName {
712        # Get the parameters.
713        my ($self) = @_;
714        # Declare the return variable.
715        my $retVal;
716        # We start by turning the timestamp into something usable as a file name.
717        my $now = Tracer::Now();
718        $now =~ tr/ :\//___/;
719        # Next we get the directory name.
720        my $dir = "$FIG_Config::var/attributes";
721        if (! -e $dir) {
722            Trace("Creating attribute file directory $dir.") if T(1);
723            mkdir $dir;
724        }
725        # Put it together with the field name and the time stamp.
726        $retVal = "$dir/upload.$now";
727        # Modify the file name to insure it's unique.
728        my $seq = 0;
729        while (-e "$retVal.$seq.tbl") { $seq++ }
730        # Use the computed sequence number to get the correct file name.
731        $retVal .= ".$seq.tbl";
732      # Return the result.      # Return the result.
733      return $retVal;      return $retVal;
734  }  }
# Line 568  Line 769 
769      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
770      Trace(scalar(@keys) . " keys found during backup.") if T(2);      Trace(scalar(@keys) . " keys found during backup.") if T(2);
771      # Open the file for output.      # Open the file for output.
772      my $fh = Open(undef, $fileName);      my $fh = Open(undef, ">$fileName");
773      # Loop through the keys.      # Loop through the keys.
774      for my $key (@keys) {      for my $key (@keys) {
775          Trace("Backing up attribute $key.") if T(3);          Trace("Backing up attribute $key.") if T(3);
776          $retVal->Add(keys => 1);          $retVal->Add(keys => 1);
777          # Loop through this key's values.          # Loop through this key's values.
778          my $query = $self->Get(['HasValueFor'], "HasValueFor(to-link) = ?", [$key]);          my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
779          my $valuesFound = 0;          my $valuesFound = 0;
780          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
781              $valuesFound++;              $valuesFound++;
782              # Get this row's data.              # Get this row's data.
783              my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',              my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',
784                                                                 'HasValueFor(from-link)',
785                                                                 'HasValueFor(subkey)',
786                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
787                # Check for a subkey.
788                if ($subKey ne '') {
789                    $key = "$key$self->{splitter}$subKey";
790                }
791              # Write it to the file.              # Write it to the file.
792              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, [$id, $key, $value]);
793          }          }
794          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
795          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
796      }      }
797        # Log the operation.
798        $self->LogOperation("Backup Data", $fileName, $retVal->Display());
799      # Return the result.      # Return the result.
800      return $retVal;      return $retVal;
801  }  }
# Line 851  Line 1060 
1060      return %retVal;      return %retVal;
1061  }  }
1062    
1063    =head3 LogOperation
1064    
1065    C<< $ca->LogOperation($action, $target, $description); >>
1066    
1067    Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).
1068    
1069    =over 4
1070    
1071    =item action
1072    
1073    Action being logged (e.g. C<Delete Group> or C<Load Key>).
1074    
1075    =item target
1076    
1077    ID of the key or group affected.
1078    
1079    =item description
1080    
1081    Short description of the action.
1082    
1083    =back
1084    
1085    =cut
1086    
1087    sub LogOperation {
1088        # Get the parameters.
1089        my ($self, $action, $target, $description) = @_;
1090        # Get the user ID.
1091        my $user = $self->{user};
1092        # Get a timestamp.
1093        my $timeString = Tracer::Now();
1094        # Open the log file for appending.
1095        my $oh = Open(undef, ">>$FIG_Config::var/attributes.log");
1096        # Write the data to it.
1097        Tracer::PutLine($oh, [$timeString, $user, $action, $target, $description]);
1098        # Close the log file.
1099        close $oh;
1100    }
1101    
1102    =head2 Internal Utility Methods
1103    
1104    =head3 _KeywordString
1105    
1106    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
1107    
1108    Compute the keyword string for a specified key/value pair. This consists of the
1109    key name and value converted to lower case with underscores translated to spaces.
1110    
1111    This method is for internal use only. It is called whenever we need to update or
1112    insert a B<HasValueFor> record.
1113    
1114    =over 4
1115    
1116    =item key
1117    
1118    Name of the relevant attribute key.
1119    
1120    =item target
1121    
1122    ID of the target object to which this key/value pair will be associated.
1123    
1124    =item value
1125    
1126    The value to store for this key/object combination.
1127    
1128    =item RETURN
1129    
1130    Returns the value that should be stored as the keyword string for the specified
1131    key/value pair.
1132    
1133    =back
1134    
1135    =cut
1136    
1137    sub _KeywordString {
1138        # Get the parameters.
1139        my ($self, $key, $value) = @_;
1140        # Get a copy of the key name and convert underscores to spaces.
1141        my $keywordString = $key;
1142        $keywordString =~ s/_/ /g;
1143        # Add the value convert it all to lower case.
1144        my $retVal = lc "$keywordString $value";
1145        # Return the result.
1146        return $retVal;
1147    }
1148    
1149    =head3 _QueryResults
1150    
1151    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1152    
1153    Match the results of a B<HasValueFor> query against value criteria and return
1154    the results. This is an internal method that splits the values coming back
1155    and matches the sections against the specified section patterns. It serves
1156    as the back end to L</GetAttributes> and L</FindAttributes>.
1157    
1158    =over 4
1159    
1160    =item query
1161    
1162    A query object that will return the desired B<HasValueFor> records.
1163    
1164    =item values
1165    
1166    List of the desired attribute values, section by section. If C<undef>
1167    or an empty string is specified, all values in that section will match. A
1168    generic match can be requested by placing a percent sign (C<%>) at the end.
1169    In that case, all values that match up to and not including the percent sign
1170    will match. You may also specify a regular expression enclosed
1171    in slashes. All values that match the regular expression will be returned. For
1172    performance reasons, only values have this extra capability.
1173    
1174    =item RETURN
1175    
1176    Returns a list of tuples. The first element in the tuple is an object ID, the
1177    second is an attribute key, and the remaining elements are the sections of
1178    the attribute value. All of the tuples will match the criteria set forth in
1179    the parameter list.
1180    
1181    =back
1182    
1183    =cut
1184    
1185    sub _QueryResults {
1186        # Get the parameters.
1187        my ($self, $query, @values) = @_;
1188        # Declare the return value.
1189        my @retVal = ();
1190        # Get the number of value sections we have to match.
1191        my $sectionCount = scalar(@values);
1192        # Loop through the assignments found.
1193        while (my $row = $query->Fetch()) {
1194            # Get the current row's data.
1195            my ($id, $realKey, $subKey, $valueString) = $row->Values(['HasValueFor(to-link)',
1196                                                                      'HasValueFor(from-link)',
1197                                                                      'HasValueFor(subkey)',
1198                                                                      'HasValueFor(value)'
1199                                                                    ]);
1200            # Form the key from the real key and the sub key.
1201            my $key = $self->JoinKey($realKey, $subKey);
1202            # Break the value into sections.
1203            my @sections = split($self->{splitter}, $valueString);
1204            # Match each section against the incoming values. We'll assume we're
1205            # okay unless we learn otherwise.
1206            my $matching = 1;
1207            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1208                # We need to check to see if this section is generic.
1209                my $value = $values[$i];
1210                Trace("Current value pattern is \"$value\".") if T(4);
1211                if (substr($value, -1, 1) eq '%') {
1212                    Trace("Generic match used.") if T(4);
1213                    # Here we have a generic match.
1214                    my $matchLen = length($values[$i]) - 1;
1215                    $matching = substr($sections[$i], 0, $matchLen) eq
1216                                substr($values[$i], 0, $matchLen);
1217                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1218                    Trace("Regular expression detected.") if T(4);
1219                    # Here we have a regular expression match.
1220                    my $section = $sections[$i];
1221                    $matching = eval("\$section =~ $value");
1222                } else {
1223                    # Here we have a strict match.
1224                    Trace("Strict match used.") if T(4);
1225                    $matching = ($sections[$i] eq $values[$i]);
1226                }
1227            }
1228            # If we match, output this row to the return list.
1229            if ($matching) {
1230                push @retVal, [$id, $key, @sections];
1231            }
1232        }
1233        # Return the rows found.
1234        return @retVal;
1235    }
1236    
1237  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1238    
1239  The following methods are used by B<FIG.pm> to replace the previous attribute functionality.  The following methods are used by B<FIG.pm> to replace the previous attribute functionality.
# Line 862  Line 1245 
1245  The idea is that these methods represent attribute manipulation allowed by all users, while  The idea is that these methods represent attribute manipulation allowed by all users, while
1246  the others are only for privileged users with access to the attribute server.  the others are only for privileged users with access to the attribute server.
1247    
1248  In the previous implementation, an attribute had a value and a URL. In the new implementation,  In the previous implementation, an attribute had a value and a URL. In this implementation,
1249  there is only a value. In this implementation, each attribute has only a value. These  each attribute has only a value. These methods will treat the value as a list with the individual
1250  methods will treat the value as a list with the individual elements separated by the  elements separated by the value of the splitter parameter on the constructor (L</new>). The default
1251  value of the splitter parameter on the constructor (L</new>). The default is double  is double colons C<::>.
 colons C<::>.  
1252    
1253  So, for example, an old-style keyword with a value of C<essential> and a URL of  So, for example, an old-style keyword with a value of C<essential> and a URL of
1254  C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default  C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default
# Line 918  Line 1300 
1300  which has no wildcard in the key or the object ID, may return multiple tuples.  which has no wildcard in the key or the object ID, may return multiple tuples.
1301    
1302  Value matching in this system works very poorly, because of the way multiple values are  Value matching in this system works very poorly, because of the way multiple values are
1303  stored. For the object ID and key name, we create queries that filter for the desired  stored. For the object ID, key name, and first value, we create queries that filter for the
1304  results. For the values, we do a comparison after the attributes are retrieved from the  desired results. On any filtering by value, we must do a comparison after the attributes are
1305  database. As a result, queries in which filter only on value end up reading the entire  retrieved from the database, since the database has no notion of the multiple values, which
1306  attribute table to find the desired results.  are stored in a single string. As a result, queries in which filter only on value end up
1307    reading a lot more than they need to.
1308    
1309  =over 4  =over 4
1310    
# Line 945  Line 1328 
1328  or an empty string is specified, all values in that section will match. A  or an empty string is specified, all values in that section will match. A
1329  generic match can be requested by placing a percent sign (C<%>) at the end.  generic match can be requested by placing a percent sign (C<%>) at the end.
1330  In that case, all values that match up to and not including the percent sign  In that case, all values that match up to and not including the percent sign
1331  will match.  will match. You may also specify a regular expression enclosed
1332    in slashes. All values that match the regular expression will be returned. For
1333    performance reasons, only values have this extra capability.
1334    
1335  =item RETURN  =item RETURN
1336    
# Line 961  Line 1346 
1346  sub GetAttributes {  sub GetAttributes {
1347      # Get the parameters.      # Get the parameters.
1348      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1349      # We will create one big honking query. The following hash will build the filter      # This hash will map "HasValueFor" fields to patterns. We use it to build the
1350      # clause and a parameter list.      # SQL statement.
1351      my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);      my %data;
1352        # Before we do anything else, we must parse the key. The key is treated by the
1353        # user as a single field, but to us it's actually a real key and a subkey.
1354        # If the key has no splitter and is exact, the real key is the original key
1355        # and the subkey is an empty string. If the key has a splitter, it is
1356        # split into two pieces and each piece is processed separately. If the key has
1357        # no splitter and is generic, the real key is the incoming key and the subkey
1358        # is allowed to be wild. Of course, this only matters if an actual key has
1359        # been specified.
1360        if (defined $key) {
1361            if ($key =~ /$self->{splitter}/) {
1362                # Here we have a two-part key, so we split it normally.
1363                my ($realKey, $subKey) = $self->SplitKey($key);
1364                $data{'HasValueFor(from-link)'} = $realKey;
1365                $data{'HasValueFor(subkey)'} = $subKey;
1366            } elsif (substr($key, -1, 1) eq '%') {
1367                $data{'HasValueFor(from-link)'} = $key;
1368            } else {
1369                $data{'HasValueFor(from-link)'} = $key;
1370                $data{'HasValueFor(subkey)'} = '';
1371            }
1372        }
1373        # Add the object ID to the key information.
1374        $data{'HasValueFor(to-link)'} = $objectID;
1375        # The first value represents a problem, because we can search it using SQL, but not
1376        # in the normal way. If the user specifies a generic search or exact match for
1377        # every alternative value (remember, the values may be specified as a list),
1378        # then we can create SQL filtering for it. If any of the values are specified
1379        # as a regular expression, however, that's a problem, because we need to read
1380        # every value to verify a match.
1381        if (@values > 0) {
1382            # Get the first value and put its alternatives in an array.
1383            my $valueParm = $values[0];
1384            my @valueList;
1385            if (ref $valueParm eq 'ARRAY') {
1386                @valueList = @{$valueParm};
1387            } else {
1388                @valueList = ($valueParm);
1389            }
1390            # Okay, now we have all the possible criteria for the first value in the list
1391            # @valueList. We'll copy the values to a new array in which they have been
1392            # converted to generic requests. If we find a regular-expression match
1393            # anywhere in the list, we toss the whole thing.
1394            my @valuePatterns = ();
1395            my $okValues = 1;
1396            for my $valuePattern (@valueList) {
1397                # Check the pattern type.
1398                if (substr($valuePattern, 0, 1) eq '/') {
1399                    # Regular expressions invalidate the entire process.
1400                    $okValues = 0;
1401                } elsif (substr($valuePattern, -1, 1) eq '%') {
1402                    # A Generic pattern is passed in unmodified.
1403                    push @valuePatterns, $valuePattern;
1404                } else {
1405                    # An exact match is converted to generic.
1406                    push @valuePatterns, "$valuePattern%";
1407                }
1408            }
1409            # If everything works, add the value data to the filtering hash.
1410            if ($okValues) {
1411                $data{'HasValueFor(value)'} = \@valuePatterns;
1412            }
1413        }
1414        # Create some lists to contain the filter fragments and parameter values.
1415      my @filter = ();      my @filter = ();
1416      my @parms = ();      my @parms = ();
1417      # This next loop goes through the different fields that can be specified in the      # This next loop goes through the different fields that can be specified in the
1418      # parameter list and generates filters for each.      # parameter list and generates filters for each. The %data hash that we built above
1419        # contains all the necessary information to do this.
1420      for my $field (keys %data) {      for my $field (keys %data) {
1421          # Accumulate filter information for this field. We will OR together all the          # Accumulate filter information for this field. We will OR together all the
1422          # elements accumulated to create the final result.          # elements accumulated to create the final result.
# Line 995  Line 1444 
1444                          push @fieldFilter, "$field = ?";                          push @fieldFilter, "$field = ?";
1445                          push @parms, $pattern;                          push @parms, $pattern;
1446                      } else {                      } else {
1447                          # Here we have a generate request, so we will use the LIKE operator to                          # Here we have a generic request, so we will use the LIKE operator to
1448                          # filter the field to this value pattern.                          # filter the field to this value pattern.
1449                          push @fieldFilter, "$field LIKE ?";                          push @fieldFilter, "$field LIKE ?";
1450                          # We must convert the pattern value to an SQL match pattern. First                          # We must convert the pattern value to an SQL match pattern. First
# Line 1017  Line 1466 
1466      # Now @filter contains one or more filter strings and @parms contains the parameter      # Now @filter contains one or more filter strings and @parms contains the parameter
1467      # values to bind to them.      # values to bind to them.
1468      my $actualFilter = join(" AND ", @filter);      my $actualFilter = join(" AND ", @filter);
     # Declare the return variable.  
     my @retVal = ();  
     # Get the number of value sections we have to match.  
     my $sectionCount = scalar(@values);  
1469      # Now we're ready to make our query.      # Now we're ready to make our query.
1470      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1471      # Loop through the assignments found.      # Format the results.
1472      while (my $row = $query->Fetch()) {      my @retVal = $self->_QueryResults($query, @values);
         # Get the current row's data.  
         my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',  
                                                       'HasValueFor(value)']);  
         # Break the value into sections.  
         my @sections = split($self->{splitter}, $valueString);  
         # Match each section against the incoming values. We'll assume we're  
         # okay unless we learn otherwise.  
         my $matching = 1;  
         for (my $i = 0; $i < $sectionCount && $matching; $i++) {  
             # We need to check to see if this section is generic.  
             if (substr($values[$i], -1, 1) eq '%') {  
                 my $matchLen = length($values[$i] - 1);  
                 $matching = substr($sections[$i], 0, $matchLen) eq  
                             substr($values[$i], 0, $matchLen);  
             } else {  
                 $matching = ($sections[$i] eq $values[$i]);  
             }  
         }  
         # If we match, output this row to the return list.  
         if ($matching) {  
             push @retVal, [$id, $key, @sections];  
         }  
     }  
1473      # Return the rows found.      # Return the rows found.
1474      return @retVal;      return @retVal;
1475  }  }
# Line 1093  Line 1515 
1515          # Okay, now we have some reason to believe we can do this. Form the values          # Okay, now we have some reason to believe we can do this. Form the values
1516          # into a scalar.          # into a scalar.
1517          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1518            # Split up the key.
1519            my ($realKey, $subKey) = $self->SplitKey($key);
1520          # Connect the object to the key.          # Connect the object to the key.
1521          $self->InsertObject('HasValueFor', { 'from-link' => $key,          $self->InsertObject('HasValueFor', { 'from-link' => $realKey,
1522                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1523                                                 'subkey'    => $subKey,
1524                                               'value'     => $valueString,                                               'value'     => $valueString,
1525                                         });                                         });
1526      }      }
# Line 1136  Line 1561 
1561          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1562      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1563          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1564      } elsif (scalar(@values) == 0) {      } else {
1565          # Here we erase the entire key.          # Split the key into the real key and the subkey.
1566          $self->EraseAttribute($key);          my ($realKey, $subKey) = $self->SplitKey($key);
1567            if ($subKey eq '' && scalar(@values) == 0) {
1568                # Here we erase the entire key for this object.
1569                $self->DeleteRow('HasValueFor', $key, $objectID);
1570      } else {      } else {
1571          # Here we erase the matching values.          # Here we erase the matching values.
1572          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1573          $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });              $self->DeleteRow('HasValueFor', $realKey, $objectID,
1574                                 { subkey => $subKey, value => $valueString });
1575            }
1576      }      }
1577      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1578      return 1;      return 1;
1579  }  }
1580    
1581    =head3 DeleteMatchingAttributes
1582    
1583    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1584    
1585    Delete all attributes that match the specified criteria. This is equivalent to
1586    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1587    row found.
1588    
1589    =over 4
1590    
1591    =item objectID
1592    
1593    ID of object whose attributes are to be deleted. If the attributes for multiple
1594    objects are to be deleted, this parameter can be specified as a list reference. If
1595    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1596    Finally, you can delete attributes for a range of object IDs by putting a percent
1597    sign (C<%>) at the end.
1598    
1599    =item key
1600    
1601    Attribute key name. A value of C<undef> or an empty string will match all
1602    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1603    specified as a list reference. Finally, you can delete attributes for a range of
1604    keys by putting a percent sign (C<%>) at the end.
1605    
1606    =item values
1607    
1608    List of the desired attribute values, section by section. If C<undef>
1609    or an empty string is specified, all values in that section will match. A
1610    generic match can be requested by placing a percent sign (C<%>) at the end.
1611    In that case, all values that match up to and not including the percent sign
1612    will match. You may also specify a regular expression enclosed
1613    in slashes. All values that match the regular expression will be deleted. For
1614    performance reasons, only values have this extra capability.
1615    
1616    =item RETURN
1617    
1618    Returns a list of tuples for the attributes that were deleted, in the
1619    same form as L</GetAttributes>.
1620    
1621    =back
1622    
1623    =cut
1624    
1625    sub DeleteMatchingAttributes {
1626        # Get the parameters.
1627        my ($self, $objectID, $key, @values) = @_;
1628        # Get the matching attributes.
1629        my @retVal = $self->GetAttributes($objectID, $key, @values);
1630        # Loop through the attributes, deleting them.
1631        for my $tuple (@retVal) {
1632            $self->DeleteAttribute(@{$tuple});
1633        }
1634        # Log this operation.
1635        my $count = @retVal;
1636        $self->LogOperation("Mass Delete", $key, "$count matching attributes deleted.");
1637        # Return the deleted attributes.
1638        return @retVal;
1639    }
1640    
1641  =head3 ChangeAttribute  =head3 ChangeAttribute
1642    
1643  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1211  Line 1701 
1701    
1702  =item key  =item key
1703    
1704  Key to erase.  Key to erase. This must be a real key; that is, it cannot have a subkey
1705    component.
1706    
1707  =back  =back
1708    
# Line 1220  Line 1711 
1711  sub EraseAttribute {  sub EraseAttribute {
1712      # Get the parameters.      # Get the parameters.
1713      my ($self, $key) = @_;      my ($self, $key) = @_;
1714      # Delete everything connected to the key. The "keepRoot" option keeps the key in the      # Delete everything connected to the key.
1715      # datanase while deleting everything attached to it.      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1716      $self->Delete('AttributeKey', $key, keepRoot => 1);      # Log the operation.
1717        $self->LogOperation("Erase Data", $key);
1718      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1719      return 1;      return 1;
1720  }  }
# Line 1257  Line 1749 
1749      return sort @groups;      return sort @groups;
1750  }  }
1751    
1752    =head3 QueryAttributes
1753    
1754    C<< my @attributeData = $ca->QueryAttributes($filter, $filterParms); >>
1755    
1756    Return the attribute data based on an SQL filter clause. In the filter clause,
1757    the name C<$object> should be used for the object ID, C<$key> should be used for
1758    the key name, C<$subkey> for the subkey value, and C<$value> for the value field.
1759    
1760    =over 4
1761    
1762    =item filter
1763    
1764    Filter clause in the standard ERDB format, except that the field names are C<$object> for
1765    the object ID field, C<$key> for the key name field, C<$subkey> for the subkey field,
1766    and C<$value> for the value field. This abstraction enables us to hide the details of
1767    the database construction from the user.
1768    
1769    =item filterParms
1770    
1771    Parameters for the filter clause.
1772    
1773    =item RETURN
1774    
1775    Returns a list of tuples. Each tuple consists of an object ID, a key (with optional subkey), and
1776    one or more attribute values.
1777    
1778    =back
1779    
1780    =cut
1781    
1782    # This hash is used to drive the substitution process.
1783    my %AttributeParms = (object => 'HasValueFor(to-link)',
1784                          key    => 'HasValueFor(from-link)',
1785                          subkey => 'HasValueFor(subkey)',
1786                          value  => 'HasValueFor(value)');
1787    
1788    sub QueryAttributes {
1789        # Get the parameters.
1790        my ($self, $filter, $filterParms) = @_;
1791        # Declare the return variable.
1792        my @retVal = ();
1793        # Make sue we have filter parameters.
1794        my $realParms = (defined($filterParms) ? $filterParms : []);
1795        # Create the query by converting the filter.
1796        my $realFilter = $filter;
1797        for my $name (keys %AttributeParms) {
1798            $realFilter =~ s/\$$name/$AttributeParms{$name}/g;
1799        }
1800        my $query = $self->Get(['HasValueFor'], $realFilter, $realParms);
1801        # Loop through the results, forming the output attribute tuples.
1802        while (my $result = $query->Fetch()) {
1803            # Get the four values from this query result row.
1804            my ($objectID, $key, $subkey, $value) = $result->Values([$AttributeParms{object},
1805                                                                    $AttributeParms{key},
1806                                                                    $AttributeParms{subkey},
1807                                                                    $AttributeParms{value}]);
1808            # Combine the key and the subkey.
1809            my $realKey = ($subkey ? $key . $self->{splitter} . $subkey : $key);
1810            # Split the value.
1811            my @values = split $self->{splitter}, $value;
1812            # Output the result.
1813            push @retVal, [$objectID, $realKey, @values];
1814        }
1815        # Return the result.
1816        return @retVal;
1817    }
1818    
1819    =head2 Key and ID Manipulation Methods
1820    
1821    =head3 ParseID
1822    
1823    C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>
1824    
1825    Determine the type and object ID corresponding to an ID value from the attribute database.
1826    Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);
1827    however, Genomes, Features, and Subsystems are not stored with a type name, so we need to
1828    deduce the type from the ID value structure.
1829    
1830    The theory here is that you can plug the ID and type directly into a Sprout database method, as
1831    follows
1832    
1833        my ($type, $id) = CustomAttributes::ParseID($attrList[$num]->[0]);
1834        my $target = $sprout->GetEntity($type, $id);
1835    
1836    =over 4
1837    
1838    =item idValue
1839    
1840    ID value taken from the attribute database.
1841    
1842    =item RETURN
1843    
1844    Returns a two-element list. The first element is the type of object indicated by the ID value,
1845    and the second element is the actual object ID.
1846    
1847    =back
1848    
1849    =cut
1850    
1851    sub ParseID {
1852        # Get the parameters.
1853        my ($idValue) = @_;
1854        # Declare the return variables.
1855        my ($type, $id);
1856        # Parse the incoming ID. We first check for the presence of an entity name. Entity names
1857        # can only contain letters, which helps to insure typed object IDs don't collide with
1858        # subsystem names (which are untyped).
1859        if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1860            # Here we have a typed ID.
1861            ($type, $id) = ($1, $2);
1862            # Fix the case sensitivity on PDB IDs.
1863            if ($type eq 'PDB') { $id = lc $id; }
1864        } elsif ($idValue =~ /fig\|/) {
1865            # Here we have a feature ID.
1866            ($type, $id) = (Feature => $idValue);
1867        } elsif ($idValue =~ /\d+\.\d+/) {
1868            # Here we have a genome ID.
1869            ($type, $id) = (Genome => $idValue);
1870        } else {
1871            # The default is a subsystem ID.
1872            ($type, $id) = (Subsystem => $idValue);
1873        }
1874        # Return the results.
1875        return ($type, $id);
1876    }
1877    
1878    =head3 FormID
1879    
1880    C<< my $idValue = CustomAttributes::FormID($type, $id); >>
1881    
1882    Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,
1883    genomes, and features are stored in the database without type information, but all other object IDs
1884    must be prefixed with the object type.
1885    
1886    =over 4
1887    
1888    =item type
1889    
1890    Relevant object type.
1891    
1892    =item id
1893    
1894    ID of the object in question.
1895    
1896    =item RETURN
1897    
1898    Returns a string that will be recognized as an object ID in the attribute database.
1899    
1900    =back
1901    
1902    =cut
1903    
1904    sub FormID {
1905        # Get the parameters.
1906        my ($type, $id) = @_;
1907        # Declare the return variable.
1908        my $retVal;
1909        # Compute the ID string from the type.
1910        if (grep { $type eq $_ } qw(Feature Genome Subsystem)) {
1911            $retVal = $id;
1912        } else {
1913            $retVal = "$type:$id";
1914        }
1915        # Return the result.
1916        return $retVal;
1917    }
1918    
1919    =head3 GetTargetObject
1920    
1921    C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>
1922    
1923    Return the database object corresponding to the specified attribute object ID. The
1924    object type associated with the ID value must correspond to an entity name in the
1925    specified database.
1926    
1927    =over 4
1928    
1929    =item erdb
1930    
1931    B<ERDB> object for accessing the target database.
1932    
1933    =item idValue
1934    
1935    ID value retrieved from the attribute database.
1936    
1937    =item RETURN
1938    
1939    Returns a B<ERDBObject> for the attribute value's target object.
1940    
1941    =back
1942    
1943    =cut
1944    
1945    sub GetTargetObject {
1946        # Get the parameters.
1947        my ($erdb, $idValue) = @_;
1948        # Declare the return variable.
1949        my $retVal;
1950        # Get the type and ID for the target object.
1951        my ($type, $id) = ParseID($idValue);
1952        # Plug them into the GetEntity method.
1953        $retVal = $erdb->GetEntity($type, $id);
1954        # Return the resulting object.
1955        return $retVal;
1956    }
1957    
1958    =head3 SplitKey
1959    
1960    C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>
1961    
1962    Split an external key (that is, one passed in by a caller) into the real key and the sub key.
1963    The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,
1964    then the sub key is presumed to be an empty string.
1965    
1966    =over 4
1967    
1968    =item key
1969    
1970    Incoming key to be split.
1971    
1972    =item RETURN
1973    
1974    Returns a two-element list, the first element of which is the real key and the second element of
1975    which is the sub key.
1976    
1977    =back
1978    
1979    =cut
1980    
1981    sub SplitKey {
1982        # Get the parameters.
1983        my ($self, $key) = @_;
1984        # Do the split.
1985        my ($realKey, $subKey) = split($self->{splitter}, $key, 2);
1986        # Insure the subkey has a value.
1987        if (! defined $subKey) {
1988            $subKey = '';
1989        }
1990        # Return the results.
1991        return ($realKey, $subKey);
1992    }
1993    
1994    =head3 JoinKey
1995    
1996    C<< my $key = $ca->JoinKey($realKey, $subKey); >>
1997    
1998    Join a real key and a subkey together to make an external key. The external key is the attribute key
1999    used by the caller. The real key and the subkey are how the keys are represented in the database. The
2000    real key is the key to the B<AttributeKey> entity. The subkey is an attribute of the B<HasValueFor>
2001    relationship.
2002    
2003    =over 4
2004    
2005    =item realKey
2006    
2007    The real attribute key.
2008    
2009    =item subKey
2010    
2011    The subordinate portion of the attribute key.
2012    
2013    =item RETURN
2014    
2015    Returns a single string representing both keys.
2016    
2017    =back
2018    
2019    =cut
2020    
2021    sub JoinKey {
2022        # Get the parameters.
2023        my ($self, $realKey, $subKey) = @_;
2024        # Declare the return variable.
2025        my $retVal;
2026        # Check for a subkey.
2027        if ($subKey eq '') {
2028            # No subkey, so the real key is the key.
2029            $retVal = $realKey;
2030        } else {
2031            # Subkey found, so the two pieces must be joined by a splitter.
2032            $retVal = "$realKey$self->{splitter}$subKey";
2033        }
2034        # Return the result.
2035        return $retVal;
2036    }
2037    
2038    
2039    =head3 AttributeTable
2040    
2041    C<< my $tableHtml = CustomAttributes::AttributeTable($cgi, @attrList); >>
2042    
2043    Format the attribute data into an HTML table.
2044    
2045    =over 4
2046    
2047    =item cgi
2048    
2049    CGI query object used to generate the HTML
2050    
2051    =item attrList
2052    
2053    List of attribute results, in the format returned by the L</GetAttributes> or
2054    L</QueryAttributes> methods.
2055    
2056    =item RETURN
2057    
2058    Returns an HTML table displaying the attribute keys and values.
2059    
2060    =back
2061    
2062    =cut
2063    
2064    sub AttributeTable {
2065        # Get the parameters.
2066        my ($cgi, @attrList) = @_;
2067        # Accumulate the table rows.
2068        my @html = ();
2069        for my $attrData (@attrList) {
2070            # Format the object ID and key.
2071            my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];
2072            # Now we format the values. These remain unchanged unless one of them is a URL.
2073            my $lastValue = scalar(@{$attrData}) - 1;
2074            push @columns, map { $_ =~ /^http:/ ? $cgi->a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];
2075            # Assemble the values into a table row.
2076            push @html, $cgi->Tr($cgi->td(\@columns));
2077        }
2078        # Format the table in the return variable.
2079        my $retVal = $cgi->table({ border => 2 }, $cgi->Tr($cgi->th(['Object', 'Key', 'Values'])), @html);
2080        # Return it.
2081        return $retVal;
2082    }
2083  1;  1;

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.29

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3