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

Legend:
Removed from v.1.14  
changed lines
  Added in v.1.27

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3