[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.26, Mon Jun 11 18:44:40 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    
13  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
14    
# Line 27  Line 28 
28  The actual attribute values are stored as a relationship between the attribute  The actual attribute values are stored as a relationship between the attribute
29  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.
30    
31    =head3 Object IDs
32    
33    The object ID is normally represented as
34    
35        I<type>:I<id>
36    
37    where I<type> is the object type (C<Role>, C<Coupling>, etc.) and I<id> is
38    the actual object ID. Note that the object type must consist of only upper- and
39    lower-case letters! Thus, C<GenomeGroup> is a valid object type, but
40    C<genome_group> is not. Given that restriction, the object ID
41    
42        Family:aclame|cluster10
43    
44    would represent the FIG family C<aclame|cluster10>. For historical reasons,
45    there are three exceptions: subsystems, genomes, and features do not need
46    a type. So, for PEG 3361 of Streptomyces coelicolor A3(2), you simply code
47    
48        fig|100226.1.peg.3361
49    
50    The methods L</ParseID> and L</FormID> can be used to make this all seem
51    more consistent. Given any object ID string, L</ParseID> will convert it to an
52    object type and ID, and given any object type and ID, L</FormID> will
53    convert it to an object ID string. The attribute database is pretty
54    freewheeling about what it will allow for an ID; however, for best
55    results, the type should match an entity type from a Sprout genetics
56    database. If this rule is followed, then the database object
57    corresponding to an ID in the attribute database could be retrieved using
58    L</GetTargetObject> method.
59    
60        my $object = CustomAttributes::GetTargetObject($sprout, $idValue);
61    
62    =head3 Retrieval and Logging
63    
64  The full suite of ERDB retrieval capabilities is provided. In addition,  The full suite of ERDB retrieval capabilities is provided. In addition,
65  custom methods are provided specific to this application. To get all  custom methods are provided specific to this application. To get all
66  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 70 
70    
71  where I<$fid> contains the ID of the desired feature.  where I<$fid> contains the ID of the desired feature.
72    
73  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
74  is provided for this purpose.  constructor (the default is C<::>). The first piece of the key is called
75    the I<real key>. This portion of the key must be defined using the
76    web interface (C<Attributes.cgi>). The second portion of the key is called
77    the I<sub key>, and can take any value.
78    
79    Major attribute activity is recorded in a log (C<attributes.log>) in the
80    C<$FIG_Config::var> directory. The log reports the user name, time, and
81    the details of the operation. The user name will almost always be unknown,
82    the exception being when it is specified in this object's constructor
83    (see L</new>).
84    
85  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
86    
# Line 87  Line 130 
130    
131  =head3 new  =head3 new
132    
133  C<< my $attrDB = CustomAttributes->new($splitter); >>  C<< my $attrDB = CustomAttributes->new(%options); >>
134    
135  Construct a new CustomAttributes object.  Construct a new CustomAttributes object. The following options are
136    supported.
137    
138  =over 4  =over 4
139    
140  =item splitter  =item splitter
141    
142  Value to be used to split attribute values into sections in the  Value to be used to split attribute values into sections in the
143  L</Fig Replacement Methods>. The default is a double colon C<::>.  L</Fig Replacement Methods>. The default is a double colon C<::>,
144  If you do not use the replacement methods, you do not need to  and should only be overridden in extreme circumstances.
145  worry about this parameter.  
146    =item user
147    
148    Name of the current user. This will appear in the attribute log.
149    
150  =back  =back
151    
# Line 106  Line 153 
153    
154  sub new {  sub new {
155      # Get the parameters.      # Get the parameters.
156      my ($class, $splitter) = @_;      my ($class, %options) = @_;
157      # Connect to the database.      # Connect to the database.
158      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
159                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
# Line 116  Line 163 
163      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = $FIG_Config::attrDBD;
164      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
165      # Store the splitter value.      # Store the splitter value.
166      $retVal->{splitter} = (defined($splitter) ? $splitter : '::');      $retVal->{splitter} = $options{splitter} || '::';
167        # Store the user name.
168        $retVal->{user} = $options{user} || '<unknown>';
169        Trace("User $retVal->{user} selected for attribute object.") if T(3);
170      # Return the result.      # Return the result.
171      return $retVal;      return $retVal;
172  }  }
# Line 131  Line 181 
181    
182  =item attributeName  =item attributeName
183    
184  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.  
185    
186  =item type  =item type
187    
# Line 160  Line 208 
208      # Get the data type hash.      # Get the data type hash.
209      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
210      # Validate the initial input values.      # Validate the initial input values.
211      if (! ERDB::ValidateFieldName($attributeName)) {      if ($attributeName =~ /$self->{splitter}/) {
212          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
213      } elsif (! $notes || length($notes) < 25) {      } elsif (! $notes || length($notes) < 25) {
214          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
215      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
216          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid data type \"$type\" for $attributeName.");
217      } else {      } else {
218            # Create a variable to hold the action to be displayed for the log (Add or Update).
219            my $action;
220          # Okay, we're ready to begin. See if this key exists.          # Okay, we're ready to begin. See if this key exists.
221          my $attribute = $self->GetEntity('AttributeKey', $attributeName);          my $attribute = $self->GetEntity('AttributeKey', $attributeName);
222          if (defined($attribute)) {          if (defined($attribute)) {
223              # It does, so we do an update.              # It does, so we do an update.
224                $action = "Update Key";
225              $self->UpdateEntity('AttributeKey', $attributeName,              $self->UpdateEntity('AttributeKey', $attributeName,
226                                  { description => $notes, 'data-type' => $type });                                  { description => $notes, 'data-type' => $type });
227              # Detach the key from its current groups.              # Detach the key from its current groups.
228              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
229          } else {          } else {
230              # It doesn't, so we do an insert.              # It doesn't, so we do an insert.
231                $action = "Insert Key";
232              $self->InsertObject('AttributeKey', { id => $attributeName,              $self->InsertObject('AttributeKey', { id => $attributeName,
233                                  description => $notes, 'data-type' => $type });                                  description => $notes, 'data-type' => $type });
234          }          }
# Line 186  Line 238 
238              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
239                                                 'to-link'   => $group });                                                 'to-link'   => $group });
240          }          }
241            # Log the operation.
242            $self->LogOperation($action, $attributeName, "Group list is " . join(" ", @{$groups}));
243      }      }
244  }  }
245    
 =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;  
 }  
   
246    
247  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
248    
# Line 315  Line 269 
269      my ($self, $attributeName) = @_;      my ($self, $attributeName) = @_;
270      # Delete the attribute key.      # Delete the attribute key.
271      my $retVal = $self->Delete('AttributeKey', $attributeName);      my $retVal = $self->Delete('AttributeKey', $attributeName);
272        # Log this operation.
273        $self->LogOperation("Delete Key", $attributeName, "Key will no longer be available for use by anyone.");
274      # Return the result.      # Return the result.
275      return $retVal;      return $retVal;
276    
# Line 388  Line 344 
344                                      -labels => \%labelMap,                                      -labels => \%labelMap,
345                                      -default => 'string');                                      -default => 'string');
346      # 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
347      # 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\">";  
348      my $fieldField = "document.$name.fieldName";      my $fieldField = "document.$name.fieldName";
349      my $newName = "\"" . NewName() . "\"";      my $newName = "\"" . NewName() . "\"";
350      push @retVal, $cgi->Tr($cgi->th("New Field Name"),      push @retVal, $cgi->Tr($cgi->th("New Field Name"),
# Line 413  Line 367 
367                             $cgi->td($cgi->checkbox_group(-name=>'groups',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
368                                      -values=> \@groups))                                      -values=> \@groups))
369                            );                            );
370      # 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.  
371      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
372                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'}, join(" ",
373                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE'),
374                                      $cgi->submit(-name => 'Store',  -value => 'STORE') . " " .                                      $cgi->submit(-name => 'Store',  -value => 'STORE'),
375                                        $cgi->submit(-name => 'Erase',  -value => 'ERASE'),
376                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')
377                                     )                                     ))
378                            );                            );
379      # Close the table and the form.      # Close the table and the form.
380      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
# Line 445  Line 385 
385  =head3 LoadAttributesFrom  =head3 LoadAttributesFrom
386    
387  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
388    s
389  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
390  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
391  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values will
392  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
393    contain a splitter. If this is the case, the portion of the key after the splitter is
394    treated as a subkey.
395    
396  =over 4  =over 4
397    
398  =item fileName  =item fileName
399    
400  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.
401    (This last enables the method to be used in conjunction with the CGI form upload
402    control.)
403    
404  =item options  =item options
405    
# Line 476  Line 420 
420  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
421  first time a key name is encountered, it will be erased.  first time a key name is encountered, it will be erased.
422    
423    =item archive
424    
425    If specified, the name of a file into which the incoming data file should be saved.
426    
427    =item objectType
428    
429    If specified, the specified object type will be prefixed to each object ID.
430    
431  =back  =back
432    
433  =cut  =cut
# Line 489  Line 441 
441      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
442      # Create a hash of key names found.      # Create a hash of key names found.
443      my %keyHash = ();      my %keyHash = ();
444      # Open the file for input.      # Open the file for input. Note we must anticipate the possibility of an
445      my $fh = Open(undef, "<$fileName");      # open filehandle being passed in.
446        my $fh;
447        if (ref $fileName) {
448            Trace("Using file opened by caller.") if T(3);
449            $fh = $fileName;
450        } else {
451            Trace("Attributes will be loaded from $fileName.") if T(3);
452            $fh = Open(undef, "<$fileName");
453        }
454        # Now check to see if we need to archive.
455        my $ah;
456        if ($options{archive}) {
457            $ah = Open(undef, ">$options{archive}");
458            Trace("Load file will be archived to $options{archive}.") if T(3);
459        }
460        # Finally, open a database transaction.
461        $self->BeginTran();
462        # Insure we recover from errors. If an error occurs, we will delete the archive file and
463        # roll back the updates.
464        eval {
465      # Loop through the file.      # Loop through the file.
466      while (! eof $fh) {      while (! eof $fh) {
467                # Read the current line.
468          my ($id, $key, @values) = Tracer::GetLine($fh);          my ($id, $key, @values) = Tracer::GetLine($fh);
469          $retVal->Add(linesIn => 1);          $retVal->Add(linesIn => 1);
470                # Check to see if we need to fix up the object ID.
471                if ($options{objectType}) {
472                    $id = "$options{objectType}:$id";
473                }
474                # Archive the line (if necessary).
475                if (defined $ah) {
476                    Tracer::PutLine($ah, [$id, $key, @values]);
477                }
478          # Do some validation.          # Do some validation.
479          if (! defined($id)) {              if (! $id) {
480              # We ignore blank lines.              # We ignore blank lines.
481              $retVal->Add(blankLines => 1);              $retVal->Add(blankLines => 1);
482                } elsif (substr($id, 0, 1) eq '#') {
483                    # A line beginning with a pound sign is a comment.
484                    $retVal->Add(comments => 1);
485          } elsif (! defined($key)) {          } elsif (! defined($key)) {
486              # An ID without a key is a serious error.              # An ID without a key is a serious error.
487              my $lines = $retVal->Ask('linesIn');              my $lines = $retVal->Ask('linesIn');
488              Confess("Line $lines in $fileName has no attribute key.");              Confess("Line $lines in $fileName has no attribute key.");
489                } elsif (! @values) {
490                    # A line with no values is not allowed.
491                    my $lines = $retVal->Ask('linesIn');
492                    Trace("Line $lines for key $key has no attribute values.") if T(1);
493                    $retVal->Add(skipped => 1);
494          } else {          } else {
495                    # The key contains a real part and an optional sub-part. We need the real part.
496                    my ($realKey, $subKey) = $self->SplitKey($key);
497              # Now we need to check for a new key.              # Now we need to check for a new key.
498              if (! exists $keyHash{$key}) {                  if (! exists $keyHash{$realKey}) {
499                  # This is a new key. Verify that it exists.                      if (! $self->Exists('AttributeKey', $realKey)) {
                 if (! $self->Exists('AttributeKey', $key)) {  
500                      my $line = $retVal->Ask('linesIn');                      my $line = $retVal->Ask('linesIn');
501                      Confess("Attribute \"$key\" on line $line of $fileName not found in database.");                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
502                  } else {                  } else {
503                      # Make sure we know this is no longer a new key.                      # Make sure we know this is no longer a new key.
504                      $keyHash{$key} = 1;                          $keyHash{$realKey} = 1;
505                      $retVal->Add(keys => 1);                      $retVal->Add(keys => 1);
506                      # If this is NOT append mode, erase the key.                      # If this is NOT append mode, erase the key.
507                      if (! $append) {                      if (! $append) {
508                          $self->EraseAttribute($key);                              $self->EraseAttribute($realKey);
509                      }                      }
510                  }                  }
511                  Trace("Key $key found.") if T(3);                      Trace("Key $realKey found.") if T(3);
512              }              }
513              # Now we know the key is valid. Add this value.                  # Everything is all set up, so add the value.
514              $self->AddAttribute($id, $key, @values);              $self->AddAttribute($id, $key, @values);
515              my $progress = $retVal->Add(values => 1);              my $progress = $retVal->Add(values => 1);
516              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
517                }
518            }
519        };
520        # Check for an error.
521        if ($@) {
522            # Here we have an error. Roll back the transaction and delete the archive file.
523            my $message = $@;
524            Trace("Rolling back attribute updates due to error.") if T(1);
525            $self->RollbackTran();
526            if (defined $ah) {
527                Trace("Deleting archive file $options{archive}.") if T(1);
528                close $ah;
529                unlink $options{archive};
530            }
531            Confess("Error during attribute load: $message");
532        } else {
533            # Here the load worked. Commit the transaction and close the archive file.
534            Trace("Committing attribute upload.") if T(2);
535            $self->CommitTran();
536            if (defined $ah) {
537                Trace("Closing archive file $options{archive}.") if T(2);
538                close $ah;
539            }
540        }
541        # Return the result.
542        return $retVal;
543    }
544    
545    =head3 BackupKeys
546    
547    C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
548    
549    Backup the attribute key information from the attribute database.
550    
551    =over 4
552    
553    =item fileName
554    
555    Name of the output file.
556    
557    =item options
558    
559    Options for modifying the backup process.
560    
561    =item RETURN
562    
563    Returns a statistics object for the backup.
564    
565    =back
566    
567    Currently there are no options. The backup is straight to a text file in
568    tab-delimited format. Each key is backup up to two lines. The first line
569    is all of the data from the B<AttributeKey> table. The second is a
570    tab-delimited list of all the groups.
571    
572    =cut
573    
574    sub BackupKeys {
575        # Get the parameters.
576        my ($self, $fileName, %options) = @_;
577        # Declare the return variable.
578        my $retVal = Stats->new();
579        # Open the output file.
580        my $fh = Open(undef, ">$fileName");
581        # Set up to read the keys.
582        my $keyQuery = $self->Get(['AttributeKey'], "", []);
583        # Loop through the keys.
584        while (my $keyData = $keyQuery->Fetch()) {
585            $retVal->Add(key => 1);
586            # Get the fields.
587            my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
588                                                              'AttributeKey(description)']);
589            # Escape any tabs or new-lines in the description.
590            my $escapedDescription = Tracer::Escape($description);
591            # Write the key data to the output.
592            Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
593            # Get the key's groups.
594            my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
595                                        'IsInGroup(to-link)');
596            $retVal->Add(memberships => scalar(@groups));
597            # Write them to the output. Note we put a marker at the beginning to insure the line
598            # is nonempty.
599            Tracer::PutLine($fh, ['#GROUPS', @groups]);
600        }
601        # Log the operation.
602        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
603        # Return the result.
604        return $retVal;
605    }
606    
607    =head3 RestoreKeys
608    
609    C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
610    
611    Restore the attribute keys and groups from a backup file.
612    
613    =over 4
614    
615    =item fileName
616    
617    Name of the file containing the backed-up keys. Each key has a pair of lines,
618    one containing the key data and one listing its groups.
619    
620    =back
621    
622    =cut
623    
624    sub RestoreKeys {
625        # Get the parameters.
626        my ($self, $fileName, %options) = @_;
627        # Declare the return variable.
628        my $retVal = Stats->new();
629        # Set up a hash to hold the group IDs.
630        my %groups = ();
631        # Open the file.
632        my $fh = Open(undef, "<$fileName");
633        # Loop until we're done.
634        while (! eof $fh) {
635            # Get a key record.
636            my ($id, $dataType, $description) = Tracer::GetLine($fh);
637            if ($id eq '#GROUPS') {
638                Confess("Group record found when key record expected.");
639            } elsif (! defined($description)) {
640                Confess("Invalid format found for key record.");
641            } else {
642                $retVal->Add("keyIn" => 1);
643                # Add this key to the database.
644                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
645                                                      description => Tracer::UnEscape($description) });
646                Trace("Attribute $id stored.") if T(3);
647                # Get the group line.
648                my ($marker, @groups) = Tracer::GetLine($fh);
649                if (! defined($marker)) {
650                    Confess("End of file found where group record expected.");
651                } elsif ($marker ne '#GROUPS') {
652                    Confess("Group record not found after key record.");
653                } else {
654                    $retVal->Add(memberships => scalar(@groups));
655                    # Connect the groups.
656                    for my $group (@groups) {
657                        # Find out if this is a new group.
658                        if (! $groups{$group}) {
659                            $retVal->Add(newGroup => 1);
660                            # Add the group.
661                            $self->InsertObject('AttributeGroup', { id => $group });
662                            Trace("Group $group created.") if T(3);
663                            # Make sure we know it's not new.
664                            $groups{$group} = 1;
665                        }
666                        # Connect the group to our key.
667                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
668                    }
669                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
670                }
671          }          }
672      }      }
673        # Log the operation.
674        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
675        # Return the result.
676        return $retVal;
677    }
678    
679    =head3 ArchiveFileName
680    
681    C<< my $fileName = $ca->ArchiveFileName(); >>
682    
683    Compute a file name for archiving attribute input data. The file will be in the attribute log directory
684    
685    =cut
686    
687    sub ArchiveFileName {
688        # Get the parameters.
689        my ($self) = @_;
690        # Declare the return variable.
691        my $retVal;
692        # We start by turning the timestamp into something usable as a file name.
693        my $now = Tracer::Now();
694        $now =~ tr/ :\//___/;
695        # Next we get the directory name.
696        my $dir = "$FIG_Config::var/attributes";
697        if (! -e $dir) {
698            Trace("Creating attribute file directory $dir.") if T(1);
699            mkdir $dir;
700        }
701        # Put it together with the field name and the time stamp.
702        $retVal = "$dir/upload.$now";
703        # Modify the file name to insure it's unique.
704        my $seq = 0;
705        while (-e "$retVal.$seq.tbl") { $seq++ }
706        # Use the computed sequence number to get the correct file name.
707        $retVal .= ".$seq.tbl";
708      # Return the result.      # Return the result.
709      return $retVal;      return $retVal;
710  }  }
# Line 568  Line 745 
745      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
746      Trace(scalar(@keys) . " keys found during backup.") if T(2);      Trace(scalar(@keys) . " keys found during backup.") if T(2);
747      # Open the file for output.      # Open the file for output.
748      my $fh = Open(undef, $fileName);      my $fh = Open(undef, ">$fileName");
749      # Loop through the keys.      # Loop through the keys.
750      for my $key (@keys) {      for my $key (@keys) {
751          Trace("Backing up attribute $key.") if T(3);          Trace("Backing up attribute $key.") if T(3);
752          $retVal->Add(keys => 1);          $retVal->Add(keys => 1);
753          # Loop through this key's values.          # Loop through this key's values.
754          my $query = $self->Get(['HasValueFor'], "HasValueFor(to-link) = ?", [$key]);          my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
755          my $valuesFound = 0;          my $valuesFound = 0;
756          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
757              $valuesFound++;              $valuesFound++;
758              # Get this row's data.              # Get this row's data.
759              my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',              my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',
760                                                                 'HasValueFor(from-link)',
761                                                                 'HasValueFor(subkey)',
762                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
763                # Check for a subkey.
764                if ($subKey ne '') {
765                    $key = "$key$self->{splitter}$subKey";
766                }
767              # Write it to the file.              # Write it to the file.
768              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, [$id, $key, $value]);
769          }          }
770          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
771          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
772      }      }
773        # Log the operation.
774        $self->LogOperation("Backup Data", $fileName, $retVal->Display());
775      # Return the result.      # Return the result.
776      return $retVal;      return $retVal;
777  }  }
# Line 851  Line 1036 
1036      return %retVal;      return %retVal;
1037  }  }
1038    
1039    =head3 LogOperation
1040    
1041    C<< $ca->LogOperation($action, $target, $description); >>
1042    
1043    Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).
1044    
1045    =over 4
1046    
1047    =item action
1048    
1049    Action being logged (e.g. C<Delete Group> or C<Load Key>).
1050    
1051    =item target
1052    
1053    ID of the key or group affected.
1054    
1055    =item description
1056    
1057    Short description of the action.
1058    
1059    =back
1060    
1061    =cut
1062    
1063    sub LogOperation {
1064        # Get the parameters.
1065        my ($self, $action, $target, $description) = @_;
1066        # Get the user ID.
1067        my $user = $self->{user};
1068        # Get a timestamp.
1069        my $timeString = Tracer::Now();
1070        # Open the log file for appending.
1071        my $oh = Open(undef, ">>$FIG_Config::var/attributes.log");
1072        # Write the data to it.
1073        Tracer::PutLine($oh, [$timeString, $user, $action, $target, $description]);
1074        # Close the log file.
1075        close $oh;
1076    }
1077    
1078    =head2 Internal Utility Methods
1079    
1080    =head3 _KeywordString
1081    
1082    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
1083    
1084    Compute the keyword string for a specified key/value pair. This consists of the
1085    key name and value converted to lower case with underscores translated to spaces.
1086    
1087    This method is for internal use only. It is called whenever we need to update or
1088    insert a B<HasValueFor> record.
1089    
1090    =over 4
1091    
1092    =item key
1093    
1094    Name of the relevant attribute key.
1095    
1096    =item target
1097    
1098    ID of the target object to which this key/value pair will be associated.
1099    
1100    =item value
1101    
1102    The value to store for this key/object combination.
1103    
1104    =item RETURN
1105    
1106    Returns the value that should be stored as the keyword string for the specified
1107    key/value pair.
1108    
1109    =back
1110    
1111    =cut
1112    
1113    sub _KeywordString {
1114        # Get the parameters.
1115        my ($self, $key, $value) = @_;
1116        # Get a copy of the key name and convert underscores to spaces.
1117        my $keywordString = $key;
1118        $keywordString =~ s/_/ /g;
1119        # Add the value convert it all to lower case.
1120        my $retVal = lc "$keywordString $value";
1121        # Return the result.
1122        return $retVal;
1123    }
1124    
1125    =head3 _QueryResults
1126    
1127    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1128    
1129    Match the results of a B<HasValueFor> query against value criteria and return
1130    the results. This is an internal method that splits the values coming back
1131    and matches the sections against the specified section patterns. It serves
1132    as the back end to L</GetAttributes> and L</FindAttributes>.
1133    
1134    =over 4
1135    
1136    =item query
1137    
1138    A query object that will return the desired B<HasValueFor> records.
1139    
1140    =item values
1141    
1142    List of the desired attribute values, section by section. If C<undef>
1143    or an empty string is specified, all values in that section will match. A
1144    generic match can be requested by placing a percent sign (C<%>) at the end.
1145    In that case, all values that match up to and not including the percent sign
1146    will match. You may also specify a regular expression enclosed
1147    in slashes. All values that match the regular expression will be returned. For
1148    performance reasons, only values have this extra capability.
1149    
1150    =item RETURN
1151    
1152    Returns a list of tuples. The first element in the tuple is an object ID, the
1153    second is an attribute key, and the remaining elements are the sections of
1154    the attribute value. All of the tuples will match the criteria set forth in
1155    the parameter list.
1156    
1157    =back
1158    
1159    =cut
1160    
1161    sub _QueryResults {
1162        # Get the parameters.
1163        my ($self, $query, @values) = @_;
1164        # Declare the return value.
1165        my @retVal = ();
1166        # Get the number of value sections we have to match.
1167        my $sectionCount = scalar(@values);
1168        # Loop through the assignments found.
1169        while (my $row = $query->Fetch()) {
1170            # Get the current row's data.
1171            my ($id, $realKey, $subKey, $valueString) = $row->Values(['HasValueFor(to-link)',
1172                                                                      'HasValueFor(from-link)',
1173                                                                      'HasValueFor(subkey)',
1174                                                                      'HasValueFor(value)'
1175                                                                    ]);
1176            # Form the key from the real key and the sub key.
1177            my $key = $self->JoinKey($realKey, $subKey);
1178            # Break the value into sections.
1179            my @sections = split($self->{splitter}, $valueString);
1180            # Match each section against the incoming values. We'll assume we're
1181            # okay unless we learn otherwise.
1182            my $matching = 1;
1183            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1184                # We need to check to see if this section is generic.
1185                my $value = $values[$i];
1186                Trace("Current value pattern is \"$value\".") if T(4);
1187                if (substr($value, -1, 1) eq '%') {
1188                    Trace("Generic match used.") if T(4);
1189                    # Here we have a generic match.
1190                    my $matchLen = length($values[$i]) - 1;
1191                    $matching = substr($sections[$i], 0, $matchLen) eq
1192                                substr($values[$i], 0, $matchLen);
1193                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1194                    Trace("Regular expression detected.") if T(4);
1195                    # Here we have a regular expression match.
1196                    my $section = $sections[$i];
1197                    $matching = eval("\$section =~ $value");
1198                } else {
1199                    # Here we have a strict match.
1200                    Trace("Strict match used.") if T(4);
1201                    $matching = ($sections[$i] eq $values[$i]);
1202                }
1203            }
1204            # If we match, output this row to the return list.
1205            if ($matching) {
1206                push @retVal, [$id, $key, @sections];
1207            }
1208        }
1209        # Return the rows found.
1210        return @retVal;
1211    }
1212    
1213  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1214    
1215  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 1221 
1221  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
1222  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.
1223    
1224  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,
1225  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
1226  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
1227  value of the splitter parameter on the constructor (L</new>). The default is double  is double colons C<::>.
 colons C<::>.  
1228    
1229  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
1230  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 1276 
1276  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.
1277    
1278  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
1279  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
1280  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
1281  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
1282  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
1283    reading a lot more than they need to.
1284    
1285  =over 4  =over 4
1286    
# Line 945  Line 1304 
1304  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
1305  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.
1306  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
1307  will match.  will match. You may also specify a regular expression enclosed
1308    in slashes. All values that match the regular expression will be returned. For
1309    performance reasons, only values have this extra capability.
1310    
1311  =item RETURN  =item RETURN
1312    
# Line 961  Line 1322 
1322  sub GetAttributes {  sub GetAttributes {
1323      # Get the parameters.      # Get the parameters.
1324      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1325      # 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
1326      # clause and a parameter list.      # SQL statement.
1327      my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);      my %data;
1328        # Before we do anything else, we must parse the key. The key is treated by the
1329        # user as a single field, but to us it's actually a real key and a subkey.
1330        # If the key has no splitter and is exact, the real key is the original key
1331        # and the subkey is an empty string. If the key has a splitter, it is
1332        # split into two pieces and each piece is processed separately. If the key has
1333        # no splitter and is generic, the real key is the incoming key and the subkey
1334        # is allowed to be wild. Of course, this only matters if an actual key has
1335        # been specified.
1336        if (defined $key) {
1337            if ($key =~ /$self->{splitter}/) {
1338                # Here we have a two-part key, so we split it normally.
1339                my ($realKey, $subKey) = $self->SplitKey($key);
1340                $data{'HasValueFor(from-link)'} = $realKey;
1341                $data{'HasValueFor(subkey)'} = $subKey;
1342            } elsif (substr($key, -1, 1) eq '%') {
1343                $data{'HasValueFor(from-link)'} = $key;
1344            } else {
1345                $data{'HasValueFor(from-link)'} = $key;
1346                $data{'HasValueFor(subkey)'} = '';
1347            }
1348        }
1349        # Add the object ID to the key information.
1350        $data{'HasValueFor(to-link)'} = $objectID;
1351        # The first value represents a problem, because we can search it using SQL, but not
1352        # in the normal way. If the user specifies a generic search or exact match for
1353        # every alternative value (remember, the values may be specified as a list),
1354        # then we can create SQL filtering for it. If any of the values are specified
1355        # as a regular expression, however, that's a problem, because we need to read
1356        # every value to verify a match.
1357        if (@values > 0) {
1358            # Get the first value and put its alternatives in an array.
1359            my $valueParm = $values[0];
1360            my @valueList;
1361            if (ref $valueParm eq 'ARRAY') {
1362                @valueList = @{$valueParm};
1363            } else {
1364                @valueList = ($valueParm);
1365            }
1366            # Okay, now we have all the possible criteria for the first value in the list
1367            # @valueList. We'll copy the values to a new array in which they have been
1368            # converted to generic requests. If we find a regular-expression match
1369            # anywhere in the list, we toss the whole thing.
1370            my @valuePatterns = ();
1371            my $okValues = 1;
1372            for my $valuePattern (@valueList) {
1373                # Check the pattern type.
1374                if (substr($valuePattern, 0, 1) eq '/') {
1375                    # Regular expressions invalidate the entire process.
1376                    $okValues = 0;
1377                } elsif (substr($valuePattern, -1, 1) eq '%') {
1378                    # A Generic pattern is passed in unmodified.
1379                    push @valuePatterns, $valuePattern;
1380                } else {
1381                    # An exact match is converted to generic.
1382                    push @valuePatterns, "$valuePattern%";
1383                }
1384            }
1385            # If everything works, add the value data to the filtering hash.
1386            if ($okValues) {
1387                $data{'HasValueFor(value)'} = \@valuePatterns;
1388            }
1389        }
1390        # Create some lists to contain the filter fragments and parameter values.
1391      my @filter = ();      my @filter = ();
1392      my @parms = ();      my @parms = ();
1393      # 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
1394      # parameter list and generates filters for each.      # parameter list and generates filters for each. The %data hash that we built above
1395        # contains all the necessary information to do this.
1396      for my $field (keys %data) {      for my $field (keys %data) {
1397          # Accumulate filter information for this field. We will OR together all the          # Accumulate filter information for this field. We will OR together all the
1398          # elements accumulated to create the final result.          # elements accumulated to create the final result.
# Line 995  Line 1420 
1420                          push @fieldFilter, "$field = ?";                          push @fieldFilter, "$field = ?";
1421                          push @parms, $pattern;                          push @parms, $pattern;
1422                      } else {                      } else {
1423                          # 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
1424                          # filter the field to this value pattern.                          # filter the field to this value pattern.
1425                          push @fieldFilter, "$field LIKE ?";                          push @fieldFilter, "$field LIKE ?";
1426                          # 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 1442 
1442      # 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
1443      # values to bind to them.      # values to bind to them.
1444      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);  
1445      # Now we're ready to make our query.      # Now we're ready to make our query.
1446      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1447      # Loop through the assignments found.      # Format the results.
1448      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];  
         }  
     }  
1449      # Return the rows found.      # Return the rows found.
1450      return @retVal;      return @retVal;
1451  }  }
# Line 1093  Line 1491 
1491          # 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
1492          # into a scalar.          # into a scalar.
1493          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1494            # Split up the key.
1495            my ($realKey, $subKey) = $self->SplitKey($key);
1496          # Connect the object to the key.          # Connect the object to the key.
1497          $self->InsertObject('HasValueFor', { 'from-link' => $key,          $self->InsertObject('HasValueFor', { 'from-link' => $realKey,
1498                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1499                                                 'subkey'    => $subKey,
1500                                               'value'     => $valueString,                                               'value'     => $valueString,
1501                                         });                                         });
1502      }      }
# Line 1136  Line 1537 
1537          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1538      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1539          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1540      } elsif (scalar(@values) == 0) {      } else {
1541          # Here we erase the entire key.          # Split the key into the real key and the subkey.
1542          $self->EraseAttribute($key);          my ($realKey, $subKey) = $self->SplitKey($key);
1543            if ($subKey eq '' && scalar(@values) == 0) {
1544                # Here we erase the entire key for this object.
1545                $self->DeleteRow('HasValueFor', $key, $objectID);
1546      } else {      } else {
1547          # Here we erase the matching values.          # Here we erase the matching values.
1548          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1549          $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });              $self->DeleteRow('HasValueFor', $realKey, $objectID,
1550                                 { subkey => $subKey, value => $valueString });
1551            }
1552      }      }
1553      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1554      return 1;      return 1;
1555  }  }
1556    
1557    =head3 DeleteMatchingAttributes
1558    
1559    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1560    
1561    Delete all attributes that match the specified criteria. This is equivalent to
1562    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1563    row found.
1564    
1565    =over 4
1566    
1567    =item objectID
1568    
1569    ID of object whose attributes are to be deleted. If the attributes for multiple
1570    objects are to be deleted, this parameter can be specified as a list reference. If
1571    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1572    Finally, you can delete attributes for a range of object IDs by putting a percent
1573    sign (C<%>) at the end.
1574    
1575    =item key
1576    
1577    Attribute key name. A value of C<undef> or an empty string will match all
1578    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1579    specified as a list reference. Finally, you can delete attributes for a range of
1580    keys by putting a percent sign (C<%>) at the end.
1581    
1582    =item values
1583    
1584    List of the desired attribute values, section by section. If C<undef>
1585    or an empty string is specified, all values in that section will match. A
1586    generic match can be requested by placing a percent sign (C<%>) at the end.
1587    In that case, all values that match up to and not including the percent sign
1588    will match. You may also specify a regular expression enclosed
1589    in slashes. All values that match the regular expression will be deleted. For
1590    performance reasons, only values have this extra capability.
1591    
1592    =item RETURN
1593    
1594    Returns a list of tuples for the attributes that were deleted, in the
1595    same form as L</GetAttributes>.
1596    
1597    =back
1598    
1599    =cut
1600    
1601    sub DeleteMatchingAttributes {
1602        # Get the parameters.
1603        my ($self, $objectID, $key, @values) = @_;
1604        # Get the matching attributes.
1605        my @retVal = $self->GetAttributes($objectID, $key, @values);
1606        # Loop through the attributes, deleting them.
1607        for my $tuple (@retVal) {
1608            $self->DeleteAttribute(@{$tuple});
1609        }
1610        # Log this operation.
1611        my $count = @retVal;
1612        $self->LogOperation("Mass Delete", $key, "$count matching attributes deleted.");
1613        # Return the deleted attributes.
1614        return @retVal;
1615    }
1616    
1617  =head3 ChangeAttribute  =head3 ChangeAttribute
1618    
1619  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1211  Line 1677 
1677    
1678  =item key  =item key
1679    
1680  Key to erase.  Key to erase. This must be a real key; that is, it cannot have a subkey
1681    component.
1682    
1683  =back  =back
1684    
# Line 1220  Line 1687 
1687  sub EraseAttribute {  sub EraseAttribute {
1688      # Get the parameters.      # Get the parameters.
1689      my ($self, $key) = @_;      my ($self, $key) = @_;
1690      # Delete everything connected to the key. The "keepRoot" option keeps the key in the      # Delete everything connected to the key.
1691      # datanase while deleting everything attached to it.      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1692      $self->Delete('AttributeKey', $key, keepRoot => 1);      # Log the operation.
1693        $self->LogOperation("Erase Data", $key);
1694      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1695      return 1;      return 1;
1696  }  }
# Line 1257  Line 1725 
1725      return sort @groups;      return sort @groups;
1726  }  }
1727    
1728    =head3 QueryAttributes
1729    
1730    C<< my @attributeData = $ca->QueryAttributes($filter, $filterParms); >>
1731    
1732    Return the attribute data based on an SQL filter clause. In the filter clause,
1733    the name C<$object> should be used for the object ID, C<$key> should be used for
1734    the key name, C<$subkey> for the subkey value, and C<$value> for the value field.
1735    
1736    =over 4
1737    
1738    =item filter
1739    
1740    Filter clause in the standard ERDB format, except that the field names are C<$object> for
1741    the object ID field, C<$key> for the key name field, C<$subkey> for the subkey field,
1742    and C<$value> for the value field. This abstraction enables us to hide the details of
1743    the database construction from the user.
1744    
1745    =item filterParms
1746    
1747    Parameters for the filter clause.
1748    
1749    =item RETURN
1750    
1751    Returns a list of tuples. Each tuple consists of an object ID, a key (with optional subkey), and
1752    one or more attribute values.
1753    
1754    =back
1755    
1756    =cut
1757    
1758    # This hash is used to drive the substitution process.
1759    my %AttributeParms = (object => 'HasValueFor(to-link)',
1760                          key    => 'HasValueFor(from-link)',
1761                          subkey => 'HasValueFor(subkey)',
1762                          value  => 'HasValueFor(value)');
1763    
1764    sub QueryAttributes {
1765        # Get the parameters.
1766        my ($self, $filter, $filterParms) = @_;
1767        # Declare the return variable.
1768        my @retVal = ();
1769        # Make sue we have filter parameters.
1770        my $realParms = (defined($filterParms) ? $filterParms : []);
1771        # Create the query by converting the filter.
1772        my $realFilter = $filter;
1773        for my $name (keys %AttributeParms) {
1774            $realFilter =~ s/\$$name/$AttributeParms{$name}/g;
1775        }
1776        my $query = $self->Get(['HasValueFor'], $realFilter, $realParms);
1777        # Loop through the results, forming the output attribute tuples.
1778        while (my $result = $query->Fetch()) {
1779            # Get the four values from this query result row.
1780            my ($objectID, $key, $subkey, $value) = $result->Values([$AttributeParms{object},
1781                                                                    $AttributeParms{key},
1782                                                                    $AttributeParms{subkey},
1783                                                                    $AttributeParms{value}]);
1784            # Combine the key and the subkey.
1785            my $realKey = ($subkey ? $key . $self->{splitter} . $subkey : $key);
1786            # Split the value.
1787            my @values = split $self->{splitter}, $value;
1788            # Output the result.
1789            push @retVal, [$objectID, $realKey, @values];
1790        }
1791        # Return the result.
1792        return @retVal;
1793    }
1794    
1795    =head2 Key and ID Manipulation Methods
1796    
1797    =head3 ParseID
1798    
1799    C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>
1800    
1801    Determine the type and object ID corresponding to an ID value from the attribute database.
1802    Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);
1803    however, Genomes, Features, and Subsystems are not stored with a type name, so we need to
1804    deduce the type from the ID value structure.
1805    
1806    The theory here is that you can plug the ID and type directly into a Sprout database method, as
1807    follows
1808    
1809        my ($type, $id) = CustomAttributes::ParseID($attrList[$num]->[0]);
1810        my $target = $sprout->GetEntity($type, $id);
1811    
1812    =over 4
1813    
1814    =item idValue
1815    
1816    ID value taken from the attribute database.
1817    
1818    =item RETURN
1819    
1820    Returns a two-element list. The first element is the type of object indicated by the ID value,
1821    and the second element is the actual object ID.
1822    
1823    =back
1824    
1825    =cut
1826    
1827    sub ParseID {
1828        # Get the parameters.
1829        my ($idValue) = @_;
1830        # Declare the return variables.
1831        my ($type, $id);
1832        # Parse the incoming ID. We first check for the presence of an entity name. Entity names
1833        # can only contain letters, which helps to insure typed object IDs don't collide with
1834        # subsystem names (which are untyped).
1835        if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1836            # Here we have a typed ID.
1837            ($type, $id) = ($1, $2);
1838            # Fix the case sensitivity on PDB IDs.
1839            if ($type eq 'PDB') { $id = lc $id; }
1840        } elsif ($idValue =~ /fig\|/) {
1841            # Here we have a feature ID.
1842            ($type, $id) = (Feature => $idValue);
1843        } elsif ($idValue =~ /\d+\.\d+/) {
1844            # Here we have a genome ID.
1845            ($type, $id) = (Genome => $idValue);
1846        } else {
1847            # The default is a subsystem ID.
1848            ($type, $id) = (Subsystem => $idValue);
1849        }
1850        # Return the results.
1851        return ($type, $id);
1852    }
1853    
1854    =head3 FormID
1855    
1856    C<< my $idValue = CustomAttributes::FormID($type, $id); >>
1857    
1858    Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,
1859    genomes, and features are stored in the database without type information, but all other object IDs
1860    must be prefixed with the object type.
1861    
1862    =over 4
1863    
1864    =item type
1865    
1866    Relevant object type.
1867    
1868    =item id
1869    
1870    ID of the object in question.
1871    
1872    =item RETURN
1873    
1874    Returns a string that will be recognized as an object ID in the attribute database.
1875    
1876    =back
1877    
1878    =cut
1879    
1880    sub FormID {
1881        # Get the parameters.
1882        my ($type, $id) = @_;
1883        # Declare the return variable.
1884        my $retVal;
1885        # Compute the ID string from the type.
1886        if (grep { $type eq $_ } qw(Feature Genome Subsystem)) {
1887            $retVal = $id;
1888        } else {
1889            $retVal = "$type:$id";
1890        }
1891        # Return the result.
1892        return $retVal;
1893    }
1894    
1895    =head3 GetTargetObject
1896    
1897    C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>
1898    
1899    Return the database object corresponding to the specified attribute object ID. The
1900    object type associated with the ID value must correspond to an entity name in the
1901    specified database.
1902    
1903    =over 4
1904    
1905    =item erdb
1906    
1907    B<ERDB> object for accessing the target database.
1908    
1909    =item idValue
1910    
1911    ID value retrieved from the attribute database.
1912    
1913    =item RETURN
1914    
1915    Returns a B<ERDBObject> for the attribute value's target object.
1916    
1917    =back
1918    
1919    =cut
1920    
1921    sub GetTargetObject {
1922        # Get the parameters.
1923        my ($erdb, $idValue) = @_;
1924        # Declare the return variable.
1925        my $retVal;
1926        # Get the type and ID for the target object.
1927        my ($type, $id) = ParseID($idValue);
1928        # Plug them into the GetEntity method.
1929        $retVal = $erdb->GetEntity($type, $id);
1930        # Return the resulting object.
1931        return $retVal;
1932    }
1933    
1934    =head3 SplitKey
1935    
1936    C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>
1937    
1938    Split an external key (that is, one passed in by a caller) into the real key and the sub key.
1939    The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,
1940    then the sub key is presumed to be an empty string.
1941    
1942    =over 4
1943    
1944    =item key
1945    
1946    Incoming key to be split.
1947    
1948    =item RETURN
1949    
1950    Returns a two-element list, the first element of which is the real key and the second element of
1951    which is the sub key.
1952    
1953    =back
1954    
1955    =cut
1956    
1957    sub SplitKey {
1958        # Get the parameters.
1959        my ($self, $key) = @_;
1960        # Do the split.
1961        my ($realKey, $subKey) = split($self->{splitter}, $key, 2);
1962        # Insure the subkey has a value.
1963        if (! defined $subKey) {
1964            $subKey = '';
1965        }
1966        # Return the results.
1967        return ($realKey, $subKey);
1968    }
1969    
1970    =head3 JoinKey
1971    
1972    C<< my $key = $ca->JoinKey($realKey, $subKey); >>
1973    
1974    Join a real key and a subkey together to make an external key. The external key is the attribute key
1975    used by the caller. The real key and the subkey are how the keys are represented in the database. The
1976    real key is the key to the B<AttributeKey> entity. The subkey is an attribute of the B<HasValueFor>
1977    relationship.
1978    
1979    =over 4
1980    
1981    =item realKey
1982    
1983    The real attribute key.
1984    
1985    =item subKey
1986    
1987    The subordinate portion of the attribute key.
1988    
1989    =item RETURN
1990    
1991    Returns a single string representing both keys.
1992    
1993    =back
1994    
1995    =cut
1996    
1997    sub JoinKey {
1998        # Get the parameters.
1999        my ($self, $realKey, $subKey) = @_;
2000        # Declare the return variable.
2001        my $retVal;
2002        # Check for a subkey.
2003        if ($subKey eq '') {
2004            # No subkey, so the real key is the key.
2005            $retVal = $realKey;
2006        } else {
2007            # Subkey found, so the two pieces must be joined by a splitter.
2008            $retVal = "$realKey$self->{splitter}$subKey";
2009        }
2010        # Return the result.
2011        return $retVal;
2012    }
2013    
2014    
2015    =head3 AttributeTable
2016    
2017    C<< my $tableHtml = CustomAttributes::AttributeTable($cgi, @attrList); >>
2018    
2019    Format the attribute data into an HTML table.
2020    
2021    =over 4
2022    
2023    =item cgi
2024    
2025    CGI query object used to generate the HTML
2026    
2027    =item attrList
2028    
2029    List of attribute results, in the format returned by the L</GetAttributes> or
2030    L</QueryAttributes> methods.
2031    
2032    =item RETURN
2033    
2034    Returns an HTML table displaying the attribute keys and values.
2035    
2036    =back
2037    
2038    =cut
2039    
2040    sub AttributeTable {
2041        # Get the parameters.
2042        my ($cgi, @attrList) = @_;
2043        # Accumulate the table rows.
2044        my @html = ();
2045        for my $attrData (@attrList) {
2046            # Format the object ID and key.
2047            my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];
2048            # Now we format the values. These remain unchanged unless one of them is a URL.
2049            my $lastValue = scalar(@{$attrData}) - 1;
2050            push @columns, map { $_ =~ /^http:/ ? $cgi->a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];
2051            # Assemble the values into a table row.
2052            push @html, $cgi->Tr($cgi->td(\@columns));
2053        }
2054        # Format the table in the return variable.
2055        my $retVal = $cgi->table({ border => 2 }, $cgi->Tr($cgi->th(['Object', 'Key', 'Values'])), @html);
2056        # Return it.
2057        return $retVal;
2058    }
2059  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3