[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.2, Fri Nov 3 16:50:04 2006 UTC revision 1.12, Fri Dec 15 03:24:59 2006 UTC
# Line 4  Line 4 
4    
5      require Exporter;      require Exporter;
6      use ERDB;      use ERDB;
7      @ISA = qw(Exporter ERDB);      @ISA = qw(ERDB);
8      use strict;      use strict;
9      use Tracer;      use Tracer;
     use FIG;  
10      use ERDBLoad;      use ERDBLoad;
11    
12  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
# Line 16  Line 15 
15    
16  The Custom SEED Attributes Manager allows the user to upload and retrieve  The Custom SEED Attributes Manager allows the user to upload and retrieve
17  custom data for SEED objects. It uses the B<ERDB> database system to  custom data for SEED objects. It uses the B<ERDB> database system to
18  store the attributes, which are implemented as multi-valued fields  store the attributes.
19  of ERDB entities.  
20    Attributes are organized by I<attribute key>. Attribute values are
21    assigned to I<objects>. In the real world, objects have types and IDs;
22    however, to the attribute database only the ID matters. This will create
23    a problem if we have a single ID that applies to two objects of different
24    types, but it is more consistent with the original attribute implementation
25    in the SEED (which this implementation replaces).
26    
27    The actual attribute values are stored as a relationship between the attribute
28    keys and the objects. There can be multiple values for a single key/object pair.
29    
30  The full suite of ERDB retrieval capabilities is provided. In addition,  The full suite of ERDB retrieval capabilities is provided. In addition,
31  custom methods are provided specific to this application. To get all  custom methods are provided specific to this application. To get all
32  the values of the attribute C<essential> in the B<Feature> entity, you  the values of the attribute C<essential> in a specified B<Feature>, you
33  would code  would code
34    
35      my @values = $attrDB->GetAttributes($fid, Feature => 'essential');      my @values = $attrDB->GetAttributes($fid, 'essential');
36    
37  where I<$fid> contains the ID of the desired feature. Each attribute has  where I<$fid> contains the ID of the desired feature.
 an alternate index to allow searching for attributes by value.  
38    
39  New attributes are introduced by updating the database definition at  New attribute keys must be defined before they can be used. A web interface
40  run-time. Attribute values are stored by uploading data from files.  is provided for this purpose.
 A web interface is provided for both these activities.  
41    
42  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
43    
# Line 77  Line 83 
83    
84  =back  =back
85    
 =head2 Impliementation Note  
   
 The L</Refresh> method reloads the entities in the database. If new  
 entity types are added, that method will need to be adjusted accordingly.  
   
86  =head2 Public Methods  =head2 Public Methods
87    
88  =head3 new  =head3 new
89    
90  C<< my $attrDB = CustomAttributes->new(); >>  C<< my $attrDB = CustomAttributes->new($splitter); >>
91    
92    Construct a new CustomAttributes object.
93    
94    =over 4
95    
96    =item splitter
97    
98    Value to be used to split attribute values into sections in the
99    L</Fig Replacement Methods>. The default is a double colon C<::>.
100    If you do not use the replacement methods, you do not need to
101    worry about this parameter.
102    
103  Construct a new CustomAttributes object. This object is only used to load  =back
 or access data. To add new attributes, use the static L</NewAttribute>  
 method.  
104    
105  =cut  =cut
106    
107  sub new {  sub new {
108      # Get the parameters.      # Get the parameters.
109      my ($class) = @_;      my ($class, $splitter) = @_;
110      # Connect to the database.      # Connect to the database.
111      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
112                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
# Line 105  Line 115 
115      # Create the ERDB object.      # Create the ERDB object.
116      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = $FIG_Config::attrDBD;
117      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
118        # Store the splitter value.
119        $retVal->{splitter} = (defined($splitter) ? $splitter : '::');
120      # Return the result.      # Return the result.
121      return $retVal;      return $retVal;
122  }  }
123    
124  =head3 GetAttributes  =head3 StoreAttributeKey
   
 C<< my @values = $attrDB->GetAttributes($id, $entityName => $attributeName); >>  
   
 Return all the values of the specified attribute for the specified entity instance.  
 A list of vaues will be returned. If the entity instance does not exist or the  
 attribute has no values, an empty list will be returned. If the attribute name  
 does not exist, an SQL error will occur.  
   
 A typical invocation would look like this:  
   
     my @values = $sttrDB->GetAttributes($fid, Feature => 'essential');  
   
 Here the user is asking for the values of the C<essential> attribute for the  
 B<Feature> with the specified ID. If the identified feature is not essential,  
 the list returned will be empty. If it is essential, then one or more values  
 will be returned that describe the essentiality.  
   
 =over 4  
   
 =item id  
   
 ID of the desired entity instance. This identifies the specific object to  
 be interrogated for attribute values.  
   
 =item entityName  
   
 Name of the entity. This identifies the the type of the object to be  
 interrogated for attribute values.  
   
 =item attributeName  
   
 Name of the desired attribute.  
   
 =item RETURN  
   
 Returns zero or more strings, each representing a value of the named attribute  
 for the specified entity instance.  
   
 =back  
   
 =cut  
   
 sub GetAttributes {  
     # Get the parameters.  
     my ($self, $id, $entityName, $attributeName) = @_;  
     # Get the data.  
     my @retVal = $self->GetEntityValues($entityName, $id, ["$entityName($attributeName)"]);  
     # Return the result.  
     return @retVal;  
 }  
   
 =head3 StoreAttribute  
125    
126  C<< my $attrDB = CustomAttributes::StoreAttribute($entityName, $attributeName, $type, $notes); >>  C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>
127    
128  Create or update an attribute for the database. This method will update the database definition  Create or update an attribute for the database.
 XML, but it will not create the table. It will connect to the database so that the caller  
 can upload the attribute values.  
129    
130  =over 4  =over 4
131    
 =item entityName  
   
 Name of the entity containing the attribute. The entity must exist.  
   
132  =item attributeName  =item attributeName
133    
134  Name of the attribute. It must be a valid ERDB field name, consisting entirely of  Name of the attribute. It must be a valid ERDB field name, consisting entirely of
# Line 189  Line 143 
143    
144  Descriptive notes about the attribute. It is presumed to be raw text, not HTML.  Descriptive notes about the attribute. It is presumed to be raw text, not HTML.
145    
146  =item RETURN  =item groups
147    
148  Returns a Custom Attribute Database object if successful. If unsuccessful, an  Reference to a list of the groups to which the attribute should be associated.
149  error will be thrown.  This will replace any groups to which the attribute is currently attached.
150    
151  =back  =back
152    
153  =cut  =cut
154    
155  sub StoreAttribute {  sub StoreAttributeKey {
156      # Get the parameters.      # Get the parameters.
157      my ($entityName, $attributeName, $type, $notes) = @_;      my ($self, $attributeName, $type, $notes, $groups) = @_;
158        # Declare the return variable.
159        my $retVal;
160      # Get the data type hash.      # Get the data type hash.
161      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
162      # Validate the initial input values.      # Validate the initial input values.
# Line 210  Line 166 
166          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
167      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
168          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid data type \"$type\" for $attributeName.");
169        } else {
170            # Okay, we're ready to begin. See if this key exists.
171            my $attribute = $self->GetEntity('AttributeKey', $attributeName);
172            if (defined($attribute)) {
173                # It does, so we do an update.
174                $self->UpdateEntity('AttributeKey', $attributeName,
175                                    { description => $notes, 'data-type' => $type });
176                # Detach the key from its current groups.
177                $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
178            } else {
179                # It doesn't, so we do an insert.
180                $self->InsertObject('AttributeKey', { id => $attributeName,
181                                    description => $notes, 'data-type' => $type });
182      }      }
183      # Our next step is to read in the XML for the database defintion. We          # Attach the key to the specified groups. (We presume the groups already
184      # need to verify that the named entity exists.          # exist.)
185      my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);          for my $group (@{$groups}) {
186      my $entityHash = $metadata->{Entities};              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
187      if (! exists $entityHash->{$entityName}) {                                                 'to-link'   => $group });
         Confess("Entity $entityName not found.");  
     } else {  
         # Okay, we're ready to begin. Get the entity hash and the field hash.  
         my $entityData = $entityHash->{$entityName};  
         my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);  
         # Compute the attribute's relation name.  
         my $relName = join("", $entityName, map { ucfirst $_ } split(/-/, $attributeName));  
         # Store the attribute's field data. Note the use of the "content" hash for  
         # the notes. This is how the XML writer knows Notes is a text tag instead of  
         # an attribute.  
         $fieldHash->{$attributeName} = { type => $type, relation => $relName,  
                                          Notes => { content => $notes } };  
         # Insure we have an index for this attribute.  
         my $index = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);  
         if (! defined($index)) {  
             push @{$entityData->{Indexes}}, { IndexFields => [ { name => $attributeName, order => 'ascending' } ],  
                                               Notes       => "Alternate index provided for access by $attributeName." };  
         }  
         # Write the XML back out.  
         ERDB::WriteMetaXML($metadata, $FIG_Config::attrDBD);  
188      }      }
     # Open a database with the new XML.  
     my $retVal = CustomAttributes->new();  
     return $retVal;  
189  }  }
   
 =head3 Refresh  
   
 C<< $attrDB->Refresh(); >>  
   
 Refresh the primary entity tables from the FIG data store. This method basically  
 drops and reloads the main tables of the custom attributes database.  
   
 =cut  
   
 sub Refresh {  
     # Get the parameters.  
     my ($self) = @_;  
     # Create load objects for the genomes and the features.  
     my $loadGenome = ERDBLoad->new($self, 'Genome', $FIG_Config::temp);  
     my $loadFeature = ERDBLoad->new($self, 'Feature', $FIG_Config::temp);  
     # Get a FIG object. We'll use this to create the data.  
     my $fig = FIG->new();  
     # Get the genome list.  
     my @genomes = $fig->genomes();  
     # Loop through the genomes.  
     for my $genomeID (@genomes) {  
         # Put this genome in the genome table.  
         $loadGenome->Put($genomeID);  
         Trace("Processing Genome $genomeID") if T(3);  
         # Put its features into the feature table. Note we have to use a hash to  
         # remove duplicates.  
         my %featureList = map { $_ => 1 } $fig->all_features($genomeID);  
         for my $fid (keys %featureList) {  
             $loadFeature->Put($fid);  
         }  
     }  
     # Get a variable for holding statistics objects.  
     my $stats;  
     # Finish the genome load.  
     Trace("Loading Genome relation.") if T(2);  
     $stats = $loadGenome->FinishAndLoad();  
     Trace("Genome table load statistics:\n" . $stats->Show()) if T(3);  
     # Finish the feature load.  
     Trace("Loading Feature relation.") if T(2);  
     $stats = $loadFeature->FinishAndLoad();  
     Trace("Feature table load statistics:\n" . $stats->Show()) if T(3);  
190  }  }
191    
192  =head3 LoadAttribute  =head3 LoadAttributeKey
193    
194  C<< my $stats = $attrDB->LoadAttribute($entityName, $fieldName, $fh, $keyCol, $dataCol); >>  C<< my $stats = $attrDB->LoadAttributeKey($keyName, $fh, $keyCol, $dataCol, %options); >>
195    
196  Load the specified attribute from the specified file. The file should be a  Load the specified attribute from the specified file. The file should be a
197  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
198  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
199  in the input file must contain the appropriate key value and the other the  in the input file must contain the appropriate object id value and the other the
200  corresponding attribute value.  corresponding attribute value.
201    
202  =over 4  =over 4
203    
204  =item entityName  =item keyName
205    
206  Name of the entity containing the attribute.  Key of the attribute to load.
   
 =item fieldName  
   
 Name of the actual attribute.  
207    
208  =item fh  =item fh
209    
210  Open file handle for the input file.  Open file handle for the input file.
211    
212  =item keyCol  =item idCol
213    
214  Index (0-based) of the column containing the key field. The key field should  Index (0-based) of the column containing the ID field. The ID field should
215  contain the ID of an instance of the named entity.  contain the ID of an instance of the named entity.
216    
217  =item dataCol  =item dataCol
218    
219  Index (0-based) of the column containing the data value field.  Index (0-based) of the column containing the data value field.
220    
221    =item options
222    
223    Hash specifying the options for this load.
224    
225  =item RETURN  =item RETURN
226    
227  Returns a statistics object for the load process.  Returns a statistics object for the load process.
228    
229  =back  =back
230    
231    The available options are as follows.
232    
233    =over 4
234    
235    =item erase
236    
237    If TRUE, the key's values will all be erased before loading. (Doing so
238    makes for a faster load.)
239    
240    =back
241    
242  =cut  =cut
243    
244  sub LoadAttribute {  sub LoadAttributeKey {
245      # Get the parameters.      # Get the parameters.
246      my ($self, $entityName, $fieldName, $fh, $keyCol, $dataCol) = @_;      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;
247      # Create the return variable.      # Create the return variable.
248      my $retVal;      my $retVal = Stats->new("lineIn", "shortLine", "newObject");
249      # Insure the entity exists.      # Compute the minimum number of fields required in each input line.
250      my $found = grep { $_ eq $entityName } $self->GetEntityTypes();      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;
251      if (! $found) {      # Insure the attribute key exists.
252          Confess("Entity \"$entityName\" not found in database.");      my $found = $self->GetEntity('AttributeKey', $keyName);
253        if (! defined $found) {
254            Confess("Attribute key \"$keyName\" not found in database.");
255      } else {      } else {
256          # Get the field structure for the named entity.          # Erase the key's current values.
257          my $fieldHash = $self->GetFieldTable($entityName);          $self->EraseAttribute($keyName);
258          # Verify that the attribute exists.          # Save a list of the object IDs we need to add.
259          if (! exists $fieldHash->{$fieldName}) {          my %objectIDs = ();
             Confess("Attribute \"$fieldName\" does not exist in entity $entityName.");  
         } else {  
             # Create a loader for the specified attribute. We need the  
             # relation name first.  
             my $relName = $fieldHash->{$fieldName}->{relation};  
             my $loadAttribute = ERDBLoad->new($self, $relName, $FIG_Config::temp);  
260              # Loop through the input file.              # Loop through the input file.
261              while (! eof $fh) {              while (! eof $fh) {
262                  # Get the next line of the file.                  # Get the next line of the file.
263                  my @fields = Tracer::GetLine($fh);                  my @fields = Tracer::GetLine($fh);
264                  $loadAttribute->Add("lineIn");              $retVal->Add(lineIn => 1);
265                  # Now we need to validate the line.                  # Now we need to validate the line.
266                  if ($#fields < $dataCol) {              if (scalar(@fields) < $minCols) {
267                      $loadAttribute->Add("shortLine");                  $retVal->Add(shortLine => 1);
268                  } elsif (! $self->Exists($entityName, $fields[$keyCol])) {              } else {
269                      $loadAttribute->Add("badKey");                  # It's valid, so get the ID and value.
270                  } else {                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
271                      # It's valid,so send it to the loader.                  # Denote we're using this input line.
272                      $loadAttribute->Put($fields[$keyCol], $fields[$dataCol]);                  $retVal->Add(lineUsed => 1);
273                      $loadAttribute->Add("lineUsed");                  # Now the fun begins. Find out if we need to create a target object record for this object ID.
274                    if (! exists $objectIDs{$id}) {
275                        my $found = $self->Exists('TargetObject', $id);
276                        if (! $found) {
277                            $self->InsertObject('TargetObject', { id => $id });
278                        }
279                        $objectIDs{$id} = 1;
280                        $retVal->Add(newObject => 1);
281                  }                  }
282                    # Now we insert the attribute.
283                    $self->InsertObject('HasValueFor', { from => $keyName, to => $id, value => $value });
284                    $retVal->Add(newValue => 1);
285              }              }
             # Finish the load.  
             $retVal = $loadAttribute->FinishAndLoad();  
286          }          }
287      }      }
288      # Return the statistics.      # Return the statistics.
289      return $retVal;      return $retVal;
290  }  }
291    
 =head3 DeleteAttribute  
292    
293  C<< CustomAttributes::DeleteAttribute($entityName, $attributeName); >>  =head3 DeleteAttributeKey
294    
295    C<< my $stats = $attrDB->DeleteAttributeKey($attributeName); >>
296    
297  Delete an attribute from the custom attributes database.  Delete an attribute from the custom attributes database.
298    
299  =over 4  =over 4
300    
 =item entityName  
   
 Name of the entity possessing the attribute.  
   
301  =item attributeName  =item attributeName
302    
303  Name of the attribute to delete.  Name of the attribute to delete.
304    
305    =item RETURN
306    
307    Returns a statistics object describing the effects of the deletion.
308    
309  =back  =back
310    
311  =cut  =cut
312    
313  sub DeleteAttribute {  sub DeleteAttributeKey {
314      # Get the parameters.      # Get the parameters.
315      my ($entityName, $attributeName) = @_;      my ($self, $attributeName) = @_;
316      # Read in the XML for the database defintion. We need to verify that      # Delete the attribute key.
317      # the named entity exists and it has the named attribute.      my $retVal = $self->Delete('AttributeKey', $attributeName);
318      my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);      # Return the result.
319      my $entityHash = $metadata->{Entities};      return $retVal;
320      if (! exists $entityHash->{$entityName}) {  
         Confess("Entity \"$entityName\" not found.");  
     } else {  
         # Get the field hash.  
         my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);  
         if (! exists $fieldHash->{$attributeName}) {  
             Confess("Attribute \"$attributeName\" not found in entity $entityName.");  
         } else {  
             # Get the attribute's relation name.  
             my $relName = $fieldHash->{$attributeName}->{relation};  
             # Check for an index.  
             my $indexIdx = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);  
             if (defined($indexIdx)) {  
                 Trace("Index for $attributeName found at position $indexIdx for $entityName.") if T(3);  
                 delete $entityHash->{$entityName}->{Indexes}->[$indexIdx];  
             }  
             # Delete the attribute from the field hash.  
             Trace("Deleting attribute $attributeName from $entityName.") if T(3);  
             delete $fieldHash->{$attributeName};  
             # Write the XML back out.  
             ERDB::WriteMetaXML($metadata, $FIG_Config::attrDBD);  
             # Insure the relation does not exist in the database. This requires connecting  
             # since we may have to do a table drop.  
             my $attrDB = CustomAttributes->new();  
             Trace("Dropping table $relName.") if T(3);  
             $attrDB->DropRelation($relName);  
         }  
321      }      }
322    
323    =head3 NewName
324    
325    C<< my $text = CustomAttributes::NewName(); >>
326    
327    Return the string used to indicate the user wants to add a new attribute.
328    
329    =cut
330    
331    sub NewName {
332        return "(new)";
333  }  }
334    
335  =head3 ControlForm  =head3 ControlForm
336    
337  C<< my $formHtml = $attrDB->ControlForm($cgi, $name); >>  C<< my $formHtml = $attrDB->ControlForm($cgi, $name, \%keys); >>
338    
339  Return a form that can be used to control the creation and modification of  Return a form that can be used to control the creation and modification of
340  attributes.  attributes. Only a subset of the attribute keys will be displayed, as
341    determined by the incoming list.
342    
343  =over 4  =over 4
344    
# Line 444  Line 350 
350    
351  Name to give to the form. This should be unique for the web page.  Name to give to the form. This should be unique for the web page.
352    
353    =item keys
354    
355    Reference to a hash mapping attribute keys to n-tuples. Each tuple will contain the
356    attribute's data type, its description, and a list of the groups in which it participates.
357    
358  =item RETURN  =item RETURN
359    
360  Returns the HTML for a form that submits instructions to the C<Attributes.cgi> script  Returns the HTML for a form that can be used to  submit instructions to the C<Attributes.cgi> script
361  for loading, creating, or deleting an attribute.  for loading, creating, displaying, changing, or deleting an attribute. Note that only the form
362    controls are generated. The form tags are left to the caller.
363    
364  =back  =back
365    
# Line 455  Line 367 
367    
368  sub ControlForm {  sub ControlForm {
369      # Get the parameters.      # Get the parameters.
370      my ($self, $cgi, $name) = @_;      my ($self, $cgi, $name, $keys) = @_;
371      # Declare the return list.      # Declare the return list.
372      my @retVal = ();      my @retVal = ();
     # Start the form. We use multipart to support the upload control.  
     push @retVal, $cgi->start_multipart_form(-name => $name);  
373      # We'll put the controls in a table. Nothing else ever seems to look nice.      # We'll put the controls in a table. Nothing else ever seems to look nice.
374      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });
375      # The first row is for selecting the field name.      # The first row is for selecting the field name.
376      push @retVal, $cgi->Tr($cgi->th("Select a Field"),      push @retVal, $cgi->Tr($cgi->th("Select a Field"),
377                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', 1,                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', $keys,
378                                                       "document.$name.notes.value",                                                       new => 1,
379                                                       "document.$name.dataType.value")));                                                       notes => "document.$name.notes.value",
380                                                         type => "document.$name.dataType.value",
381                                                         groups => "document.$name.groups")));
382      # Now we set up a dropdown for the data types. The values will be the      # Now we set up a dropdown for the data types. The values will be the
383      # data type names, and the labels will be the descriptions.      # data type names, and the labels will be the descriptions.
384      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
385      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;
386      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',
387                                      -values => [sort keys %types],                                      -values => [sort keys %types],
388                                      -labels => \%labelMap);                                      -labels => \%labelMap,
389                                        -default => 'string');
390        # Allow the user to specify a new field name. This is required if the
391        # user has selected the "(new)" marker. We put a little scriptlet in here that
392        # selects the (new) marker when the user enters the field.
393        push @retVal, "<script language=\"javaScript\">";
394        my $fieldField = "document.$name.fieldName";
395        my $newName = "\"" . NewName() . "\"";
396        push @retVal, $cgi->Tr($cgi->th("New Field Name"),
397                               $cgi->td($cgi->textfield(-name => 'newName',
398                                                        -size => 30,
399                                                        -value => "",
400                                                        -onFocus => "setIfEmpty($fieldField, $newName);")),
401                                        );
402      push @retVal, $cgi->Tr($cgi->th("Data type"),      push @retVal, $cgi->Tr($cgi->th("Data type"),
403                             $cgi->td($typeMenu));                             $cgi->td($typeMenu));
404      # The next row is for the notes.      # The next row is for the notes.
# Line 482  Line 407 
407                                                     -rows => 6,                                                     -rows => 6,
408                                                     -columns => 80))                                                     -columns => 80))
409                            );                            );
410      # Allow the user to specify a new field name. This is required if the      # Now we have the groups, which are implemented as a checkbox group.
411      # user has selected one of the "(new)" markers.      my @groups = $self->GetGroups();
412      push @retVal, $cgi->Tr($cgi->th("New Field Name"),      push @retVal, $cgi->Tr($cgi->th("Groups"),
413                             $cgi->td($cgi->textfield(-name => 'newName',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
414                                                      -size => 30)),                                      -values=> \@groups))
415                                      );                                      );
416      # If the user wants to upload new values for the field, then we have      # If the user wants to upload new values for the field, then we have
417      # an upload file name and column indicators.      # an upload file name and column indicators.
# Line 503  Line 428 
428                                                      -default => 1)                                                      -default => 1)
429                                     ),                                     ),
430                            );                            );
431      # Now the two buttons: UPDATE and DELETE.      # Now the three buttons: STORE, SHOW, and DELETE.
432      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
433                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'},
434                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .
435                                      $cgi->submit(-name => 'Store',  -value => 'STORE')                                      $cgi->submit(-name => 'Store',  -value => 'STORE') . " " .
436                                        $cgi->submit(-name => 'Show',   -value => 'SHOW')
437                                     )                                     )
438                            );                            );
439      # Close the table and the form.      # Close the table and the form.
440      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
     push @retVal, $cgi->end_form();  
441      # Return the assembled HTML.      # Return the assembled HTML.
442      return join("\n", @retVal, "");      return join("\n", @retVal, "");
443  }  }
444    
445    =head3 LoadAttributesFrom
446    
447    C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
448    
449    Load attributes from the specified tab-delimited file. Each line of the file must
450    contain an object ID in the first column, an attribute key name in the second
451    column, and attribute values in the remaining columns. The attribute values will
452    be assembled into a single value using the splitter code.
453    
454    =over 4
455    
456    =item fileName
457    
458    Name of the file from which to load the attributes.
459    
460    =item options
461    
462    Hash of options for modifying the load process.
463    
464    =item RETURN
465    
466    Returns a statistics object describing the load.
467    
468    =back
469    
470    Permissible option values are as follows.
471    
472    =over 4
473    
474    =item append
475    
476    If TRUE, then the attributes will be appended to existing data; otherwise, the
477    first time a key name is encountered, it will be erased.
478    
479    =back
480    
481    =cut
482    
483    sub LoadAttributesFrom {
484        # Get the parameters.
485        my ($self, $fileName, %options) = @_;
486        # Declare the return variable.
487        my $retVal = Stats->new('keys', 'values');
488        # Check for append mode.
489        my $append = ($options{append} ? 1 : 0);
490        # Create a hash of key names found.
491        my %keyHash = ();
492        # Open the file for input.
493        my $fh = Open(undef, "<$fileName");
494        # Loop through the file.
495        while (! eof $fh) {
496            my ($id, $key, @values) = Tracer::GetLine($fh);
497            $retVal->Add(linesIn => 1);
498            # Do some validation.
499            if (! defined($id)) {
500                # We ignore blank lines.
501                $retVal->Add(blankLines => 1);
502            } elsif (! defined($key)) {
503                # An ID without a key is a serious error.
504                my $lines = $retVal->Ask('linesIn');
505                Confess("Line $lines in $fileName has no attribute key.");
506            } else {
507                # Now we need to check for a new key.
508                if (! exists $keyHash{$key}) {
509                    # This is a new key. Verify that it exists.
510                    if (! $self->Exists('AttributeKey', $key)) {
511                        my $line = $retVal->Ask('linesIn');
512                        Confess("Attribute \"$key\" on line $line of $fileName not found in database.");
513                    } else {
514                        # Make sure we know this is no longer a new key.
515                        $keyHash{$key} = 1;
516                        $retVal->Add(keys => 1);
517                        # If this is NOT append mode, erase the key.
518                        if (! $append) {
519                            $self->EraseAttribute($key);
520                        }
521                    }
522                    Trace("Key $key found.") if T(3);
523                }
524                # Now we know the key is valid. Add this value.
525                $self->AddAttribute($id, $key, @values);
526                my $progress = $retVal->Add(values => 1);
527                Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
528    
529            }
530        }
531        # Return the result.
532        return $retVal;
533    }
534    
535    =head3 BackupAllAttributes
536    
537    C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
538    
539    Backup all of the attributes to a file. The attributes will be stored in a
540    tab-delimited file suitable for reloading via L</LoadAttributesFrom>.
541    
542    =over 4
543    
544    =item fileName
545    
546    Name of the file to which the attribute data should be backed up.
547    
548    =item options
549    
550    Hash of options for the backup.
551    
552    =item RETURN
553    
554    Returns a statistics object describing the backup.
555    
556    =back
557    
558    Currently there are no options defined.
559    
560    =cut
561    
562    sub BackupAllAttributes {
563        # Get the parameters.
564        my ($self, $fileName, %options) = @_;
565        # Declare the return variable.
566        my $retVal = Stats->new();
567        # Get a list of the keys.
568        my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
569        Trace(scalar(@keys) . " keys found during backup.") if T(2);
570        # Open the file for output.
571        my $fh = Open(undef, ">$fileName");
572        # Loop through the keys.
573        for my $key (@keys) {
574            Trace("Backing up attribute $key.") if T(3);
575            $retVal->Add(keys => 1);
576            # Loop through this key's values.
577            my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
578            my $valuesFound = 0;
579            while (my $line = $query->Fetch()) {
580                $valuesFound++;
581                # Get this row's data.
582                my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',
583                                         'HasValueFor(value)']);
584                # Write it to the file.
585                Tracer::PutLine($fh, \@row);
586            }
587            Trace("$valuesFound values backed up for key $key.") if T(3);
588            $retVal->Add(values => $valuesFound);
589        }
590        # Return the result.
591        return $retVal;
592    }
593    
594  =head3 FieldMenu  =head3 FieldMenu
595    
596  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $newFlag, $noteControl, $typeControl); >>  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>
597    
598  Return the HTML for a menu to select an attribute field. The menu will  Return the HTML for a menu to select an attribute field. The menu will
599  be a standard SELECT/OPTION thing which is called "popup menu" in the  be a standard SELECT/OPTION thing which is called "popup menu" in the
600  CGI package, but actually looks like a list. The list will contain  CGI package, but actually looks like a list. The list will contain
601  one selectable row per field, grouped by entity.  one selectable row per field.
602    
603  =over 4  =over 4
604    
# Line 541  Line 615 
615  Name to give to the menu. This is the name under which the value will  Name to give to the menu. This is the name under which the value will
616  appear when the form is submitted.  appear when the form is submitted.
617    
618  =item newFlag (optional)  =item keys
619    
620    Reference to a hash mapping each attribute key name to a list reference,
621    the list itself consisting of the attribute data type, its description,
622    and a list of its groups.
623    
624    =item options
625    
626    Hash containing options that modify the generation of the menu.
627    
628    =item RETURN
629    
630    Returns the HTML to create a form field that can be used to select an
631    attribute from the custom attributes system.
632    
633    =back
634    
635    The permissible options are as follows.
636    
637    =over 4
638    
639    =item new
640    
641  If TRUE, then extra rows will be provided to allow the user to select  If TRUE, then extra rows will be provided to allow the user to select
642  a new attribute. In other words, the user can select an existing  a new attribute. In other words, the user can select an existing
643  attribute, or can choose a C<(new)> marker to indicate a field to  attribute, or can choose a C<(new)> marker to indicate a field to
644  be created in the parent entity.  be created in the parent entity.
645    
646  =item noteControl (optional)  =item notes
647    
648  If specified, the name of a variable for displaying the notes attached  If specified, the name of a variable for displaying the notes attached
649  to the field. This must be in Javascript form ready for assignment.  to the field. This must be in Javascript form ready for assignment.
# Line 559  Line 654 
654  it is copied in. Specifying this parameter generates Javascript for  it is copied in. Specifying this parameter generates Javascript for
655  displaying the field description when a field is selected.  displaying the field description when a field is selected.
656    
657  =item typeControl (optional)  =item type
658    
659  If specified, the name of a variable for displaying the field's  If specified, the name of a variable for displaying the field's
660  data type. Data types are a much more controlled vocabulary than  data type. Data types are a much more controlled vocabulary than
# Line 567  Line 662 
662  raw value is put into the specified variable. Otherwise, the same  raw value is put into the specified variable. Otherwise, the same
663  rules apply to this value that apply to I<$noteControl>.  rules apply to this value that apply to I<$noteControl>.
664    
665  =item RETURN  =item groups
666    
667  Returns the HTML to create a form field that can be used to select an  If specified, the name of a multiple-selection list control (also called
668  attribute from the custom attributes system.  a popup menu) which shall be used to display the selected groups.
669    
670  =back  =back
671    
# Line 578  Line 673 
673    
674  sub FieldMenu {  sub FieldMenu {
675      # Get the parameters.      # Get the parameters.
676      my ($self, $cgi, $height, $name, $newFlag, $noteControl, $typeControl) = @_;      my ($self, $cgi, $height, $name, $keys, %options) = @_;
677      # These next two hashes make everything happen. "entities"      # Reformat the list of keys.
678      # maps each entity name to the list of values to be put into its      my %keys = %{$keys};
679      # option group. "labels" maps each entity name to a map from values      # Add the (new) key, if needed.
680      # to labels.      if ($options{new}) {
681      my @entityNames = sort ($self->GetEntityTypes());          $keys{NewName()} = ["string", ""];
682      my %entities = map { $_ => [] } @entityNames;      }
683      my %labels = map { $_ => { }} @entityNames;      # Get a sorted list of key.
684      # Loop through the entities, adding the existing attributes.      my @keys = sort keys %keys;
685      for my $entity (@entityNames) {      # We need to create the name for the onChange function. This function
         # Get this entity's field table.  
         my $fieldHash = $self->GetFieldTable($entity);  
         # Get its field list in our local hashes.  
         my $fieldList = $entities{$entity};  
         my $labelList = $labels{$entity};  
         # Add the NEW fields if we want them.  
         if ($newFlag) {  
             push @{$fieldList}, $entity;  
             $labelList->{$entity} = "(new)";  
         }  
         # Loop through the fields in the hash. We only keep the ones with a  
         # secondary relation name. (In other words, the name of the relation  
         # in which the field appears cannot be the same as the entity name.)  
         for my $fieldName (sort keys %{$fieldHash}) {  
             if ($fieldHash->{$fieldName}->{relation} ne $entity) {  
                 my $value = "$entity/$fieldName";  
                 push @{$fieldList}, $value;  
                 $labelList->{$value} = $fieldName;  
             }  
         }  
     }  
     # Now we have a hash and a list for each entity, and they correspond  
     # exactly to what the $cgi->optgroup function expects.  
     # The last step is to create the name for the onChange function. This function  
686      # may not do anything, but we need to know the name to generate the HTML      # may not do anything, but we need to know the name to generate the HTML
687      # for the menu.      # for the menu.
688      my $changeName = "${name}_setNotes";      my $changeName = "${name}_setNotes";
689      my $retVal = $cgi->popup_menu({name => $name,      my $retVal = $cgi->popup_menu({name => $name,
690                                     size => $height,                                     size => $height,
691                                     onChange => "$changeName(this.value)",                                     onChange => "$changeName(this.value)",
692                                     values => [map { $cgi->optgroup(-name => $_,                                     values => \@keys,
693                                                                     -values => $entities{$_},                                    });
                                                                    -labels => $labels{$_})  
                                                   } @entityNames]}  
                                  );  
694      # Create the change function.      # Create the change function.
695      $retVal .= "\n<script language=\"javascript\">\n";      $retVal .= "\n<script language=\"javascript\">\n";
696      $retVal .= "    function $changeName(fieldValue) {\n";      $retVal .= "    function $changeName(fieldValue) {\n";
697      # The function only has a body if we have a notes control to store the description.      # The function only has a body if we have a control to store data about the
698      if ($noteControl || $typeControl) {      # attribute.
699        if ($options{notes} || $options{type} || $options{groups}) {
700          # Check to see if we're storing HTML or text into the note control.          # Check to see if we're storing HTML or text into the note control.
701            my $noteControl = $options{notes};
702          my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);          my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);
703          # We use a CASE statement based on the newly-selected field value. The          # We use a CASE statement based on the newly-selected field value. The
704          # field description will be stored in the JavaScript variable "myText"          # field description will be stored in the JavaScript variable "myText"
# Line 637  Line 707 
707          $retVal .= "        var myText = \"\";\n";          $retVal .= "        var myText = \"\";\n";
708          $retVal .= "        var myType = \"string\";\n";          $retVal .= "        var myType = \"string\";\n";
709          $retVal .= "        switch (fieldValue) {\n";          $retVal .= "        switch (fieldValue) {\n";
710          # Loop through the entities.          # Loop through the keys.
711          for my $entity (@entityNames) {          for my $key (@keys) {
             # Get the entity's field hash. This has the notes in it.  
             my $fieldHash = $self->GetFieldTable($entity);  
             # Loop through the values we might see for this entity's fields.  
             my $fields = $entities{$entity};  
             for my $value (@{$fields}) {  
                 # Only proceed if we have an existing field.  
                 if ($value =~ m!/(.+)$!) {  
                     # Get the field's hash element.  
                     my $element = $fieldHash->{$1};  
712                      # Generate this case.                      # Generate this case.
713                      $retVal .= "        case \"$value\" :\n";              $retVal .= "        case \"$key\" :\n";
714                      # Here we either want to update the note display, the                      # Here we either want to update the note display, the
715                      # type display, or both.              # type display, the group list, or a combination of them.
716                my ($type, $notes, @groups) = @{$keys{$key}};
717                      if ($noteControl) {                      if ($noteControl) {
                         # Here we want the notes updated.  
                         my $notes = $element->{Notes}->{content};  
718                          # Insure it's in the proper form.                          # Insure it's in the proper form.
719                          if ($htmlMode) {                          if ($htmlMode) {
720                              $notes = ERDB::HTMLNote($notes);                              $notes = ERDB::HTMLNote($notes);
# Line 664  Line 724 
724                          $notes =~ s/"/\\"/g;                          $notes =~ s/"/\\"/g;
725                          $retVal .= "           myText = \"$notes\";\n";                          $retVal .= "           myText = \"$notes\";\n";
726                      }                      }
727                      if ($typeControl) {              if ($options{type}) {
728                          # Here we want the type updated.                          # Here we want the type updated.
                         my $type = $element->{type};  
729                          $retVal .= "           myType = \"$type\";\n";                          $retVal .= "           myType = \"$type\";\n";
730                      }                      }
731                if ($options{groups}) {
732                    # Here we want the groups shown. Get a list of this attribute's groups.
733                    # We'll search through this list for each group to see if it belongs with
734                    # our attribute.
735                    my $groupLiteral = "=" . join("=", @groups) . "=";
736                    # Now we need some variables containing useful code for the javascript. It's
737                    # worth knowing we go through a bit of pain to insure $groupField[i] isn't
738                    # parsed as an array element.
739                    my $groupField = $options{groups};
740                    my $currentField = $groupField . "[i]";
741                    # Do the javascript.
742                    $retVal .= "           var groupList = \"$groupLiteral\";\n";
743                    $retVal .= "           for (var i = 0; i < $groupField.length; i++) {\n";
744                    $retVal .= "              var srchString = \"=\" + $currentField.value + \"=\";\n";
745                    $retVal .= "              var srchLoc = groupList.indexOf(srchString);\n";
746                    $retVal .= "              $currentField.checked = (srchLoc >= 0);\n";
747                    $retVal .= "           }\n";
748                }
749                      # Close this case.                      # Close this case.
750                      $retVal .= "           break;\n";                      $retVal .= "           break;\n";
751                  }                  }
             }  
         }  
752          # Close the CASE statement and make the appropriate assignments.          # Close the CASE statement and make the appropriate assignments.
753          $retVal .= "        }\n";          $retVal .= "        }\n";
754          if ($noteControl) {          if ($noteControl) {
755              $retVal .= "        $noteControl = myText;\n";              $retVal .= "        $noteControl = myText;\n";
756          }          }
757          if ($typeControl) {          if ($options{type}) {
758              $retVal .= "        $typeControl = myType;\n";              $retVal .= "        $options{type} = myType;\n";
759          }          }
760      }      }
761      # Terminate the change function.      # Terminate the change function.
# Line 690  Line 765 
765      return $retVal;      return $retVal;
766  }  }
767    
768    =head3 GetGroups
769    
770    C<< my @groups = $attrDB->GetGroups(); >>
771    
772    Return a list of the available groups.
773    
774    =cut
775    
776    sub GetGroups {
777        # Get the parameters.
778        my ($self) = @_;
779        # Get the groups.
780        my @retVal = $self->GetFlat(['AttributeGroup'], "", [], 'AttributeGroup(id)');
781        # Return them.
782        return @retVal;
783    }
784    
785    =head3 GetAttributeData
786    
787    C<< my %keys = $attrDB->GetAttributeData($type, @list); >>
788    
789    Return attribute data for the selected attributes. The attribute
790    data is a hash mapping each attribute key name to a n-tuple containing the
791    data type, the description, and the groups. This is the same format expected in
792    the L</FieldMenu> and L</ControlForm> methods for the list of attributes to display.
793    
794    =over 4
795    
796    =item type
797    
798    Type of attribute criterion: C<name> for attributes whose names begin with the
799    specified string, or C<group> for attributes in the specified group.
800    
801    =item list
802    
803    List containing the names of the groups or keys for the desired attributes.
804    
805    =item RETURN
806    
807    Returns a hash mapping each attribute key name to its data type, description, and
808    parent groups.
809    
810    =back
811    
812    =cut
813    
814    sub GetAttributeData {
815        # Get the parameters.
816        my ($self, $type, @list) = @_;
817        # Set up a hash to store the attribute data.
818        my %retVal = ();
819        # Loop through the list items.
820        for my $item (@list) {
821            # Set up a query for the desired attributes.
822            my $query;
823            if ($type eq 'name') {
824                # Here we're doing a generic name search. We need to escape it and then tack
825                # on a %.
826                my $parm = $item;
827                $parm =~ s/_/\\_/g;
828                $parm =~ s/%/\\%/g;
829                $parm .= "%";
830                # Ask for matching attributes. (Note that if the user passed in a null string
831                # he'll get everything.)
832                $query = $self->Get(['AttributeKey'], "AttributeKey(id) LIKE ?", [$parm]);
833            } elsif ($type eq 'group') {
834                $query = $self->Get(['IsInGroup', 'AttributeKey'], "IsInGroup(to-link) = ?", [$item]);
835            } else {
836                Confess("Unknown attribute query type \"$type\".");
837            }
838            while (my $row = $query->Fetch()) {
839                # Get this attribute's data.
840                my ($key, $type, $notes) = $row->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
841                                                         'AttributeKey(description)']);
842                # If it's new, get its groups and add it to the return hash.
843                if (! exists $retVal{$key}) {
844                    my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",
845                                                [$key], 'IsInGroup(to-link)');
846                    $retVal{$key} = [$type, $notes, @groups];
847                }
848            }
849        }
850        # Return the result.
851        return %retVal;
852    }
853    
854    =head2 FIG Method Replacements
855    
856    The following methods are used by B<FIG.pm> to replace the previous attribute functionality.
857    Some of the old functionality is no longer present: controlled vocabulary is no longer
858    supported and there is no longer any searching by URL. Fortunately, neither of these
859    capabilities were used in the old system.
860    
861    The methods here are the only ones supported by the B<RemoteCustomAttributes> object.
862    The idea is that these methods represent attribute manipulation allowed by all users, while
863    the others are only for privileged users with access to the attribute server.
864    
865    In the previous implementation, an attribute had a value and a URL. In the new implementation,
866    there is only a value. In this implementation, each attribute has only a value. These
867    methods will treat the value as a list with the individual elements separated by the
868    value of the splitter parameter on the constructor (L</new>). The default is double
869    colons C<::>.
870    
871    So, for example, an old-style keyword with a value of C<essential> and a URL of
872    C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default
873    splitter value would be stored as
874    
875        essential::http://www.sciencemag.org/cgi/content/abstract/293/5538/2266
876    
877    The best performance is achieved by searching for a particular key for a specified
878    feature or genome.
879    
880    =head3 GetAttributes
881    
882    C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @values); >>
883    
884    In the database, attribute values are sectioned into pieces using a splitter
885    value specified in the constructor (L</new>). This is not a requirement of
886    the attribute system as a whole, merely a convenience for the purpose of
887    these methods. If a value has multiple sections, each section
888    is matched against the corresponding criterion in the I<@valuePatterns> list.
889    
890    This method returns a series of tuples that match the specified criteria. Each tuple
891    will contain an object ID, a key, and one or more values. The parameters to this
892    method therefore correspond structurally to the values expected in each tuple. In
893    addition, you can ask for a generic search by suffixing a percent sign (C<%>) to any
894    of the parameters. So, for example,
895    
896        my @attributeList = $attrDB->GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);
897    
898    would return something like
899    
900        ['fig}100226.1.peg.1004', 'structure', 1, 2]
901        ['fig}100226.1.peg.1004', 'structure1', 1, 2]
902        ['fig}100226.1.peg.1004', 'structure2', 1, 2]
903        ['fig}100226.1.peg.1004', 'structureA', 1, 2]
904    
905    Use of C<undef> in any position acts as a wild card (all values). You can also specify
906    a list reference in the ID column. Thus,
907    
908        my @attributeList = $attrDB->GetAttributes(['100226.1', 'fig|100226.1.%'], 'PUBMED');
909    
910    would get the PUBMED attribute data for Streptomyces coelicolor A3(2) and all its
911    features.
912    
913    In addition to values in multiple sections, a single attribute key can have multiple
914    values, so even
915    
916        my @attributeList = $attrDB->GetAttributes($peg, 'virulent');
917    
918    which has no wildcard in the key or the object ID, may return multiple tuples.
919    
920    Value matching in this system works very poorly, because of the way multiple values are
921    stored. For the object ID and key name, we create queries that filter for the desired
922    results. For the values, we do a comparison after the attributes are retrieved from the
923    database. As a result, queries in which filter only on value end up reading the entire
924    attribute table to find the desired results.
925    
926    =over 4
927    
928    =item objectID
929    
930    ID of object whose attributes are desired. If the attributes are desired for multiple
931    objects, this parameter can be specified as a list reference. If the attributes are
932    desired for all objects, specify C<undef> or an empty string. Finally, you can specify
933    attributes for a range of object IDs by putting a percent sign (C<%>) at the end.
934    
935    =item key
936    
937    Attribute key name. A value of C<undef> or an empty string will match all
938    attribute keys. If the values are desired for multiple keys, this parameter can be
939    specified as a list reference. Finally, you can specify attributes for a range of
940    keys by putting a percent sign (C<%>) at the end.
941    
942    =item values
943    
944    List of the desired attribute values, section by section. If C<undef>
945    or an empty string is specified, all values in that section will match. A
946    generic match can be requested by placing a percent sign (C<%>) at the end.
947    In that case, all values that match up to and not including the percent sign
948    will match.
949    
950    =item RETURN
951    
952    Returns a list of tuples. The first element in the tuple is an object ID, the
953    second is an attribute key, and the remaining elements are the sections of
954    the attribute value. All of the tuples will match the criteria set forth in
955    the parameter list.
956    
957    =back
958    
959    =cut
960    
961    sub GetAttributes {
962        # Get the parameters.
963        my ($self, $objectID, $key, @values) = @_;
964        # We will create one big honking query. The following hash will build the filter
965        # clause and a parameter list.
966        my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);
967        my @filter = ();
968        my @parms = ();
969        # This next loop goes through the different fields that can be specified in the
970        # parameter list and generates filters for each.
971        for my $field (keys %data) {
972            # Accumulate filter information for this field. We will OR together all the
973            # elements accumulated to create the final result.
974            my @fieldFilter = ();
975            # Get the specified data from the caller.
976            my $fieldPattern = $data{$field};
977            # Only proceed if the pattern is one that won't match everything.
978            if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {
979                # Convert the pattern to an array.
980                my @patterns = ();
981                if (ref $fieldPattern eq 'ARRAY') {
982                    push @patterns, @{$fieldPattern};
983                } else {
984                    push @patterns, $fieldPattern;
985                }
986                # Only proceed if the array is nonempty. The loop will work fine if the
987                # array is empty, but when we build the filter string at the end we'll
988                # get "()" in the filter list, which will result in an SQL syntax error.
989                if (@patterns) {
990                    # Loop through the individual patterns.
991                    for my $pattern (@patterns) {
992                        # Check for a generic request.
993                        if (substr($pattern, -1, 1) ne '%') {
994                            # Here we have a normal request.
995                            push @fieldFilter, "$field = ?";
996                            push @parms, $pattern;
997                        } else {
998                            # Here we have a generate request, so we will use the LIKE operator to
999                            # filter the field to this value pattern.
1000                            push @fieldFilter, "$field LIKE ?";
1001                            # We must convert the pattern value to an SQL match pattern. First
1002                            # we get a copy of it.
1003                            my $actualPattern = $pattern;
1004                            # Now we escape the underscores. Underscores are an SQL wild card
1005                            # character, but they are used frequently in key names and object IDs.
1006                            $actualPattern =~ s/_/\\_/g;
1007                            # Add the escaped pattern to the bound parameter list.
1008                            push @parms, $actualPattern;
1009                        }
1010                    }
1011                    # Form the filter for this field.
1012                    my $fieldFilterString = join(" OR ", @fieldFilter);
1013                    push @filter, "($fieldFilterString)";
1014                }
1015            }
1016        }
1017        # Now @filter contains one or more filter strings and @parms contains the parameter
1018        # values to bind to them.
1019        my $actualFilter = join(" AND ", @filter);
1020        # Declare the return variable.
1021        my @retVal = ();
1022        # Get the number of value sections we have to match.
1023        my $sectionCount = scalar(@values);
1024        # Now we're ready to make our query.
1025        my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1026        # Loop through the assignments found.
1027        while (my $row = $query->Fetch()) {
1028            # Get the current row's data.
1029            my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1030                                                          'HasValueFor(value)']);
1031            # Break the value into sections.
1032            my @sections = split($self->{splitter}, $valueString);
1033            # Match each section against the incoming values. We'll assume we're
1034            # okay unless we learn otherwise.
1035            my $matching = 1;
1036            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1037                # We need to check to see if this section is generic.
1038                if (substr($values[$i], -1, 1) eq '%') {
1039                    my $matchLen = length($values[$i] - 1);
1040                    $matching = substr($sections[$i], 0, $matchLen) eq
1041                                substr($values[$i], 0, $matchLen);
1042                } else {
1043                    $matching = ($sections[$i] eq $values[$i]);
1044                }
1045            }
1046            # If we match, output this row to the return list.
1047            if ($matching) {
1048                push @retVal, [$id, $key, @sections];
1049            }
1050        }
1051        # Return the rows found.
1052        return @retVal;
1053    }
1054    
1055    =head3 AddAttribute
1056    
1057    C<< $attrDB->AddAttribute($objectID, $key, @values); >>
1058    
1059    Add an attribute key/value pair to an object. This method cannot add a new key, merely
1060    add a value to an existing key. Use L</StoreAttributeKey> to create a new key.
1061    
1062    =over 4
1063    
1064    =item objectID
1065    
1066    ID of the object to which the attribute is to be added.
1067    
1068    =item key
1069    
1070    Attribute key name.
1071    
1072    =item values
1073    
1074    One or more values to be associated with the key. The values are joined together with
1075    the splitter value before being stored as field values. This enables L</GetAttributes>
1076    to split them apart during retrieval. The splitter value defaults to double colons C<::>.
1077    
1078    =back
1079    
1080    =cut
1081    
1082    sub AddAttribute {
1083        # Get the parameters.
1084        my ($self, $objectID, $key, @values) = @_;
1085        # Don't allow undefs.
1086        if (! defined($objectID)) {
1087            Confess("No object ID specified for AddAttribute call.");
1088        } elsif (! defined($key)) {
1089            Confess("No attribute key specified for AddAttribute call.");
1090        } elsif (! @values) {
1091            Confess("No values specified in AddAttribute call for key $key.");
1092        } else {
1093            # Okay, now we have some reason to believe we can do this. Form the values
1094            # into a scalar.
1095            my $valueString = join($self->{splitter}, @values);
1096            # Connect the object to the key.
1097            $self->InsertObject('HasValueFor', { 'from-link' => $key,
1098                                                 'to-link'   => $objectID,
1099                                                 'value'     => $valueString,
1100                                           });
1101        }
1102        # Return a one, indicating success. We do this for backward compatability.
1103        return 1;
1104    }
1105    
1106    =head3 DeleteAttribute
1107    
1108    C<< $attrDB->DeleteAttribute($objectID, $key, @values); >>
1109    
1110    Delete the specified attribute key/value combination from the database.
1111    
1112    =over 4
1113    
1114    =item objectID
1115    
1116    ID of the object whose attribute is to be deleted.
1117    
1118    =item key
1119    
1120    Attribute key name.
1121    
1122    =item values
1123    
1124    One or more values associated with the key. If no values are specified, then all values
1125    will be deleted. Otherwise, only a matching value will be deleted.
1126    
1127    =back
1128    
1129    =cut
1130    
1131    sub DeleteAttribute {
1132        # Get the parameters.
1133        my ($self, $objectID, $key, @values) = @_;
1134        # Don't allow undefs.
1135        if (! defined($objectID)) {
1136            Confess("No object ID specified for DeleteAttribute call.");
1137        } elsif (! defined($key)) {
1138            Confess("No attribute key specified for DeleteAttribute call.");
1139        } elsif (scalar(@values) == 0) {
1140            # Here we erase the entire key.
1141            $self->EraseAttribute($key);
1142        } else {
1143            # Here we erase the matching values.
1144            my $valueString = join($self->{splitter}, @values);
1145            $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });
1146        }
1147        # Return a one. This is for backward compatability.
1148        return 1;
1149    }
1150    
1151    =head3 ChangeAttribute
1152    
1153    C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
1154    
1155    Change the value of an attribute key/value pair for an object.
1156    
1157    =over 4
1158    
1159    =item objectID
1160    
1161    ID of the genome or feature to which the attribute is to be changed. In general, an ID that
1162    starts with C<fig|> is treated as a feature ID, and an ID that is all digits and periods
1163    is treated as a genome ID. For IDs of other types, this parameter should be a reference
1164    to a 2-tuple consisting of the entity type name followed by the object ID.
1165    
1166    =item key
1167    
1168    Attribute key name. This corresponds to the name of a field in the database.
1169    
1170    =item oldValues
1171    
1172    One or more values identifying the key/value pair to change.
1173    
1174    =item newValues
1175    
1176    One or more values to be put in place of the old values.
1177    
1178    =back
1179    
1180    =cut
1181    
1182    sub ChangeAttribute {
1183        # Get the parameters.
1184        my ($self, $objectID, $key, $oldValues, $newValues) = @_;
1185        # Don't allow undefs.
1186        if (! defined($objectID)) {
1187            Confess("No object ID specified for ChangeAttribute call.");
1188        } elsif (! defined($key)) {
1189            Confess("No attribute key specified for ChangeAttribute call.");
1190        } elsif (! defined($oldValues) || ref $oldValues ne 'ARRAY') {
1191            Confess("No old values specified in ChangeAttribute call for key $key.");
1192        } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {
1193            Confess("No new values specified in ChangeAttribute call for key $key.");
1194        } else {
1195            # We do the change as a delete/add.
1196            $self->DeleteAttribute($objectID, $key, @{$oldValues});
1197            $self->AddAttribute($objectID, $key, @{$newValues});
1198        }
1199        # Return a one. We do this for backward compatability.
1200        return 1;
1201    }
1202    
1203    =head3 EraseAttribute
1204    
1205    C<< $attrDB->EraseAttribute($key); >>
1206    
1207    Erase all values for the specified attribute key. This does not remove the
1208    key from the database; it merely removes all the values.
1209    
1210    =over 4
1211    
1212    =item key
1213    
1214    Key to erase.
1215    
1216    =back
1217    
1218    =cut
1219    
1220    sub EraseAttribute {
1221        # Get the parameters.
1222        my ($self, $key) = @_;
1223        # Delete everything connected to the key. The "keepRoot" option keeps the key in the
1224        # datanase while deleting everything attached to it.
1225        $self->Delete('AttributeKey', $key, keepRoot => 1);
1226        # Return a 1, for backward compatability.
1227        return 1;
1228    }
1229    
1230    =head3 GetAttributeKeys
1231    
1232    C<< my @keyList = $attrDB->GetAttributeKeys($groupName); >>
1233    
1234    Return a list of the attribute keys for a particular group.
1235    
1236    =over 4
1237    
1238    =item groupName
1239    
1240    Name of the group whose keys are desired.
1241    
1242    =item RETURN
1243    
1244    Returns a list of the attribute keys for the specified group.
1245    
1246    =back
1247    
1248    =cut
1249    
1250    sub GetAttributeKeys {
1251        # Get the parameters.
1252        my ($self, $groupName) = @_;
1253        # Get the attributes for the specified group.
1254        my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(to-link) = ?", [$groupName],
1255                                    'IsInGroup(from-link)');
1256        # Return the keys.
1257        return sort @groups;
1258    }
1259    
1260  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3