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