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

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.18

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3