[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.12, Fri Dec 15 03:24:59 2006 UTC revision 1.21, Sun Feb 18 22:13:53 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 413  Line 369 
369                             $cgi->td($cgi->checkbox_group(-name=>'groups',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
370                                      -values=> \@groups))                                      -values=> \@groups))
371                            );                            );
372      # 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.  
373      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
374                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'}, join(" ",
375                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE'),
376                                      $cgi->submit(-name => 'Store',  -value => 'STORE') . " " .                                      $cgi->submit(-name => 'Store',  -value => 'STORE'),
377                                        $cgi->submit(-name => 'Erase',  -value => 'ERASE'),
378                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')
379                                     )                                     ))
380                            );                            );
381      # Close the table and the form.      # Close the table and the form.
382      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
# Line 449  Line 391 
391  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
392  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
393  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values will
394  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
395    contain a splitter. If this is the case, the portion of the key after the splitter is
396    treated as a subkey.
397    
398  =over 4  =over 4
399    
400  =item fileName  =item fileName
401    
402  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.
403    (This last enables the method to be used in conjunction with the CGI form upload
404    control.)
405    
406  =item options  =item options
407    
# Line 476  Line 422 
422  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
423  first time a key name is encountered, it will be erased.  first time a key name is encountered, it will be erased.
424    
425    =item archive
426    
427    If specified, the name of a file into which the incoming data file should be saved.
428    
429    =item objectType
430    
431    If specified, the specified object type will be prefixed to each object ID.
432    
433  =back  =back
434    
435  =cut  =cut
# Line 489  Line 443 
443      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
444      # Create a hash of key names found.      # Create a hash of key names found.
445      my %keyHash = ();      my %keyHash = ();
446      # Open the file for input.      # Open the file for input. Note we must anticipate the possibility of an
447      my $fh = Open(undef, "<$fileName");      # open filehandle being passed in.
448        my $fh;
449        if (ref $fileName) {
450            Trace("Using file opened by caller.") if T(3);
451            $fh = $fileName;
452        } else {
453            Trace("Attributes will be loaded from $fileName.") if T(3);
454            $fh = Open(undef, "<$fileName");
455        }
456        # Now check to see if we need to archive.
457        my $ah;
458        if ($options{archive}) {
459            $ah = Open(undef, ">$options{archive}");
460            Trace("Load file will be archived to $options{archive}.") if T(3);
461        }
462        # Finally, open a database transaction.
463        $self->BeginTran();
464        # Insure we recover from errors. If an error occurs, we will delete the archive file and
465        # roll back the updates.
466        eval {
467      # Loop through the file.      # Loop through the file.
468      while (! eof $fh) {      while (! eof $fh) {
469                # Read the current line.
470          my ($id, $key, @values) = Tracer::GetLine($fh);          my ($id, $key, @values) = Tracer::GetLine($fh);
471          $retVal->Add(linesIn => 1);          $retVal->Add(linesIn => 1);
472                # Check to see if we need to fix up the object ID.
473                if ($options{objectType}) {
474                    $id = "$options{objectType}:$id";
475                }
476                # Archive the line (if necessary).
477                if (defined $ah) {
478                    Tracer::PutLine($ah, [$id, $key, @values]);
479                }
480          # Do some validation.          # Do some validation.
481          if (! defined($id)) {              if (! $id) {
482              # We ignore blank lines.              # We ignore blank lines.
483              $retVal->Add(blankLines => 1);              $retVal->Add(blankLines => 1);
484                } elsif (substr($id, 0, 1) eq '#') {
485                    # A line beginning with a pound sign is a comment.
486                    $retVal->Add(comments => 1);
487          } elsif (! defined($key)) {          } elsif (! defined($key)) {
488              # An ID without a key is a serious error.              # An ID without a key is a serious error.
489              my $lines = $retVal->Ask('linesIn');              my $lines = $retVal->Ask('linesIn');
490              Confess("Line $lines in $fileName has no attribute key.");              Confess("Line $lines in $fileName has no attribute key.");
491          } else {          } else {
492                    # The key contains a real part and an optional sub-part. We need the real part.
493                    my ($realKey, $subKey) = $self->SplitKey($key);
494              # Now we need to check for a new key.              # Now we need to check for a new key.
495              if (! exists $keyHash{$key}) {                  if (! exists $keyHash{$realKey}) {
496                  # This is a new key. Verify that it exists.                      if (! $self->Exists('AttributeKey', $realKey)) {
                 if (! $self->Exists('AttributeKey', $key)) {  
497                      my $line = $retVal->Ask('linesIn');                      my $line = $retVal->Ask('linesIn');
498                      Confess("Attribute \"$key\" on line $line of $fileName not found in database.");                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
499                  } else {                  } else {
500                      # Make sure we know this is no longer a new key.                      # Make sure we know this is no longer a new key.
501                      $keyHash{$key} = 1;                          $keyHash{$realKey} = 1;
502                      $retVal->Add(keys => 1);                      $retVal->Add(keys => 1);
503                      # If this is NOT append mode, erase the key.                      # If this is NOT append mode, erase the key.
504                      if (! $append) {                      if (! $append) {
505                          $self->EraseAttribute($key);                              $self->EraseAttribute($realKey);
506                      }                      }
507                  }                  }
508                  Trace("Key $key found.") if T(3);                      Trace("Key $realKey found.") if T(3);
509              }              }
510              # Now we know the key is valid. Add this value.                  # Everything is all set up, so add the value.
511              $self->AddAttribute($id, $key, @values);              $self->AddAttribute($id, $key, @values);
512              my $progress = $retVal->Add(values => 1);              my $progress = $retVal->Add(values => 1);
513              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
514                }
515            }
516        };
517        # Check for an error.
518        if ($@) {
519            # Here we have an error. Roll back the transaction and delete the archive file.
520            my $message = $@;
521            Trace("Rolling back attribute updates due to error.") if T(1);
522            $self->RollbackTran();
523            if (defined $ah) {
524                Trace("Deleting archive file $options{archive}.") if T(1);
525                close $ah;
526                unlink $options{archive};
527            }
528            Confess("Error during attribute load: $message");
529        } else {
530            # Here the load worked. Commit the transaction and close the archive file.
531            Trace("Committing attribute upload.") if T(2);
532            $self->CommitTran();
533            if (defined $ah) {
534                Trace("Closing archive file $options{archive}.") if T(2);
535                close $ah;
536            }
537        }
538        # Return the result.
539        return $retVal;
540    }
541    
542    =head3 BackupKeys
543    
544    C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
545    
546    Backup the attribute key information from the attribute database.
547    
548    =over 4
549    
550    =item fileName
551    
552    Name of the output file.
553    
554    =item options
555    
556    Options for modifying the backup process.
557    
558    =item RETURN
559    
560    Returns a statistics object for the backup.
561    
562    =back
563    
564    Currently there are no options. The backup is straight to a text file in
565    tab-delimited format. Each key is backup up to two lines. The first line
566    is all of the data from the B<AttributeKey> table. The second is a
567    tab-delimited list of all the groups.
568    
569    =cut
570    
571    sub BackupKeys {
572        # Get the parameters.
573        my ($self, $fileName, %options) = @_;
574        # Declare the return variable.
575        my $retVal = Stats->new();
576        # Open the output file.
577        my $fh = Open(undef, ">$fileName");
578        # Set up to read the keys.
579        my $keyQuery = $self->Get(['AttributeKey'], "", []);
580        # Loop through the keys.
581        while (my $keyData = $keyQuery->Fetch()) {
582            $retVal->Add(key => 1);
583            # Get the fields.
584            my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
585                                                              'AttributeKey(description)']);
586            # Escape any tabs or new-lines in the description.
587            my $escapedDescription = Tracer::Escape($description);
588            # Write the key data to the output.
589            Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
590            # Get the key's groups.
591            my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
592                                        'IsInGroup(to-link)');
593            $retVal->Add(memberships => scalar(@groups));
594            # Write them to the output. Note we put a marker at the beginning to insure the line
595            # is nonempty.
596            Tracer::PutLine($fh, ['#GROUPS', @groups]);
597        }
598        # Log the operation.
599        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
600        # Return the result.
601        return $retVal;
602    }
603    
604    =head3 RestoreKeys
605    
606    C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
607    
608    Restore the attribute keys and groups from a backup file.
609    
610    =over 4
611    
612    =item fileName
613    
614    Name of the file containing the backed-up keys. Each key has a pair of lines,
615    one containing the key data and one listing its groups.
616    
617    =back
618    
619    =cut
620    
621    sub RestoreKeys {
622        # Get the parameters.
623        my ($self, $fileName, %options) = @_;
624        # Declare the return variable.
625        my $retVal = Stats->new();
626        # Set up a hash to hold the group IDs.
627        my %groups = ();
628        # Open the file.
629        my $fh = Open(undef, "<$fileName");
630        # Loop until we're done.
631        while (! eof $fh) {
632            # Get a key record.
633            my ($id, $dataType, $description) = Tracer::GetLine($fh);
634            if ($id eq '#GROUPS') {
635                Confess("Group record found when key record expected.");
636            } elsif (! defined($description)) {
637                Confess("Invalid format found for key record.");
638            } else {
639                $retVal->Add("keyIn" => 1);
640                # Add this key to the database.
641                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
642                                                      description => Tracer::UnEscape($description) });
643                Trace("Attribute $id stored.") if T(3);
644                # Get the group line.
645                my ($marker, @groups) = Tracer::GetLine($fh);
646                if (! defined($marker)) {
647                    Confess("End of file found where group record expected.");
648                } elsif ($marker ne '#GROUPS') {
649                    Confess("Group record not found after key record.");
650                } else {
651                    $retVal->Add(memberships => scalar(@groups));
652                    # Connect the groups.
653                    for my $group (@groups) {
654                        # Find out if this is a new group.
655                        if (! $groups{$group}) {
656                            $retVal->Add(newGroup => 1);
657                            # Add the group.
658                            $self->InsertObject('AttributeGroup', { id => $group });
659                            Trace("Group $group created.") if T(3);
660                            # Make sure we know it's not new.
661                            $groups{$group} = 1;
662                        }
663                        # Connect the group to our key.
664                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
665                    }
666                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
667          }          }
668      }      }
669        }
670        # Log the operation.
671        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
672        # Return the result.
673        return $retVal;
674    }
675    
676    =head3 ArchiveFileName
677    
678    C<< my $fileName = $ca->ArchiveFileName(); >>
679    
680    Compute a file name for archiving attribute input data. The file will be in the attribute log directory
681    
682    =cut
683    
684    sub ArchiveFileName {
685        # Get the parameters.
686        my ($self) = @_;
687        # Declare the return variable.
688        my $retVal;
689        # We start by turning the timestamp into something usable as a file name.
690        my $now = Tracer::Now();
691        $now =~ tr/ :\//___/;
692        # Next we get the directory name.
693        my $dir = "$FIG_Config::var/attributes";
694        if (! -e $dir) {
695            Trace("Creating attribute file directory $dir.") if T(1);
696            mkdir $dir;
697        }
698        # Put it together with the field name and the time stamp.
699        $retVal = "$dir/upload.$now";
700        # Modify the file name to insure it's unique.
701        my $seq = 0;
702        while (-e "$retVal.$seq.tbl") { $seq++ }
703        # Use the computed sequence number to get the correct file name.
704        $retVal .= ".$seq.tbl";
705      # Return the result.      # Return the result.
706      return $retVal;      return $retVal;
707  }  }
# Line 579  Line 753 
753          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
754              $valuesFound++;              $valuesFound++;
755              # Get this row's data.              # Get this row's data.
756              my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',              my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',
757                                                                 'HasValueFor(from-link)',
758                                                                 'HasValueFor(subkey)',
759                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
760                # Check for a subkey.
761                if ($subKey ne '') {
762                    $key = "$key$self->{splitter}$subKey";
763                }
764              # Write it to the file.              # Write it to the file.
765              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, [$id, $key, $value]);
766          }          }
767          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
768          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
769      }      }
770        # Log the operation.
771        $self->LogOperation("Backup Data", $fileName, $retVal->Display());
772      # Return the result.      # Return the result.
773      return $retVal;      return $retVal;
774  }  }
# Line 851  Line 1033 
1033      return %retVal;      return %retVal;
1034  }  }
1035    
1036    =head3 LogOperation
1037    
1038    C<< $ca->LogOperation($action, $target, $description); >>
1039    
1040    Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).
1041    
1042    =over 4
1043    
1044    =item action
1045    
1046    Action being logged (e.g. C<Delete Group> or C<Load Key>).
1047    
1048    =item target
1049    
1050    ID of the key or group affected.
1051    
1052    =item description
1053    
1054    Short description of the action.
1055    
1056    =back
1057    
1058    =cut
1059    
1060    sub LogOperation {
1061        # Get the parameters.
1062        my ($self, $action, $target, $description) = @_;
1063        # Get the user ID.
1064        my $user = $self->{user};
1065        # Get a timestamp.
1066        my $timeString = Tracer::Now();
1067        # Open the log file for appending.
1068        my $oh = Open(undef, ">>$FIG_Config::var/attributes.log");
1069        # Write the data to it.
1070        Tracer::PutLine($oh, [$timeString, $user, $action, $target, $description]);
1071        # Close the log file.
1072        close $oh;
1073    }
1074    
1075    =head2 Internal Utility Methods
1076    
1077    =head3 _KeywordString
1078    
1079    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
1080    
1081    Compute the keyword string for a specified key/value pair. This consists of the
1082    key name and value converted to lower case with underscores translated to spaces.
1083    
1084    This method is for internal use only. It is called whenever we need to update or
1085    insert a B<HasValueFor> record.
1086    
1087    =over 4
1088    
1089    =item key
1090    
1091    Name of the relevant attribute key.
1092    
1093    =item target
1094    
1095    ID of the target object to which this key/value pair will be associated.
1096    
1097    =item value
1098    
1099    The value to store for this key/object combination.
1100    
1101    =item RETURN
1102    
1103    Returns the value that should be stored as the keyword string for the specified
1104    key/value pair.
1105    
1106    =back
1107    
1108    =cut
1109    
1110    sub _KeywordString {
1111        # Get the parameters.
1112        my ($self, $key, $value) = @_;
1113        # Get a copy of the key name and convert underscores to spaces.
1114        my $keywordString = $key;
1115        $keywordString =~ s/_/ /g;
1116        # Add the value convert it all to lower case.
1117        my $retVal = lc "$keywordString $value";
1118        # Return the result.
1119        return $retVal;
1120    }
1121    
1122    =head3 _QueryResults
1123    
1124    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1125    
1126    Match the results of a B<HasValueFor> query against value criteria and return
1127    the results. This is an internal method that splits the values coming back
1128    and matches the sections against the specified section patterns. It serves
1129    as the back end to L</GetAttributes> and L</FindAttributes>.
1130    
1131    =over 4
1132    
1133    =item query
1134    
1135    A query object that will return the desired B<HasValueFor> records.
1136    
1137    =item values
1138    
1139    List of the desired attribute values, section by section. If C<undef>
1140    or an empty string is specified, all values in that section will match. A
1141    generic match can be requested by placing a percent sign (C<%>) at the end.
1142    In that case, all values that match up to and not including the percent sign
1143    will match. You may also specify a regular expression enclosed
1144    in slashes. All values that match the regular expression will be returned. For
1145    performance reasons, only values have this extra capability.
1146    
1147    =item RETURN
1148    
1149    Returns a list of tuples. The first element in the tuple is an object ID, the
1150    second is an attribute key, and the remaining elements are the sections of
1151    the attribute value. All of the tuples will match the criteria set forth in
1152    the parameter list.
1153    
1154    =back
1155    
1156    =cut
1157    
1158    sub _QueryResults {
1159        # Get the parameters.
1160        my ($self, $query, @values) = @_;
1161        # Declare the return value.
1162        my @retVal = ();
1163        # Get the number of value sections we have to match.
1164        my $sectionCount = scalar(@values);
1165        # Loop through the assignments found.
1166        while (my $row = $query->Fetch()) {
1167            # Get the current row's data.
1168            my ($id, $realKey, $subKey, $valueString) = $row->Values(['HasValueFor(to-link)',
1169                                                                      'HasValueFor(from-link)',
1170                                                                      'HasValueFor(subkey)',
1171                                                                      'HasValueFor(value)'
1172                                                                    ]);
1173            # Form the key from the real key and the sub key.
1174            my $key = $self->JoinKey($realKey, $subKey);
1175            # Break the value into sections.
1176            my @sections = split($self->{splitter}, $valueString);
1177            # Match each section against the incoming values. We'll assume we're
1178            # okay unless we learn otherwise.
1179            my $matching = 1;
1180            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1181                # We need to check to see if this section is generic.
1182                my $value = $values[$i];
1183                Trace("Current value pattern is \"$value\".") if T(4);
1184                if (substr($value, -1, 1) eq '%') {
1185                    Trace("Generic match used.") if T(4);
1186                    # Here we have a generic match.
1187                    my $matchLen = length($values[$i]) - 1;
1188                    $matching = substr($sections[$i], 0, $matchLen) eq
1189                                substr($values[$i], 0, $matchLen);
1190                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1191                    Trace("Regular expression detected.") if T(4);
1192                    # Here we have a regular expression match.
1193                    my $section = $sections[$i];
1194                    $matching = eval("\$section =~ $value");
1195                } else {
1196                    # Here we have a strict match.
1197                    Trace("Strict match used.") if T(4);
1198                    $matching = ($sections[$i] eq $values[$i]);
1199                }
1200            }
1201            # If we match, output this row to the return list.
1202            if ($matching) {
1203                push @retVal, [$id, $key, @sections];
1204            }
1205        }
1206        # Return the rows found.
1207        return @retVal;
1208    }
1209    
1210  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1211    
1212  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 1218 
1218  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
1219  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.
1220    
1221  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,
1222  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
1223  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
1224  value of the splitter parameter on the constructor (L</new>). The default is double  is double colons C<::>.
 colons C<::>.  
1225    
1226  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
1227  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 1273 
1273  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.
1274    
1275  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
1276  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
1277  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
1278  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
1279  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
1280    reading a lot more than they need to.
1281    
1282  =over 4  =over 4
1283    
# Line 945  Line 1301 
1301  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
1302  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.
1303  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
1304  will match.  will match. You may also specify a regular expression enclosed
1305    in slashes. All values that match the regular expression will be returned. For
1306    performance reasons, only values have this extra capability.
1307    
1308  =item RETURN  =item RETURN
1309    
# Line 961  Line 1319 
1319  sub GetAttributes {  sub GetAttributes {
1320      # Get the parameters.      # Get the parameters.
1321      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1322      # 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
1323      # clause and a parameter list.      # SQL statement.
1324      my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);      my %data;
1325        # Before we do anything else, we must parse the key. The key is treated by the
1326        # user as a single field, but to us it's actually a real key and a subkey.
1327        # If the key has no splitter and is exact, the real key is the original key
1328        # and the subkey is an empty string. If the key has a splitter, it is
1329        # split into two pieces and each piece is processed separately. If the key has
1330        # no splitter and is generic, the real key is the incoming key and the subkey
1331        # is allowed to be wild. Of course, this only matters if an actual key has
1332        # been specified.
1333        if (defined $key) {
1334            if ($key =~ /$self->{splitter}/) {
1335                # Here we have a two-part key, so we split it normally.
1336                my ($realKey, $subKey) = $self->SplitKey($key);
1337                $data{'HasValueFor(from-link)'} = $realKey;
1338                $data{'HasValueFor(subkey)'} = $subKey;
1339            } elsif (substr($key, -1, 1) eq '%') {
1340                $data{'HasValueFor(from-link)'} = $key;
1341            } else {
1342                $data{'HasValueFor(from-link)'} = $key;
1343                $data{'HasValueFor(subkey)'} = '';
1344            }
1345        }
1346        # Add the object ID to the key information.
1347        $data{'HasValueFor(to-link)'} = $objectID;
1348        # The first value represents a problem, because we can search it using SQL, but not
1349        # in the normal way. If the user specifies a generic search or exact match for
1350        # every alternative value (remember, the values may be specified as a list),
1351        # then we can create SQL filtering for it. If any of the values are specified
1352        # as a regular expression, however, that's a problem, because we need to read
1353        # every value to verify a match.
1354        if (@values > 0) {
1355            # Get the first value and put its alternatives in an array.
1356            my $valueParm = $values[0];
1357            my @valueList;
1358            if (ref $valueParm eq 'ARRAY') {
1359                @valueList = @{$valueParm};
1360            } else {
1361                @valueList = ($valueParm);
1362            }
1363            # Okay, now we have all the possible criteria for the first value in the list
1364            # @valueList. We'll copy the values to a new array in which they have been
1365            # converted to generic requests. If we find a regular-expression match
1366            # anywhere in the list, we toss the whole thing.
1367            my @valuePatterns = ();
1368            my $okValues = 1;
1369            for my $valuePattern (@valueList) {
1370                # Check the pattern type.
1371                if (substr($valuePattern, 0, 1) eq '/') {
1372                    # Regular expressions invalidate the entire process.
1373                    $okValues = 0;
1374                } elsif (substr($valuePattern, -1, 1) eq '%') {
1375                    # A Generic pattern is passed in unmodified.
1376                    push @valuePatterns, $valuePattern;
1377                } else {
1378                    # An exact match is converted to generic.
1379                    push @valuePatterns, "$valuePattern%";
1380                }
1381            }
1382            # If everything works, add the value data to the filtering hash.
1383            if ($okValues) {
1384                $data{'HasValueFor(value)'} = \@valuePatterns;
1385            }
1386        }
1387        # Create some lists to contain the filter fragments and parameter values.
1388      my @filter = ();      my @filter = ();
1389      my @parms = ();      my @parms = ();
1390      # 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
1391      # parameter list and generates filters for each.      # parameter list and generates filters for each. The %data hash that we built above
1392        # contains all the necessary information to do this.
1393      for my $field (keys %data) {      for my $field (keys %data) {
1394          # Accumulate filter information for this field. We will OR together all the          # Accumulate filter information for this field. We will OR together all the
1395          # elements accumulated to create the final result.          # elements accumulated to create the final result.
# Line 995  Line 1417 
1417                          push @fieldFilter, "$field = ?";                          push @fieldFilter, "$field = ?";
1418                          push @parms, $pattern;                          push @parms, $pattern;
1419                      } else {                      } else {
1420                          # 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
1421                          # filter the field to this value pattern.                          # filter the field to this value pattern.
1422                          push @fieldFilter, "$field LIKE ?";                          push @fieldFilter, "$field LIKE ?";
1423                          # 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 1439 
1439      # 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
1440      # values to bind to them.      # values to bind to them.
1441      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);  
1442      # Now we're ready to make our query.      # Now we're ready to make our query.
1443      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1444      # Loop through the assignments found.      # Format the results.
1445      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];  
         }  
     }  
1446      # Return the rows found.      # Return the rows found.
1447      return @retVal;      return @retVal;
1448  }  }
# Line 1093  Line 1488 
1488          # 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
1489          # into a scalar.          # into a scalar.
1490          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1491            # Split up the key.
1492            my ($realKey, $subKey) = $self->SplitKey($key);
1493          # Connect the object to the key.          # Connect the object to the key.
1494          $self->InsertObject('HasValueFor', { 'from-link' => $key,          $self->InsertObject('HasValueFor', { 'from-link' => $realKey,
1495                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1496                                                 'subkey'    => $subKey,
1497                                               'value'     => $valueString,                                               'value'     => $valueString,
1498                                         });                                         });
1499      }      }
# Line 1136  Line 1534 
1534          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1535      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1536          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1537      } elsif (scalar(@values) == 0) {      } else {
1538          # Here we erase the entire key.          # Split the key into the real key and the subkey.
1539          $self->EraseAttribute($key);          my ($realKey, $subKey) = $self->SplitKey($key);
1540            if ($subKey eq '' && scalar(@values) == 0) {
1541                # Here we erase the entire key for this object.
1542                $self->DeleteRow('HasValueFor', $key, $objectID);
1543      } else {      } else {
1544          # Here we erase the matching values.          # Here we erase the matching values.
1545          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1546          $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });              $self->DeleteRow('HasValueFor', $realKey, $objectID,
1547                                 { subkey => $subKey, value => $valueString });
1548            }
1549      }      }
1550      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1551      return 1;      return 1;
1552  }  }
1553    
1554    =head3 DeleteMatchingAttributes
1555    
1556    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1557    
1558    Delete all attributes that match the specified criteria. This is equivalent to
1559    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1560    row found.
1561    
1562    =over 4
1563    
1564    =item objectID
1565    
1566    ID of object whose attributes are to be deleted. If the attributes for multiple
1567    objects are to be deleted, this parameter can be specified as a list reference. If
1568    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1569    Finally, you can delete attributes for a range of object IDs by putting a percent
1570    sign (C<%>) at the end.
1571    
1572    =item key
1573    
1574    Attribute key name. A value of C<undef> or an empty string will match all
1575    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1576    specified as a list reference. Finally, you can delete attributes for a range of
1577    keys by putting a percent sign (C<%>) at the end.
1578    
1579    =item values
1580    
1581    List of the desired attribute values, section by section. If C<undef>
1582    or an empty string is specified, all values in that section will match. A
1583    generic match can be requested by placing a percent sign (C<%>) at the end.
1584    In that case, all values that match up to and not including the percent sign
1585    will match. You may also specify a regular expression enclosed
1586    in slashes. All values that match the regular expression will be deleted. For
1587    performance reasons, only values have this extra capability.
1588    
1589    =item RETURN
1590    
1591    Returns a list of tuples for the attributes that were deleted, in the
1592    same form as L</GetAttributes>.
1593    
1594    =back
1595    
1596    =cut
1597    
1598    sub DeleteMatchingAttributes {
1599        # Get the parameters.
1600        my ($self, $objectID, $key, @values) = @_;
1601        # Get the matching attributes.
1602        my @retVal = $self->GetAttributes($objectID, $key, @values);
1603        # Loop through the attributes, deleting them.
1604        for my $tuple (@retVal) {
1605            $self->DeleteAttribute(@{$tuple});
1606        }
1607        # Log this operation.
1608        my $count = @retVal;
1609        $self->LogOperation("Mass Delete", $key, "$count matching attributes deleted.");
1610        # Return the deleted attributes.
1611        return @retVal;
1612    }
1613    
1614  =head3 ChangeAttribute  =head3 ChangeAttribute
1615    
1616  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1211  Line 1674 
1674    
1675  =item key  =item key
1676    
1677  Key to erase.  Key to erase. This must be a real key; that is, it cannot have a subkey
1678    component.
1679    
1680  =back  =back
1681    
# Line 1220  Line 1684 
1684  sub EraseAttribute {  sub EraseAttribute {
1685      # Get the parameters.      # Get the parameters.
1686      my ($self, $key) = @_;      my ($self, $key) = @_;
1687      # Delete everything connected to the key. The "keepRoot" option keeps the key in the      # Delete everything connected to the key.
1688      # datanase while deleting everything attached to it.      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1689      $self->Delete('AttributeKey', $key, keepRoot => 1);      # Log the operation.
1690        $self->LogOperation("Erase Data", $key);
1691      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1692      return 1;      return 1;
1693  }  }
# Line 1257  Line 1722 
1722      return sort @groups;      return sort @groups;
1723  }  }
1724    
1725    =head2 Key and ID Manipulation Methods
1726    
1727    =head3 ParseID
1728    
1729    C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>
1730    
1731    Determine the type and object ID corresponding to an ID value from the attribute database.
1732    Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);
1733    however, Genomes, Features, and Subsystems are not stored with a type name, so we need to
1734    deduce the type from the ID value structure.
1735    
1736    The theory here is that you can plug the ID and type directly into a Sprout database method, as
1737    follows
1738    
1739        my ($type, $id) = CustomAttributes::ParseID($attrList[$num]->[0]);
1740        my $target = $sprout->GetEntity($type, $id);
1741    
1742    =over 4
1743    
1744    =item idValue
1745    
1746    ID value taken from the attribute database.
1747    
1748    =item RETURN
1749    
1750    Returns a two-element list. The first element is the type of object indicated by the ID value,
1751    and the second element is the actual object ID.
1752    
1753    =back
1754    
1755    =cut
1756    
1757    sub ParseID {
1758        # Get the parameters.
1759        my ($idValue) = @_;
1760        # Declare the return variables.
1761        my ($type, $id);
1762        # Parse the incoming ID. We first check for the presence of an entity name. Entity names
1763        # can only contain letters, which helps to insure typed object IDs don't collide with
1764        # subsystem names (which are untyped).
1765        if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1766            # Here we have a typed ID.
1767            ($type, $id) = ($1, $2);
1768        } elsif ($idValue =~ /fig\|/) {
1769            # Here we have a feature ID.
1770            ($type, $id) = (Feature => $idValue);
1771        } elsif ($idValue =~ /\d+\.\d+/) {
1772            # Here we have a genome ID.
1773            ($type, $id) = (Genome => $idValue);
1774        } else {
1775            # The default is a subsystem ID.
1776            ($type, $id) = (Subsystem => $idValue);
1777        }
1778        # Return the results.
1779        return ($type, $id);
1780    }
1781    
1782    =head3 FormID
1783    
1784    C<< my $idValue = CustomAttributes::FormID($type, $id); >>
1785    
1786    Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,
1787    genomes, and features are stored in the database without type information, but all other object IDs
1788    must be prefixed with the object type.
1789    
1790    =over 4
1791    
1792    =item type
1793    
1794    Relevant object type.
1795    
1796    =item id
1797    
1798    ID of the object in question.
1799    
1800    =item RETURN
1801    
1802    Returns a string that will be recognized as an object ID in the attribute database.
1803    
1804    =back
1805    
1806    =cut
1807    
1808    sub FormID {
1809        # Get the parameters.
1810        my ($type, $id) = @_;
1811        # Declare the return variable.
1812        my $retVal;
1813        # Compute the ID string from the type.
1814        if (grep { $type eq $_ } qw(Feature Genome Subsystem)) {
1815            $retVal = $id;
1816        } else {
1817            $retVal = "$type:$id";
1818        }
1819        # Return the result.
1820        return $retVal;
1821    }
1822    
1823    =head3 GetTargetObject
1824    
1825    C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>
1826    
1827    Return the database object corresponding to the specified attribute object ID. The
1828    object type associated with the ID value must correspond to an entity name in the
1829    specified database.
1830    
1831    =over 4
1832    
1833    =item erdb
1834    
1835    B<ERDB> object for accessing the target database.
1836    
1837    =item idValue
1838    
1839    ID value retrieved from the attribute database.
1840    
1841    =item RETURN
1842    
1843    Returns a B<DBObject> for the attribute value's target object.
1844    
1845    =back
1846    
1847    =cut
1848    
1849    sub GetTargetObject {
1850        # Get the parameters.
1851        my ($erdb, $idValue) = @_;
1852        # Declare the return variable.
1853        my $retVal;
1854        # Get the type and ID for the target object.
1855        my ($type, $id) = ParseID($idValue);
1856        # Plug them into the GetEntity method.
1857        $retVal = $erdb->GetEntity($type, $id);
1858        # Return the resulting object.
1859        return $retVal;
1860    }
1861    
1862    =head3 SplitKey
1863    
1864    C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>
1865    
1866    Split an external key (that is, one passed in by a caller) into the real key and the sub key.
1867    The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,
1868    then the sub key is presumed to be an empty string.
1869    
1870    =over 4
1871    
1872    =item key
1873    
1874    Incoming key to be split.
1875    
1876    =item RETURN
1877    
1878    Returns a two-element list, the first element of which is the real key and the second element of
1879    which is the sub key.
1880    
1881    =back
1882    
1883    =cut
1884    
1885    sub SplitKey {
1886        # Get the parameters.
1887        my ($self, $key) = @_;
1888        # Do the split.
1889        my ($realKey, $subKey) = split($self->{splitter}, $key, 2);
1890        # Insure the subkey has a value.
1891        if (! defined $subKey) {
1892            $subKey = '';
1893        }
1894        # Return the results.
1895        return ($realKey, $subKey);
1896    }
1897    
1898    =head3 JoinKey
1899    
1900    C<< my $key = $ca->JoinKey($realKey, $subKey); >>
1901    
1902    Join a real key and a subkey together to make an external key. The external key is the attribute key
1903    used by the caller. The real key and the subkey are how the keys are represented in the database. The
1904    real key is the key to the B<AttributeKey> entity. The subkey is an attribute of the B<HasValueFor>
1905    relationship.
1906    
1907    =over 4
1908    
1909    =item realKey
1910    
1911    The real attribute key.
1912    
1913    =item subKey
1914    
1915    The subordinate portion of the attribute key.
1916    
1917    =item RETURN
1918    
1919    Returns a single string representing both keys.
1920    
1921    =back
1922    
1923    =cut
1924    
1925    sub JoinKey {
1926        # Get the parameters.
1927        my ($self, $realKey, $subKey) = @_;
1928        # Declare the return variable.
1929        my $retVal;
1930        # Check for a subkey.
1931        if ($subKey eq '') {
1932            # No subkey, so the real key is the key.
1933            $retVal = $realKey;
1934        } else {
1935            # Subkey found, so the two pieces must be joined by a splitter.
1936            $retVal = "$realKey$self->{splitter}$subKey";
1937        }
1938        # Return the result.
1939        return $retVal;
1940    }
1941    
1942  1;  1;

Legend:
Removed from v.1.12  
changed lines
  Added in v.1.21

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3