[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.19, Fri Feb 9 22:59:18 2007 UTC
# Line 28  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 40  Line 73 
73  New attribute keys must be defined before they can be used. A web interface  New attribute keys must be defined before they can be used. A web interface
74  is provided for this purpose.  is provided for this purpose.
75    
76    Major attribute activity is recorded in a log (C<attributes.log>) in the
77    C<$FIG_Config::var> directory. The log reports the user name, time, and
78    the details of the operation. The user name will almost always be unknown,
79    except when it is specified in this object's constructor (see L</new>).
80    
81  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
82    
83  The following configuration parameters are used to manage custom attributes.  The following configuration parameters are used to manage custom attributes.
# Line 88  Line 126 
126    
127  =head3 new  =head3 new
128    
129  C<< my $attrDB = CustomAttributes->new($splitter); >>  C<< my $attrDB = CustomAttributes->new(%options); >>
130    
131  Construct a new CustomAttributes object.  Construct a new CustomAttributes object. The following options are
132    supported.
133    
134  =over 4  =over 4
135    
136  =item splitter  =item splitter
137    
138  Value to be used to split attribute values into sections in the  Value to be used to split attribute values into sections in the
139  L</Fig Replacement Methods>. The default is a double colon C<::>.  L</Fig Replacement Methods>. The default is a double colon C<::>,
140  If you do not use the replacement methods, you do not need to  and should only be overridden in extreme circumstances.
141  worry about this parameter.  
142    =item user
143    
144    Name of the current user. This will appear in the attribute log.
145    
146  =back  =back
147    
# Line 107  Line 149 
149    
150  sub new {  sub new {
151      # Get the parameters.      # Get the parameters.
152      my ($class, $splitter) = @_;      my ($class, %options) = @_;
153      # Connect to the database.      # Connect to the database.
154      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
155                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
# Line 117  Line 159 
159      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = $FIG_Config::attrDBD;
160      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
161      # Store the splitter value.      # Store the splitter value.
162      $retVal->{splitter} = (defined($splitter) ? $splitter : '::');      $retVal->{splitter} = $options{splitter} || '::';
163        # Store the user name.
164        $retVal->{user} = $options{user} || '<unknown>';
165        Trace("User $retVal->{user} selected for attribute object.") if T(3);
166      # Return the result.      # Return the result.
167      return $retVal;      return $retVal;
168  }  }
# Line 168  Line 213 
213      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
214          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid data type \"$type\" for $attributeName.");
215      } else {      } else {
216            # Create a variable to hold the action to be displayed for the log (Add or Update).
217            my $action;
218          # Okay, we're ready to begin. See if this key exists.          # Okay, we're ready to begin. See if this key exists.
219          my $attribute = $self->GetEntity('AttributeKey', $attributeName);          my $attribute = $self->GetEntity('AttributeKey', $attributeName);
220          if (defined($attribute)) {          if (defined($attribute)) {
221              # It does, so we do an update.              # It does, so we do an update.
222                $action = "Update Key";
223              $self->UpdateEntity('AttributeKey', $attributeName,              $self->UpdateEntity('AttributeKey', $attributeName,
224                                  { description => $notes, 'data-type' => $type });                                  { description => $notes, 'data-type' => $type });
225              # Detach the key from its current groups.              # Detach the key from its current groups.
226              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
227          } else {          } else {
228              # It doesn't, so we do an insert.              # It doesn't, so we do an insert.
229                $action = "Insert Key";
230              $self->InsertObject('AttributeKey', { id => $attributeName,              $self->InsertObject('AttributeKey', { id => $attributeName,
231                                  description => $notes, 'data-type' => $type });                                  description => $notes, 'data-type' => $type });
232          }          }
# Line 187  Line 236 
236              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
237                                                 'to-link'   => $group });                                                 'to-link'   => $group });
238          }          }
239            # Log the operation.
240            $self->LogOperation($action, $attributeName, "Group list is " . join(" ", @{$groups}));
241      }      }
242  }  }
243    
# Line 198  Line 249 
249  tab-delimited file with internal tab and new-line characters escaped. This is  tab-delimited file with internal tab and new-line characters escaped. This is
250  the typical TBL-style file used by most FIG applications. One of the columns  the typical TBL-style file used by most FIG applications. One of the columns
251  in the input file must contain the appropriate object id value and the other the  in the input file must contain the appropriate object id value and the other the
252  corresponding attribute value.  corresponding attribute value. The current contents of the attribute database will
253    be erased before loading, unless the options are used to override that behavior.
254    
255  =over 4  =over 4
256    
# Line 233  Line 285 
285    
286  =over 4  =over 4
287    
288  =item erase  =item keep
289    
290    If specified, the existing attribute values will not be erased.
291    
292  If TRUE, the key's values will all be erased before loading. (Doing so  =item archive
293  makes for a faster load.)  
294    If specified, the name of a file into which the incoming file should be saved.
295    
296  =back  =back
297    
# Line 246  Line 301 
301      # Get the parameters.      # Get the parameters.
302      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;
303      # Create the return variable.      # Create the return variable.
304      my $retVal = Stats->new("lineIn", "shortLine", "newObject");      my $retVal = Stats->new("lineIn", "shortLine");
305      # Compute the minimum number of fields required in each input line.      # Compute the minimum number of fields required in each input line. The user specifies two
306      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;      # columns, and we need to make sure both columns are in every record.
307        my $minCols = ($idCol < $dataCol ? $dataCol : $idCol) + 1;
308        Trace("Minimum column count is $minCols.") if T(3);
309        #
310      # Insure the attribute key exists.      # Insure the attribute key exists.
311      my $found = $self->GetEntity('AttributeKey', $keyName);      my $found = $self->GetEntity('AttributeKey', $keyName);
312      if (! defined $found) {      if (! defined $found) {
313          Confess("Attribute key \"$keyName\" not found in database.");          Confess("Attribute key \"$keyName\" not found in database.");
314      } else {      } else {
315          # Erase the key's current values.          # Erase the key's current values (unless, of course, the caller specified the "keep" option.
316            if (! $options{keep}) {
317          $self->EraseAttribute($keyName);          $self->EraseAttribute($keyName);
318            }
319            # Check for a save file. In the main loop, we'll know a save file is needed if $sh is
320            # defined.
321            my $sh;
322            if ($options{archive}) {
323                $sh = Open(undef, ">$options{archive}");
324                Trace("Attribute $keyName upload saved in $options{archive}.") if T(2);
325            }
326          # Save a list of the object IDs we need to add.          # Save a list of the object IDs we need to add.
327          my %objectIDs = ();          my %objectIDs = ();
328          # Loop through the input file.          # Loop through the input file.
# Line 263  Line 330 
330              # Get the next line of the file.              # Get the next line of the file.
331              my @fields = Tracer::GetLine($fh);              my @fields = Tracer::GetLine($fh);
332              $retVal->Add(lineIn => 1);              $retVal->Add(lineIn => 1);
333              # Now we need to validate the line.              my $count = scalar @fields;
334              if (scalar(@fields) < $minCols) {              Trace("Field count is $count. First field is \"$fields[0]\".") if T(4);
335                # Archive it if necessary.
336                if (defined $sh) {
337                    Tracer::PutLine($sh, \@fields);
338                }
339                # Now we need to check for comments and validate the line.
340                if ($fields[0] =~ /^\s*$/) {
341                    # Blank line: skip it.
342                    $retVal->Add(blank => 1);
343                } elsif (substr($fields[0],0,1) eq '#') {
344                    # Comment line: skip it.
345                    $retVal->Add(comment => 1);
346                } elsif ($count < $minCols) {
347                    # Line is too short: we have an error.
348                  $retVal->Add(shortLine => 1);                  $retVal->Add(shortLine => 1);
349              } else {              } else {
350                  # It's valid, so get the ID and value.                  # It's valid, so get the ID and value.
351                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
352                  # Denote we're using this input line.                  # Denote we're using this input line.
353                  $retVal->Add(lineUsed => 1);                  $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);  
                 }  
354                  # Now we insert the attribute.                  # Now we insert the attribute.
355                  $self->InsertObject('HasValueFor', { from => $keyName, to => $id, value => $value });                  $self->InsertObject('HasValueFor', { 'from-link' => $keyName,
356                                                         'to-link' => $id,
357                                                         value => $value });
358                  $retVal->Add(newValue => 1);                  $retVal->Add(newValue => 1);
359              }              }
360          }          }
361            # Log this operation.
362            $self->LogOperation("Load Key", $keyName, $retVal->Display());
363            # If there's an archive, close it.
364            if (defined $sh) {
365                close $sh;
366            }
367      }      }
368      # Return the statistics.      # Return the statistics.
369      return $retVal;      return $retVal;
# Line 316  Line 395 
395      my ($self, $attributeName) = @_;      my ($self, $attributeName) = @_;
396      # Delete the attribute key.      # Delete the attribute key.
397      my $retVal = $self->Delete('AttributeKey', $attributeName);      my $retVal = $self->Delete('AttributeKey', $attributeName);
398        # Log this operation.
399        $self->LogOperation("Delete Key", $attributeName, "Key will no longer be available for use by anyone.");
400      # Return the result.      # Return the result.
401      return $retVal;      return $retVal;
402    
# Line 589  Line 670 
670          # is nonempty.          # is nonempty.
671          Tracer::PutLine($fh, ['#GROUPS', @groups]);          Tracer::PutLine($fh, ['#GROUPS', @groups]);
672      }      }
673        # Log the operation.
674        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
675      # Return the result.      # Return the result.
676      return $retVal;      return $retVal;
677  }  }
# Line 659  Line 742 
742              }              }
743          }          }
744      }      }
745        # Log the operation.
746        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
747      # Return the result.      # Return the result.
748      return $retVal;      return $retVal;
749  }  }
# Line 719  Line 804 
804          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
805          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
806      }      }
807        # Log the operation.
808        $self->LogOperation("Backup Data", $fileName, $retVal->Display());
809      # Return the result.      # Return the result.
810      return $retVal;      return $retVal;
811  }  }
# Line 983  Line 1070 
1070      return %retVal;      return %retVal;
1071  }  }
1072    
1073    =head3 LogOperation
1074    
1075    C<< $ca->LogOperation($action, $target, $description); >>
1076    
1077    Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).
1078    
1079    =over 4
1080    
1081    =item action
1082    
1083    Action being logged (e.g. C<Delete Group> or C<Load Key>).
1084    
1085    =item target
1086    
1087    ID of the key or group affected.
1088    
1089    =item description
1090    
1091    Short description of the action.
1092    
1093    =back
1094    
1095    =cut
1096    
1097    sub LogOperation {
1098        # Get the parameters.
1099        my ($self, $action, $target, $description) = @_;
1100        # Get the user ID.
1101        my $user = $self->{user};
1102        # Get a timestamp.
1103        my $timeString = Tracer::Now();
1104        # Open the log file for appending.
1105        my $oh = Open(undef, ">>$FIG_Config::var/attributes.log");
1106        # Write the data to it.
1107        Tracer::PutLine($oh, [$timeString, $user, $action, $target, $description]);
1108        # Close the log file.
1109        close $oh;
1110    }
1111    
1112    =head2 Internal Utility Methods
1113    
1114    =head3 _KeywordString
1115    
1116    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
1117    
1118    Compute the keyword string for a specified key/value pair. This consists of the
1119    key name and value converted to lower case with underscores translated to spaces.
1120    
1121    This method is for internal use only. It is called whenever we need to update or
1122    insert a B<HasValueFor> record.
1123    
1124    =over 4
1125    
1126    =item key
1127    
1128    Name of the relevant attribute key.
1129    
1130    =item target
1131    
1132    ID of the target object to which this key/value pair will be associated.
1133    
1134    =item value
1135    
1136    The value to store for this key/object combination.
1137    
1138    =item RETURN
1139    
1140    Returns the value that should be stored as the keyword string for the specified
1141    key/value pair.
1142    
1143    =back
1144    
1145    =cut
1146    
1147    sub _KeywordString {
1148        # Get the parameters.
1149        my ($self, $key, $value) = @_;
1150        # Get a copy of the key name and convert underscores to spaces.
1151        my $keywordString = $key;
1152        $keywordString =~ s/_/ /g;
1153        # Add the value convert it all to lower case.
1154        my $retVal = lc "$keywordString $value";
1155        # Return the result.
1156        return $retVal;
1157    }
1158    
1159    =head3 _QueryResults
1160    
1161    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1162    
1163    Match the results of a B<HasValueFor> query against value criteria and return
1164    the results. This is an internal method that splits the values coming back
1165    and matches the sections against the specified section patterns. It serves
1166    as the back end to L</GetAttributes> and L</FindAttributes>.
1167    
1168    =over 4
1169    
1170    =item query
1171    
1172    A query object that will return the desired B<HasValueFor> records.
1173    
1174    =item values
1175    
1176    List of the desired attribute values, section by section. If C<undef>
1177    or an empty string is specified, all values in that section will match. A
1178    generic match can be requested by placing a percent sign (C<%>) at the end.
1179    In that case, all values that match up to and not including the percent sign
1180    will match. You may also specify a regular expression enclosed
1181    in slashes. All values that match the regular expression will be returned. For
1182    performance reasons, only values have this extra capability.
1183    
1184    =item RETURN
1185    
1186    Returns a list of tuples. The first element in the tuple is an object ID, the
1187    second is an attribute key, and the remaining elements are the sections of
1188    the attribute value. All of the tuples will match the criteria set forth in
1189    the parameter list.
1190    
1191    =back
1192    
1193    =cut
1194    
1195    sub _QueryResults {
1196        # Get the parameters.
1197        my ($self, $query, @values) = @_;
1198        # Declare the return value.
1199        my @retVal = ();
1200        # Get the number of value sections we have to match.
1201        my $sectionCount = scalar(@values);
1202        # Loop through the assignments found.
1203        while (my $row = $query->Fetch()) {
1204            # Get the current row's data.
1205            my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1206                                                          'HasValueFor(value)']);
1207            # Break the value into sections.
1208            my @sections = split($self->{splitter}, $valueString);
1209            # Match each section against the incoming values. We'll assume we're
1210            # okay unless we learn otherwise.
1211            my $matching = 1;
1212            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1213                # We need to check to see if this section is generic.
1214                my $value = $values[$i];
1215                Trace("Current value pattern is \"$value\".") if T(4);
1216                if (substr($value, -1, 1) eq '%') {
1217                    Trace("Generic match used.") if T(4);
1218                    # Here we have a generic match.
1219                    my $matchLen = length($values[$i] - 1);
1220                    $matching = substr($sections[$i], 0, $matchLen) eq
1221                                substr($values[$i], 0, $matchLen);
1222                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1223                    Trace("Regular expression detected.") if T(4);
1224                    # Here we have a regular expression match.
1225                    my $section = $sections[$i];
1226                    $matching = eval("\$section =~ $value");
1227                } else {
1228                    # Here we have a strict match.
1229                    Trace("Strict match used.") if T(4);
1230                    $matching = ($sections[$i] eq $values[$i]);
1231                }
1232            }
1233            # If we match, output this row to the return list.
1234            if ($matching) {
1235                push @retVal, [$id, $key, @sections];
1236            }
1237        }
1238        # Return the rows found.
1239        return @retVal;
1240    }
1241    
1242  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1243    
1244  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 1151  Line 1407 
1407      # 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
1408      # values to bind to them.      # values to bind to them.
1409      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);  
1410      # Now we're ready to make our query.      # Now we're ready to make our query.
1411      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1412      # Loop through the assignments found.      # Format the results.
1413      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];  
         }  
     }  
1414      # Return the rows found.      # Return the rows found.
1415      return @retVal;      return @retVal;
1416  }  }
# Line 1282  Line 1500 
1500      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1501          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1502      } elsif (scalar(@values) == 0) {      } elsif (scalar(@values) == 0) {
1503          # Here we erase the entire key.          # Here we erase the entire key for this object.
1504          $self->EraseAttribute($key);          $self->DeleteRow('HasValueFor', $key, $objectID);
1505      } else {      } else {
1506          # Here we erase the matching values.          # Here we erase the matching values.
1507          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
# Line 1293  Line 1511 
1511      return 1;      return 1;
1512  }  }
1513    
1514    =head3 DeleteMatchingAttributes
1515    
1516    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1517    
1518    Delete all attributes that match the specified criteria. This is equivalent to
1519    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1520    row found.
1521    
1522    =over 4
1523    
1524    =item objectID
1525    
1526    ID of object whose attributes are to be deleted. If the attributes for multiple
1527    objects are to be deleted, this parameter can be specified as a list reference. If
1528    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1529    Finally, you can delete attributes for a range of object IDs by putting a percent
1530    sign (C<%>) at the end.
1531    
1532    =item key
1533    
1534    Attribute key name. A value of C<undef> or an empty string will match all
1535    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1536    specified as a list reference. Finally, you can delete attributes for a range of
1537    keys by putting a percent sign (C<%>) at the end.
1538    
1539    =item values
1540    
1541    List of the desired attribute values, section by section. If C<undef>
1542    or an empty string is specified, all values in that section will match. A
1543    generic match can be requested by placing a percent sign (C<%>) at the end.
1544    In that case, all values that match up to and not including the percent sign
1545    will match. You may also specify a regular expression enclosed
1546    in slashes. All values that match the regular expression will be deleted. For
1547    performance reasons, only values have this extra capability.
1548    
1549    =item RETURN
1550    
1551    Returns a list of tuples for the attributes that were deleted, in the
1552    same form as L</GetAttributes>.
1553    
1554    =back
1555    
1556    =cut
1557    
1558    sub DeleteMatchingAttributes {
1559        # Get the parameters.
1560        my ($self, $objectID, $key, @values) = @_;
1561        # Get the matching attributes.
1562        my @retVal = $self->GetAttributes($objectID, $key, @values);
1563        # Loop through the attributes, deleting them.
1564        for my $tuple (@retVal) {
1565            $self->DeleteAttribute(@{$tuple});
1566        }
1567        # Log this operation.
1568        my $count = @retVal;
1569        $self->LogOperation("Mass Delete", $key, "$count matching attributes deleted.");
1570        # Return the deleted attributes.
1571        return @retVal;
1572    }
1573    
1574  =head3 ChangeAttribute  =head3 ChangeAttribute
1575    
1576  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1365  Line 1643 
1643  sub EraseAttribute {  sub EraseAttribute {
1644      # Get the parameters.      # Get the parameters.
1645      my ($self, $key) = @_;      my ($self, $key) = @_;
1646      # Delete everything connected to the key. The "keepRoot" option keeps the key in the      # Delete everything connected to the key.
1647      # datanase while deleting everything attached to it.      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1648      $self->Delete('AttributeKey', $key, keepRoot => 1);      # Log the operation.
1649        $self->LogOperation("Erase Data", $key);
1650      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1651      return 1;      return 1;
1652  }  }
# Line 1402  Line 1681 
1681      return sort @groups;      return sort @groups;
1682  }  }
1683    
1684    =head3 ParseID
1685    
1686    C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>
1687    
1688    Determine the type and object ID corresponding to an ID value from the attribute database.
1689    Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);
1690    however, Genomes, Features, and Subsystems are not stored with a type name, so we need to
1691    deduce the type from the ID value structure.
1692    
1693    The theory here is that you can plug the ID and type directly into a Sprout database method, as
1694    follows
1695    
1696        my ($type, $id) = CustomAttributes::ParseID($attrList[$num]->[0]);
1697        my $target = $sprout->GetEntity($type, $id);
1698    
1699    =over 4
1700    
1701    =item idValue
1702    
1703    ID value taken from the attribute database.
1704    
1705    =item RETURN
1706    
1707    Returns a two-element list. The first element is the type of object indicated by the ID value,
1708    and the second element is the actual object ID.
1709    
1710    =back
1711    
1712    =cut
1713    
1714    sub ParseID {
1715        # Get the parameters.
1716        my ($idValue) = @_;
1717        # Declare the return variables.
1718        my ($type, $id);
1719        # Parse the incoming ID. We first check for the presence of an entity name. Entity names
1720        # can only contain letters, which helps to insure typed object IDs don't collide with
1721        # subsystem names (which are untyped).
1722        if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1723            # Here we have a typed ID.
1724            ($type, $id) = ($1, $2);
1725        } elsif ($idValue =~ /fig\|/) {
1726            # Here we have a feature ID.
1727            ($type, $id) = (Feature => $idValue);
1728        } elsif ($idValue =~ /\d+\.\d+/) {
1729            # Here we have a genome ID.
1730            ($type, $id) = (Genome => $idValue);
1731        } else {
1732            # The default is a subsystem ID.
1733            ($type, $id) = (Subsystem => $idValue);
1734        }
1735        # Return the results.
1736        return ($type, $id);
1737    }
1738    
1739    =head3 FormID
1740    
1741    C<< my $idValue = CustomAttributes::FormID($type, $id); >>
1742    
1743    Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,
1744    genomes, and features are stored in the database without type information, but all other object IDs
1745    must be prefixed with the object type.
1746    
1747    =over 4
1748    
1749    =item type
1750    
1751    Relevant object type.
1752    
1753    =item id
1754    
1755    ID of the object in question.
1756    
1757    =item RETURN
1758    
1759    Returns a string that will be recognized as an object ID in the attribute database.
1760    
1761    =back
1762    
1763    =cut
1764    
1765    sub FormID {
1766        # Get the parameters.
1767        my ($type, $id) = @_;
1768        # Declare the return variable.
1769        my $retVal;
1770        # Compute the ID string from the type.
1771        if (grep { $type eq $_ } qw(Feature Genome Subsystem)) {
1772            $retVal = $id;
1773        } else {
1774            $retVal = "$type:$id";
1775        }
1776        # Return the result.
1777        return $retVal;
1778    }
1779    
1780    =head3 GetTargetObject
1781    
1782    C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>
1783    
1784    Return the database object corresponding to the specified attribute object ID. The
1785    object type associated with the ID value must correspond to an entity name in the
1786    specified database.
1787    
1788    =over 4
1789    
1790    =item erdb
1791    
1792    B<ERDB> object for accessing the target database.
1793    
1794    =item idValue
1795    
1796    ID value retrieved from the attribute database.
1797    
1798    =item RETURN
1799    
1800    Returns a B<DBObject> for the attribute value's target object.
1801    
1802    =back
1803    
1804    =cut
1805    
1806    sub GetTargetObject {
1807        # Get the parameters.
1808        my ($erdb, $idValue) = @_;
1809        # Declare the return variable.
1810        my $retVal;
1811        # Get the type and ID for the target object.
1812        my ($type, $id) = ParseID($idValue);
1813        # Plug them into the GetEntity method.
1814        $retVal = $erdb->GetEntity($type, $id);
1815        # Return the resulting object.
1816        return $retVal;
1817    }
1818    
1819  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3