[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.3, Thu Nov 9 21:19:53 2006 UTC revision 1.21, Sun Feb 18 22:13:53 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);
     @EXPORT = qw(GetAttributes AddAttribute DeleteAttribute ChangeAttribute MatchSqlPattern);  
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 17  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    =head3 Object IDs
32    
33    The object ID is normally represented as
34    
35        I<type>:I<id>
36    
37    where I<type> is the object type (C<Role>, C<Coupling>, etc.) and I<id> is
38    the actual object ID. Note that the object type must consist of only upper- and
39    lower-case letters! Thus, C<GenomeGroup> is a valid object type, but
40    C<genome_group> is not. Given that restriction, the object ID
41    
42        Family:aclame|cluster10
43    
44    would represent the FIG family C<aclame|cluster10>. For historical reasons,
45    there are three exceptions: subsystems, genomes, and features do not need
46    a type. So, for PEG 3361 of Streptomyces coelicolor A3(2), you simply code
47    
48        fig|100226.1.peg.3361
49    
50    The methods L</ParseID> and L</FormID> can be used to make this all seem
51    more consistent. Given any object ID string, L</ParseID> will convert it to an
52    object type and ID, and given any object type and ID, L</FormID> will
53    convert it to an object ID string. The attribute database is pretty
54    freewheeling about what it will allow for an ID; however, for best
55    results, the type should match an entity type from a Sprout genetics
56    database. If this rule is followed, then the database object
57    corresponding to an ID in the attribute database could be retrieved using
58    L</GetTargetObject> method.
59    
60        my $object = CustomAttributes::GetTargetObject($sprout, $idValue);
61    
62    =head3 Retrieval and Logging
63    
64  The full suite of ERDB retrieval capabilities is provided. In addition,  The full suite of ERDB retrieval capabilities is provided. In addition,
65  custom methods are provided specific to this application. To get all  custom methods are provided specific to this application. To get all
66  the values of the attribute C<essential> in the B<Feature> entity, you  the values of the attribute C<essential> in a specified B<Feature>, you
67  would code  would code
68    
69      my @values = $attrDB->GetAttributeValues($fid, Feature => 'essential');      my @values = $attrDB->GetAttributes($fid, 'essential');
70    
71  where I<$fid> contains the ID of the desired feature. Each attribute has  where I<$fid> contains the ID of the desired feature.
 an alternate index to allow searching for attributes by value.  
72    
73  New attributes are introduced by updating the database definition at  Keys can be split into two pieces using the splitter value defined in the
74  run-time. Attribute values are stored by uploading data from files.  constructor (the default is C<::>). The first piece of the key is called
75  A web interface is provided for both these activities.  the I<real key>. This portion of the key must be defined using the
76    web interface (C<Attributes.cgi>). The second portion of the key is called
77    the I<sub key>, and can take any value.
78    
79    Major attribute activity is recorded in a log (C<attributes.log>) in the
80    C<$FIG_Config::var> directory. The log reports the user name, time, and
81    the details of the operation. The user name will almost always be unknown,
82    the exception being when it is specified in this object's constructor
83    (see L</new>).
84    
85  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
86    
# Line 78  Line 126 
126    
127  =back  =back
128    
 =head2 Implementation 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.  
   
129  =head2 Public Methods  =head2 Public Methods
130    
131  =head3 new  =head3 new
132    
133  C<< my $attrDB = CustomAttributes->new($splitter); >>  C<< my $attrDB = CustomAttributes->new(%options); >>
134    
135  Construct a new CustomAttributes object. This object cannot be used to add or  Construct a new CustomAttributes object. The following options are
136  delete keys because that requires modifying the database design. To do that,  supported.
 you need to use the static L</StoreAttributeKey> or L</DeleteAttributeKey>  
 methods.  
137    
138  =over 4  =over 4
139    
140  =item splitter  =item splitter
141    
142  Value to be used to split attribute values into sections in the  Value to be used to split attribute values into sections in the
143  L</Fig Replacement Methods>. The default is a double colon C<::>.  L</Fig Replacement Methods>. The default is a double colon C<::>,
144  If you do not use the replacement methods, you do not need to  and should only be overridden in extreme circumstances.
145  worry about this parameter.  
146    =item user
147    
148    Name of the current user. This will appear in the attribute log.
149    
150  =back  =back
151    
# Line 109  Line 153 
153    
154  sub new {  sub new {
155      # Get the parameters.      # Get the parameters.
156      my ($class, $splitter) = @_;      my ($class, %options) = @_;
157      # Connect to the database.      # Connect to the database.
158      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
159                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
# Line 119  Line 163 
163      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = $FIG_Config::attrDBD;
164      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
165      # Store the splitter value.      # Store the splitter value.
166      $retVal->{splitter} = (defined($splitter) ? $splitter : '::');      $retVal->{splitter} = $options{splitter} || '::';
167        # Store the user name.
168        $retVal->{user} = $options{user} || '<unknown>';
169        Trace("User $retVal->{user} selected for attribute object.") if T(3);
170      # Return the result.      # Return the result.
171      return $retVal;      return $retVal;
172  }  }
173    
 =head3 GetAttributeValues  
   
 C<< my @values = $attrDB->GetAttributeValues($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->GetAttributeValues($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 GetAttributeValues {  
     # Get the parameters.  
     my ($self, $id, $entityName, $attributeName) = @_;  
     # Get the data.  
     my @retVal = $self->GetEntityValues($entityName, $id, ["$entityName($attributeName)"]);  
     # Return the result.  
     return @retVal;  
 }  
   
174  =head3 StoreAttributeKey  =head3 StoreAttributeKey
175    
176  C<< my $attrDB = CustomAttributes::StoreAttributeKey($entityName, $attributeName, $type, $notes); >>  C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>
177    
178  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.  
179    
180  =over 4  =over 4
181    
 =item entityName  
   
 Name of the entity containing the attribute. The entity must exist.  
   
182  =item attributeName  =item attributeName
183    
184  Name of the attribute. It must be a valid ERDB field name, consisting entirely of  Name of the attribute (the real key). If it does not exist already, it will be created.
 letters, digits, and hyphens, with a letter at the beginning. If it does not  
 exist already, it will be created.  
185    
186  =item type  =item type
187    
# Line 204  Line 191 
191    
192  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.
193    
194  =item RETURN  =item groups
195    
196  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.
197  error will be thrown.  This will replace any groups to which the attribute is currently attached.
198    
199  =back  =back
200    
# Line 215  Line 202 
202    
203  sub StoreAttributeKey {  sub StoreAttributeKey {
204      # Get the parameters.      # Get the parameters.
205      my ($entityName, $attributeName, $type, $notes) = @_;      my ($self, $attributeName, $type, $notes, $groups) = @_;
206        # Declare the return variable.
207        my $retVal;
208      # Get the data type hash.      # Get the data type hash.
209      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
210      # Validate the initial input values.      # Validate the initial input values.
211      if (! ERDB::ValidateFieldName($attributeName)) {      if ($attributeName =~ /$self->{splitter}/) {
212          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
213      } elsif (! $notes || length($notes) < 25) {      } elsif (! $notes || length($notes) < 25) {
214          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
215      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
216          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid data type \"$type\" for $attributeName.");
217        } else {
218            # Create a variable to hold the action to be displayed for the log (Add or Update).
219            my $action;
220            # Okay, we're ready to begin. See if this key exists.
221            my $attribute = $self->GetEntity('AttributeKey', $attributeName);
222            if (defined($attribute)) {
223                # It does, so we do an update.
224                $action = "Update Key";
225                $self->UpdateEntity('AttributeKey', $attributeName,
226                                    { description => $notes, 'data-type' => $type });
227                # Detach the key from its current groups.
228                $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
229            } else {
230                # It doesn't, so we do an insert.
231                $action = "Insert Key";
232                $self->InsertObject('AttributeKey', { id => $attributeName,
233                                    description => $notes, 'data-type' => $type });
234            }
235            # Attach the key to the specified groups. (We presume the groups already
236            # exist.)
237            for my $group (@{$groups}) {
238                $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
239                                                   'to-link'   => $group });
240      }      }
241      # Our next step is to read in the XML for the database defintion. We          # Log the operation.
242      # need to verify that the named entity exists.          $self->LogOperation($action, $attributeName, "Group list is " . join(" ", @{$groups}));
     my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);  
     my $entityHash = $metadata->{Entities};  
     if (! exists $entityHash->{$entityName}) {  
         Confess("Entity $entityName not found.");  
     } else {  
         # Okay, we're ready to begin. Get the entity hash and the field hash.  
         my $entityData = $entityHash->{$entityName};  
         my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);  
         # Compute the attribute's relation name.  
         my $relName = join("", $entityName, map { ucfirst $_ } split(/-|_/, $attributeName));  
         # Store the attribute's field data. Note the use of the "content" hash for  
         # the notes. This is how the XML writer knows Notes is a text tag instead of  
         # an attribute.  
         $fieldHash->{$attributeName} = { type => $type, relation => $relName,  
                                          Notes => { content => $notes } };  
         # Insure we have an index for this attribute.  
         my $index = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);  
         if (! defined($index)) {  
             push @{$entityData->{Indexes}}, { IndexFields => [ { name => $attributeName, order => 'ascending' } ],  
                                               Notes       => "Alternate index provided for access by $attributeName." };  
         }  
         # Write the XML back out.  
         ERDB::WriteMetaXML($metadata, $FIG_Config::attrDBD);  
243      }      }
     # Open a database with the new XML.  
     my $retVal = CustomAttributes->new();  
     return $retVal;  
244  }  }
245    
 =head3 Refresh  
   
 C<< $attrDB->Refresh($fig); >>  
   
 Refresh the primary entity tables from the FIG data store. This method basically  
 drops and reloads the main tables of the custom attributes database.  
   
 =over 4  
   
 =item fig  
   
 FIG-like object that can be used to find genomes and features.  
   
 =back  
   
 =cut  
   
 sub Refresh {  
     # Get the parameters.  
     my ($self, $fig) = @_;  
     # 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 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);  
 }  
246    
247  =head3 LoadAttributeKey  =head3 DeleteAttributeKey
248    
249  C<< my $stats = $attrDB->LoadAttributeKey($entityName, $fieldName, $fh, $keyCol, $dataCol); >>  C<< my $stats = $attrDB->DeleteAttributeKey($attributeName); >>
250    
251  Load the specified attribute from the specified file. The file should be a  Delete an attribute from the custom attributes database.
 tab-delimited file with internal tab and new-line characters escaped. This is  
 the typical TBL-style file used by most FIG applications. One of the columns  
 in the input file must contain the appropriate key value and the other the  
 corresponding attribute value.  
252    
253  =over 4  =over 4
254    
255  =item entityName  =item attributeName
   
 Name of the entity containing the attribute.  
   
 =item fieldName  
   
 Name of the actual attribute.  
   
 =item fh  
   
 Open file handle for the input file.  
   
 =item keyCol  
   
 Index (0-based) of the column containing the key field. The key field should  
 contain the ID of an instance of the named entity.  
   
 =item dataCol  
256    
257  Index (0-based) of the column containing the data value field.  Name of the attribute to delete.
258    
259  =item RETURN  =item RETURN
260    
261  Returns a statistics object for the load process.  Returns a statistics object describing the effects of the deletion.
262    
263  =back  =back
264    
265  =cut  =cut
266    
267  sub LoadAttributeKey {  sub DeleteAttributeKey {
268      # Get the parameters.      # Get the parameters.
269      my ($self, $entityName, $fieldName, $fh, $keyCol, $dataCol) = @_;      my ($self, $attributeName) = @_;
270      # Create the return variable.      # Delete the attribute key.
271      my $retVal;      my $retVal = $self->Delete('AttributeKey', $attributeName);
272      # Insure the entity exists.      # Log this operation.
273      my $found = grep { $_ eq $entityName } $self->GetEntityTypes();      $self->LogOperation("Delete Key", $attributeName, "Key will no longer be available for use by anyone.");
274      if (! $found) {      # Return the result.
         Confess("Entity \"$entityName\" not found in database.");  
     } else {  
         # Get the field structure for the named entity.  
         my $fieldHash = $self->GetFieldTable($entityName);  
         # Verify that the attribute exists.  
         if (! exists $fieldHash->{$fieldName}) {  
             Confess("Attribute key \"$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);  
             # Loop through the input file.  
             while (! eof $fh) {  
                 # Get the next line of the file.  
                 my @fields = Tracer::GetLine($fh);  
                 $loadAttribute->Add("lineIn");  
                 # Now we need to validate the line.  
                 if ($#fields < $dataCol) {  
                     $loadAttribute->Add("shortLine");  
                 } elsif (! $self->Exists($entityName, $fields[$keyCol])) {  
                     $loadAttribute->Add("badKey");  
                 } else {  
                     # It's valid,so send it to the loader.  
                     $loadAttribute->Put($fields[$keyCol], $fields[$dataCol]);  
                     $loadAttribute->Add("lineUsed");  
                 }  
             }  
             # Finish the load.  
             $retVal = $loadAttribute->FinishAndLoad();  
         }  
     }  
     # Return the statistics.  
275      return $retVal;      return $retVal;
 }  
   
   
 =head3 DeleteAttributeKey  
   
 C<< CustomAttributes::DeleteAttributeKey($entityName, $attributeName); >>  
   
 Delete an attribute from the custom attributes database.  
276    
277  =over 4  }
   
 =item entityName  
   
 Name of the entity possessing the attribute.  
278    
279  =item attributeName  =head3 NewName
280    
281  Name of the attribute to delete.  C<< my $text = CustomAttributes::NewName(); >>
282    
283  =back  Return the string used to indicate the user wants to add a new attribute.
284    
285  =cut  =cut
286    
287  sub DeleteAttributeKey {  sub NewName {
288      # Get the parameters.      return "(new)";
     my ($entityName, $attributeName) = @_;  
     # Read in the XML for the database defintion. We need to verify that  
     # the named entity exists and it has the named attribute.  
     my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);  
     my $entityHash = $metadata->{Entities};  
     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 key \"$attributeName\" not found in entity $entityName.");  
         } else {  
             # Get the attribute's relation name.  
             my $relName = $fieldHash->{$attributeName}->{relation};  
             # Check for an index.  
             my $indexIdx = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);  
             if (defined($indexIdx)) {  
                 Trace("Index for $attributeName found at position $indexIdx for $entityName.") if T(3);  
                 delete $entityHash->{$entityName}->{Indexes}->[$indexIdx];  
             }  
             # Delete the attribute from the field hash.  
             Trace("Deleting attribute $attributeName from $entityName.") if T(3);  
             delete $fieldHash->{$attributeName};  
             # Write the XML back out.  
             ERDB::WriteMetaXML($metadata, $FIG_Config::attrDBD);  
             # Insure the relation does not exist in the database. This requires connecting  
             # since we may have to do a table drop.  
             my $attrDB = CustomAttributes->new();  
             Trace("Dropping table $relName.") if T(3);  
             $attrDB->DropRelation($relName);  
         }  
     }  
289  }  }
290    
291  =head3 ControlForm  =head3 ControlForm
292    
293  C<< my $formHtml = $attrDB->ControlForm($cgi, $name); >>  C<< my $formHtml = $attrDB->ControlForm($cgi, $name, \%keys); >>
294    
295  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
296  attributes.  attributes. Only a subset of the attribute keys will be displayed, as
297    determined by the incoming list.
298    
299  =over 4  =over 4
300    
# Line 466  Line 306 
306    
307  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.
308    
309    =item keys
310    
311    Reference to a hash mapping attribute keys to n-tuples. Each tuple will contain the
312    attribute's data type, its description, and a list of the groups in which it participates.
313    
314  =item RETURN  =item RETURN
315    
316  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
317  for loading, creating, or deleting an attribute.  for loading, creating, displaying, changing, or deleting an attribute. Note that only the form
318    controls are generated. The form tags are left to the caller.
319    
320  =back  =back
321    
# Line 477  Line 323 
323    
324  sub ControlForm {  sub ControlForm {
325      # Get the parameters.      # Get the parameters.
326      my ($self, $cgi, $name) = @_;      my ($self, $cgi, $name, $keys) = @_;
327      # Declare the return list.      # Declare the return list.
328      my @retVal = ();      my @retVal = ();
     # Start the form. We use multipart to support the upload control.  
     push @retVal, $cgi->start_multipart_form(-name => $name);  
329      # 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.
330      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });
331      # The first row is for selecting the field name.      # The first row is for selecting the field name.
332      push @retVal, $cgi->Tr($cgi->th("Select a Field"),      push @retVal, $cgi->Tr($cgi->th("Select a Field"),
333                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', 1,                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', $keys,
334                                                       "document.$name.notes.value",                                                       new => 1,
335                                                       "document.$name.dataType.value")));                                                       notes => "document.$name.notes.value",
336                                                         type => "document.$name.dataType.value",
337                                                         groups => "document.$name.groups")));
338      # 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
339      # data type names, and the labels will be the descriptions.      # data type names, and the labels will be the descriptions.
340      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
341      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;
342      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',
343                                      -values => [sort keys %types],                                      -values => [sort keys %types],
344                                      -labels => \%labelMap);                                      -labels => \%labelMap,
345                                        -default => 'string');
346        # Allow the user to specify a new field name. This is required if the
347        # user has selected the "(new)" marker. We put a little scriptlet in here that
348        # selects the (new) marker when the user enters the field.
349        push @retVal, "<script language=\"javaScript\">";
350        my $fieldField = "document.$name.fieldName";
351        my $newName = "\"" . NewName() . "\"";
352        push @retVal, $cgi->Tr($cgi->th("New Field Name"),
353                               $cgi->td($cgi->textfield(-name => 'newName',
354                                                        -size => 30,
355                                                        -value => "",
356                                                        -onFocus => "setIfEmpty($fieldField, $newName);")),
357                                        );
358      push @retVal, $cgi->Tr($cgi->th("Data type"),      push @retVal, $cgi->Tr($cgi->th("Data type"),
359                             $cgi->td($typeMenu));                             $cgi->td($typeMenu));
360      # The next row is for the notes.      # The next row is for the notes.
# Line 504  Line 363 
363                                                     -rows => 6,                                                     -rows => 6,
364                                                     -columns => 80))                                                     -columns => 80))
365                            );                            );
366      # 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.
367      # user has selected one of the "(new)" markers.      my @groups = $self->GetGroups();
368      push @retVal, $cgi->Tr($cgi->th("New Field Name"),      push @retVal, $cgi->Tr($cgi->th("Groups"),
369                             $cgi->td($cgi->textfield(-name => 'newName',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
370                                                      -size => 30)),                                      -values=> \@groups))
                                     );  
     # If the user wants to upload new values for the field, then we have  
     # an upload file name and column indicators.  
     push @retVal, $cgi->Tr($cgi->th("Upload Values"),  
                            $cgi->td($cgi->filefield(-name => 'newValueFile',  
                                                     -size => 20) .  
                                     " Key&nbsp;" .  
                                     $cgi->textfield(-name => 'keyCol',  
                                                     -size => 3,  
                                                     -default => 0) .  
                                     " Value&nbsp;" .  
                                     $cgi->textfield(-name => 'valueCol',  
                                                     -size => 3,  
                                                     -default => 1)  
                                    ),  
371                            );                            );
372      # Now the two buttons: UPDATE and DELETE.      # Now the four buttons: STORE, SHOW, ERASE, and DELETE.
373      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
374                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'}, join(" ",
375                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE'),
376                                      $cgi->submit(-name => 'Store',  -value => 'STORE')                                      $cgi->submit(-name => 'Store',  -value => 'STORE'),
377                                     )                                      $cgi->submit(-name => 'Erase',  -value => 'ERASE'),
378                                        $cgi->submit(-name => 'Show',   -value => 'SHOW')
379                                       ))
380                            );                            );
381      # Close the table and the form.      # Close the table and the form.
382      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
     push @retVal, $cgi->end_form();  
383      # Return the assembled HTML.      # Return the assembled HTML.
384      return join("\n", @retVal, "");      return join("\n", @retVal, "");
385  }  }
386    
387  =head3 FieldMenu  =head3 LoadAttributesFrom
388    
389  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $newFlag, $noteControl, $typeControl); >>  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
390    
391  Return the HTML for a menu to select an attribute field. The menu will  Load attributes from the specified tab-delimited file. Each line of the file must
392  be a standard SELECT/OPTION thing which is called "popup menu" in the  contain an object ID in the first column, an attribute key name in the second
393  CGI package, but actually looks like a list. The list will contain  column, and attribute values in the remaining columns. The attribute values will
394  one selectable row per field, grouped by entity.  be assembled into a single value using the splitter code. In addition, the key names may
395    contain a splitter. If this is the case, the portion of the key after the splitter is
396    treated as a subkey.
397    
398  =over 4  =over 4
399    
400  =item cgi  =item fileName
401    
402  CGI query object used to generate HTML.  Name of the file from which to load the attributes, or an open handle for the file.
403    (This last enables the method to be used in conjunction with the CGI form upload
404    control.)
405    
406  =item height  =item options
407    
408  Number of lines to display in the list.  Hash of options for modifying the load process.
409    
410  =item name  =item RETURN
411    
412  Name to give to the menu. This is the name under which the value will  Returns a statistics object describing the load.
 appear when the form is submitted.  
413    
414  =item newFlag (optional)  =back
415    
416  If TRUE, then extra rows will be provided to allow the user to select  Permissible option values are as follows.
 a new attribute. In other words, the user can select an existing  
 attribute, or can choose a C<(new)> marker to indicate a field to  
 be created in the parent entity.  
417    
418  =item noteControl (optional)  =over 4
419    
420  If specified, the name of a variable for displaying the notes attached  =item append
 to the field. This must be in Javascript form ready for assignment.  
 So, for example, if you have a variable called C<notes> that  
 represents a paragraph element, you should code C<notes.innerHTML>.  
 If it actually represents a form field you should code C<notes.value>.  
 If an C<innerHTML> coding is used, the text will be HTML-escaped before  
 it is copied in. Specifying this parameter generates Javascript for  
 displaying the field description when a field is selected.  
421    
422  =item typeControl (optional)  If TRUE, then the attributes will be appended to existing data; otherwise, the
423    first time a key name is encountered, it will be erased.
424    
425  If specified, the name of a variable for displaying the field's  =item archive
 data type. Data types are a much more controlled vocabulary than  
 notes, so there is no worry about HTML translation. Instead, the  
 raw value is put into the specified variable. Otherwise, the same  
 rules apply to this value that apply to I<$noteControl>.  
426    
427  =item RETURN  If specified, the name of a file into which the incoming data file should be saved.
428    
429  Returns the HTML to create a form field that can be used to select an  =item objectType
430  attribute from the custom attributes system.  
431    If specified, the specified object type will be prefixed to each object ID.
432    
433  =back  =back
434    
435  =cut  =cut
436    
437  sub FieldMenu {  sub LoadAttributesFrom {
438      # Get the parameters.      # Get the parameters.
439      my ($self, $cgi, $height, $name, $newFlag, $noteControl, $typeControl) = @_;      my ($self, $fileName, %options) = @_;
440      # These next two hashes make everything happen. "entities"      # Declare the return variable.
441      # maps each entity name to the list of values to be put into its      my $retVal = Stats->new('keys', 'values');
442      # option group. "labels" maps each entity name to a map from values      # Check for append mode.
443      # to labels.      my $append = ($options{append} ? 1 : 0);
444      my @entityNames = sort ($self->GetEntityTypes());      # Create a hash of key names found.
445      my %entities = map { $_ => [] } @entityNames;      my %keyHash = ();
446      my %labels = map { $_ => { }} @entityNames;      # Open the file for input. Note we must anticipate the possibility of an
447      # Loop through the entities, adding the existing attributes.      # open filehandle being passed in.
448      for my $entity (@entityNames) {      my $fh;
449          # Get this entity's field table.      if (ref $fileName) {
450          my $fieldHash = $self->GetFieldTable($entity);          Trace("Using file opened by caller.") if T(3);
451          # Get its field list in our local hashes.          $fh = $fileName;
452          my $fieldList = $entities{$entity};      } else {
453          my $labelList = $labels{$entity};          Trace("Attributes will be loaded from $fileName.") if T(3);
454          # Add the NEW fields if we want them.          $fh = Open(undef, "<$fileName");
         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  
     # may not do anything, but we need to know the name to generate the HTML  
     # for the menu.  
     my $changeName = "${name}_setNotes";  
     my $retVal = $cgi->popup_menu({name => $name,  
                                    size => $height,  
                                    onChange => "$changeName(this.value)",  
                                    values => [map { $cgi->optgroup(-name => $_,  
                                                                    -values => $entities{$_},  
                                                                    -labels => $labels{$_})  
                                                   } @entityNames]}  
                                  );  
     # Create the change function.  
     $retVal .= "\n<script language=\"javascript\">\n";  
     $retVal .= "    function $changeName(fieldValue) {\n";  
     # The function only has a body if we have a notes control to store the description.  
     if ($noteControl || $typeControl) {  
         # Check to see if we're storing HTML or text into the note control.  
         my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);  
         # We use a CASE statement based on the newly-selected field value. The  
         # field description will be stored in the JavaScript variable "myText"  
         # and the data type in "myType". Note the default data type is a normal  
         # string, but the default notes is an empty string.  
         $retVal .= "        var myText = \"\";\n";  
         $retVal .= "        var myType = \"string\";\n";  
         $retVal .= "        switch (fieldValue) {\n";  
         # Loop through the entities.  
         for my $entity (@entityNames) {  
             # 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};  
                     # Generate this case.  
                     $retVal .= "        case \"$value\" :\n";  
                     # Here we either want to update the note display, the  
                     # type display, or both.  
                     if ($noteControl) {  
                         # Here we want the notes updated.  
                         my $notes = $element->{Notes}->{content};  
                         # Insure it's in the proper form.  
                         if ($htmlMode) {  
                             $notes = ERDB::HTMLNote($notes);  
                         }  
                         # Escape it for use as a string literal.  
                         $notes =~ s/\n/\\n/g;  
                         $notes =~ s/"/\\"/g;  
                         $retVal .= "           myText = \"$notes\";\n";  
                     }  
                     if ($typeControl) {  
                         # Here we want the type updated.  
                         my $type = $element->{type};  
                         $retVal .= "           myType = \"$type\";\n";  
                     }  
                     # Close this case.  
                     $retVal .= "           break;\n";  
                 }  
             }  
455          }          }
456          # Close the CASE statement and make the appropriate assignments.      # Now check to see if we need to archive.
457          $retVal .= "        }\n";      my $ah;
458          if ($noteControl) {      if ($options{archive}) {
459              $retVal .= "        $noteControl = myText;\n";          $ah = Open(undef, ">$options{archive}");
460            Trace("Load file will be archived to $options{archive}.") if T(3);
461        }
462        # Finally, open a database transaction.
463        $self->BeginTran();
464        # Insure we recover from errors. If an error occurs, we will delete the archive file and
465        # roll back the updates.
466        eval {
467            # Loop through the file.
468            while (! eof $fh) {
469                # Read the current line.
470                my ($id, $key, @values) = Tracer::GetLine($fh);
471                $retVal->Add(linesIn => 1);
472                # Check to see if we need to fix up the object ID.
473                if ($options{objectType}) {
474                    $id = "$options{objectType}:$id";
475                }
476                # Archive the line (if necessary).
477                if (defined $ah) {
478                    Tracer::PutLine($ah, [$id, $key, @values]);
479                }
480                # Do some validation.
481                if (! $id) {
482                    # We ignore blank lines.
483                    $retVal->Add(blankLines => 1);
484                } elsif (substr($id, 0, 1) eq '#') {
485                    # A line beginning with a pound sign is a comment.
486                    $retVal->Add(comments => 1);
487                } elsif (! defined($key)) {
488                    # An ID without a key is a serious error.
489                    my $lines = $retVal->Ask('linesIn');
490                    Confess("Line $lines in $fileName has no attribute key.");
491                } else {
492                    # The key contains a real part and an optional sub-part. We need the real part.
493                    my ($realKey, $subKey) = $self->SplitKey($key);
494                    # Now we need to check for a new key.
495                    if (! exists $keyHash{$realKey}) {
496                        if (! $self->Exists('AttributeKey', $realKey)) {
497                            my $line = $retVal->Ask('linesIn');
498                            Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
499                        } else {
500                            # Make sure we know this is no longer a new key.
501                            $keyHash{$realKey} = 1;
502                            $retVal->Add(keys => 1);
503                            # If this is NOT append mode, erase the key.
504                            if (! $append) {
505                                $self->EraseAttribute($realKey);
506                            }
507                        }
508                        Trace("Key $realKey found.") if T(3);
509                    }
510                    # Everything is all set up, so add the value.
511                    $self->AddAttribute($id, $key, @values);
512                    my $progress = $retVal->Add(values => 1);
513                    Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
514                }
515            }
516        };
517        # Check for an error.
518        if ($@) {
519            # Here we have an error. Roll back the transaction and delete the archive file.
520            my $message = $@;
521            Trace("Rolling back attribute updates due to error.") if T(1);
522            $self->RollbackTran();
523            if (defined $ah) {
524                Trace("Deleting archive file $options{archive}.") if T(1);
525                close $ah;
526                unlink $options{archive};
527          }          }
528          if ($typeControl) {          Confess("Error during attribute load: $message");
529              $retVal .= "        $typeControl = myType;\n";      } else {
530            # Here the load worked. Commit the transaction and close the archive file.
531            Trace("Committing attribute upload.") if T(2);
532            $self->CommitTran();
533            if (defined $ah) {
534                Trace("Closing archive file $options{archive}.") if T(2);
535                close $ah;
536          }          }
537      }      }
     # Terminate the change function.  
     $retVal .= "    }\n";  
     $retVal .= "</script>\n";  
538      # Return the result.      # Return the result.
539      return $retVal;      return $retVal;
540  }  }
541    
542  =head3 MatchSqlPattern  =head3 BackupKeys
543    
544  C<< my $matched = MatchSqlPattern($value, $pattern); >>  C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
545    
546  Determine whether or not a specified value matches an SQL pattern. An SQL  Backup the attribute key information from the attribute database.
 pattern has two wild card characters: C<%> that matches multiple characters,  
 and C<_> that matches a single character. These can be escaped using a  
 backslash (C<\>). We pull this off by converting the SQL pattern to a  
 PERL regular expression. As per SQL rules, the match is case-insensitive.  
547    
548  =over 4  =over 4
549    
550  =item value  =item fileName
551    
552  Value to be matched against the pattern. Note that an undefined value will  Name of the output file.
 not match anything.  
553    
554  =item pattern  =item options
555    
556  SQL pattern against which to match the value. An undefined pattern will  Options for modifying the backup process.
 match everything.  
557    
558  =item RETURN  =item RETURN
559    
560  Returns TRUE if the value and pattern match, else FALSE.  Returns a statistics object for the backup.
561    
562  =back  =back
563    
564    Currently there are no options. The backup is straight to a text file in
565    tab-delimited format. Each key is backup up to two lines. The first line
566    is all of the data from the B<AttributeKey> table. The second is a
567    tab-delimited list of all the groups.
568    
569  =cut  =cut
570    
571  sub MatchSqlPattern {  sub BackupKeys {
572      # Get the parameters.      # Get the parameters.
573      my ($value, $pattern) = @_;      my ($self, $fileName, %options) = @_;
574      # Declare the return variable.      # Declare the return variable.
575      my $retVal;      my $retVal = Stats->new();
576      # Insure we have a pattern.      # Open the output file.
577      if (! defined($pattern)) {      my $fh = Open(undef, ">$fileName");
578          $retVal = 1;      # Set up to read the keys.
579      } else {      my $keyQuery = $self->Get(['AttributeKey'], "", []);
580          # Break the pattern into pieces around the wildcard characters. Because we      # Loop through the keys.
581          # use parentheses in the split function's delimiter expression, we'll get      while (my $keyData = $keyQuery->Fetch()) {
582          # list elements for the delimiters as well as the rest of the string.          $retVal->Add(key => 1);
583          my @pieces = split /([_%]|\\[_%])/, $pattern;          # Get the fields.
584          # Check some fast special cases.          my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
585          if ($pattern eq '%') {                                                            'AttributeKey(description)']);
586              # A null pattern matches everything.          # Escape any tabs or new-lines in the description.
587              $retVal = 1;          my $escapedDescription = Tracer::Escape($description);
588          } elsif (@pieces == 1) {          # Write the key data to the output.
589              # No wildcards, so we have a literal comparison. Note we're case-insensitive.          Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
590              $retVal = (lc($value) eq lc($pattern));          # Get the key's groups.
591          } elsif (@pieces == 2 && $pieces[1] eq '%') {          my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
592              # A wildcard at the end, so we have a substring match. This is also case-insensitive.                                      'IsInGroup(to-link)');
593              $retVal = (lc(substr($value, 0, length($pieces[0]))) eq lc($pieces[0]));          $retVal->Add(memberships => scalar(@groups));
594          } else {          # Write them to the output. Note we put a marker at the beginning to insure the line
595              # Okay, we have to do it the hard way. Convert each piece to a PERL pattern.          # is nonempty.
596              my $realPattern = "";          Tracer::PutLine($fh, ['#GROUPS', @groups]);
             for my $piece (@pieces) {  
                 # Determine the type of piece.  
                 if ($piece eq "") {  
                     # Empty pieces are ignored.  
                 } elsif ($piece eq "%") {  
                     # Here we have a multi-character wildcard. Note that it can match  
                     # zero or more characters.  
                     $realPattern .= ".*"  
                 } elsif ($piece eq "_") {  
                     # Here we have a single-character wildcard.  
                     $realPattern .= ".";  
                 } elsif ($piece eq "\\%" || $piece eq "\\_") {  
                     # This is an escape sequence (which is a rare thing, actually).  
                     $realPattern .= substr($piece, 1, 1);  
                 } else {  
                     # Here we have raw text.  
                     $realPattern .= quotemeta($piece);  
                 }  
             }  
             # Do the match.  
             $retVal = ($value =~ /^$realPattern$/i ? 1 : 0);  
         }  
597      }      }
598        # Log the operation.
599        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
600      # Return the result.      # Return the result.
601      return $retVal;      return $retVal;
602  }  }
603    
604  =head3 MigrateAttributes  =head3 RestoreKeys
605    
606  C<< CustomAttributes::MigrateAttributes($fig); >>  C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
607    
608  Migrate all the attributes data from the specified FIG instance. This is a long, slow  Restore the attribute keys and groups from a backup file.
 method used to convert the old attribute data to the new system. Only attribute  
 keys that are not already in the database will be loaded, and only for entity instances  
 current in the database. To get an accurate capture of the attributes in the given  
 instance, you may want to clear the database and the DBD before starting and  
 run L</Refresh> to populate the entities.  
609    
610  =over 4  =over 4
611    
612  =item fig  =item fileName
613    
614  A FIG object that can be used to retrieve attributes for migration purposes.  Name of the file containing the backed-up keys. Each key has a pair of lines,
615    one containing the key data and one listing its groups.
616    
617  =back  =back
618    
619  =cut  =cut
620    
621  sub MigrateAttributes {  sub RestoreKeys {
622      # Get the parameters.      # Get the parameters.
623      my ($fig) = @_;      my ($self, $fileName, %options) = @_;
624      # Get a list of the objects to migrate. This requires connecting. Note we      # Declare the return variable.
625      # will map each entity type to a file name. The file will contain a list      my $retVal = Stats->new();
626      # of the object's IDs so we can get to them when we're not connected to      # Set up a hash to hold the group IDs.
627      # the database.      my %groups = ();
628      my $ca = CustomAttributes->new();      # Open the file.
     my %objects = map { $_ => "$FIG_Config::temp/$_.keys.tbl" } $ca->GetEntityTypes();  
     # Set up hash of the existing attribute keys for each entity type.  
     my %oldKeys = ();  
     # Finally, we have a hash that counts the IDs for each entity type.  
     my %idCounts = map { $_ => 0 } keys %objects;  
     # Loop through the list, creating key files to read back in.  
     for my $entityType (keys %objects) {  
         Trace("Retrieving keys for $entityType.") if T(2);  
         # Create the key file.  
         my $idFile = Open(undef, ">$objects{$entityType}");  
         # Loop through the keys.  
         my @ids = $ca->GetFlat([$entityType], "", [], "$entityType(id)");  
         for my $id (@ids) {  
             print $idFile "$id\n";  
         }  
         close $idFile;  
         # In addition to the key file, we must get a list of attributes already  
         # in the database. This avoids a circularity problem that might occur if the $fig  
         # object is retrieving from the custom attributes database already.  
         my %fields = $ca->GetSecondaryFields($entityType);  
         $oldKeys{$entityType} = \%fields;  
         # Finally, we have the ID count.  
         $idCounts{$entityType} = scalar @ids;  
     }  
     # Release the custom attributes database so we can add attributes.  
     undef $ca;  
     # Loop through the objects.  
     for my $entityType (keys %objects) {  
         # Get a hash of all the attributes already in this database. These are  
         # left untouched.  
         my $myOldKeys = $oldKeys{$entityType};  
         # Create a hash to control the load file names for each attribute key we find.  
         my %keyHash = ();  
         # Set up some counters so we can trace our progress.  
         my ($totalIDs, $processedIDs, $keyCount, $valueCount) = ($idCounts{$entityType}, 0, 0, 0);  
         # Open this object's ID file.  
         Trace("Migrating data for $entityType. $totalIDs found.") if T(3);  
         my $keysIn = Open(undef, "<$objects{$entityType}");  
         while (my $id = <$keysIn>) {  
             # Remove the EOL characters.  
             chomp $id;  
             # Get this object's attributes.  
             my @allData = $fig->get_attributes($id);  
             Trace(scalar(@allData) . " attribute values found for $entityType($id).") if T(4);  
             # Loop through the attribute values one at a time.  
             for my $dataTuple (@allData) {  
                 # Get the key, value, and URL. We ignore the first element because that's the  
                 # object ID, and we already know the object ID.  
                 my (undef, $key, $value, $url) = @{$dataTuple};  
                 # Only proceed if this is not an old key.  
                 if (! $myOldKeys->{$key}) {  
                     # See if we've run into this key before.  
                     if (! exists $keyHash{$key}) {  
                         # Here we need to create the attribute key in the database.  
                         StoreAttributeKey($entityType, $key, 'text',  
                                           "Key migrated automatically from the FIG system. " .  
                                           "Please replace these notes as soon as possible " .  
                                           "with useful text."  
                                          );  
                         # Compute the attribute's load file name and open it for output.  
                         my $fileName = "$FIG_Config::temp/$entityType.$key.load.tbl";  
                         my $fh = Open(undef, ">$fileName");  
                         # Store the file name and handle.  
                         $keyHash{$key} = {h => $fh, name => $fileName};  
                         # Count this key.  
                         $keyCount++;  
                     }  
                     # Smash the value and the URL together.  
                     if (defined($url) && length($url) > 0) {  
                         $value .= "::$url";  
                     }  
                     # Write the attribute value to the load file.  
                     Tracer::PutLine($keyHash{$key}->{h}, [$id, $value]);  
                     $valueCount++;  
                 }  
             }  
             # Now we've finished all the attributes for this object. Count and trace it.  
             $processedIDs++;  
             if ($processedIDs % 500 == 0) {  
                 Trace("$processedIDs of $totalIDs ${entityType}s processed.") if T(3);  
                 Trace("$entityType has $keyCount keys and $valueCount values so far.") if T(3);  
             }  
         }  
         # Now we've finished all the attributes for all objects of this type.  
         Trace("$processedIDs ${entityType}s processed, with $keyCount keys and $valueCount values.") if T(2);  
         # Loop through the files, loading the keys into the database.  
         Trace("Connecting to database.") if T(2);  
         my $objectCA = CustomAttributes->new();  
         Trace("Loading key files.") if T(2);  
         for my $key (sort keys %keyHash) {  
             # Close the key's load file.  
             close $keyHash{$key}->{h};  
             # Reopen it for input.  
             my $fileName = $keyHash{$key}->{name};  
629              my $fh = Open(undef, "<$fileName");              my $fh = Open(undef, "<$fileName");
630              Trace("Loading $key from $fileName.") if T(3);      # Loop until we're done.
631              my $stats = $objectCA->LoadAttributeKey($entityType, $key, $fh, 0, 1);      while (! eof $fh) {
632              Trace("Statistics for $key of $entityType:\n" . $stats->Show()) if T(3);          # Get a key record.
633            my ($id, $dataType, $description) = Tracer::GetLine($fh);
634            if ($id eq '#GROUPS') {
635                Confess("Group record found when key record expected.");
636            } elsif (! defined($description)) {
637                Confess("Invalid format found for key record.");
638            } else {
639                $retVal->Add("keyIn" => 1);
640                # Add this key to the database.
641                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
642                                                      description => Tracer::UnEscape($description) });
643                Trace("Attribute $id stored.") if T(3);
644                # Get the group line.
645                my ($marker, @groups) = Tracer::GetLine($fh);
646                if (! defined($marker)) {
647                    Confess("End of file found where group record expected.");
648                } elsif ($marker ne '#GROUPS') {
649                    Confess("Group record not found after key record.");
650                } else {
651                    $retVal->Add(memberships => scalar(@groups));
652                    # Connect the groups.
653                    for my $group (@groups) {
654                        # Find out if this is a new group.
655                        if (! $groups{$group}) {
656                            $retVal->Add(newGroup => 1);
657                            # Add the group.
658                            $self->InsertObject('AttributeGroup', { id => $group });
659                            Trace("Group $group created.") if T(3);
660                            # Make sure we know it's not new.
661                            $groups{$group} = 1;
662                        }
663                        # Connect the group to our key.
664                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
665                    }
666                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
667                }
668          }          }
         # All the keys for this entity type are now loaded.  
         Trace("Key files loaded for $entityType.") if T(2);  
669      }      }
670      # All keys for all entity types are now loaded.      # Log the operation.
671      Trace("Migration complete.") if T(2);      $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
672        # Return the result.
673        return $retVal;
674  }  }
675    
676  =head2 FIG Method Replacements  =head3 ArchiveFileName
677    
678  The following methods are used by B<FIG.pm> to replace the previous attribute functionality.  C<< my $fileName = $ca->ArchiveFileName(); >>
 Some of the old functionality is no longer present. Controlled vocabulary is no longer  
 supported and there is no longer any searching by URL. Fortunately, neither of these  
 capabilities were used in the old system.  
679    
680  In the previous implementation, an attribute had a value and a URL. In the new implementation,  Compute a file name for archiving attribute input data. The file will be in the attribute log directory
 there is only a value. In this implementation, each attribute has only a value. These  
 methods will treat the value as a list with the individual elements separated by the  
 value of the splitter parameter on the constructor (L</new>). The default is double  
 colons C<::>.  
681    
682  So, for example, an old-style keyword with a /value of C<essential> and a URL of  =cut
 C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default  
 splitter value would be stored as  
683    
684      essential::http://www.sciencemag.org/cgi/content/abstract/293/5538/2266  sub ArchiveFileName {
685        # Get the parameters.
686        my ($self) = @_;
687        # Declare the return variable.
688        my $retVal;
689        # We start by turning the timestamp into something usable as a file name.
690        my $now = Tracer::Now();
691        $now =~ tr/ :\//___/;
692        # Next we get the directory name.
693        my $dir = "$FIG_Config::var/attributes";
694        if (! -e $dir) {
695            Trace("Creating attribute file directory $dir.") if T(1);
696            mkdir $dir;
697        }
698        # Put it together with the field name and the time stamp.
699        $retVal = "$dir/upload.$now";
700        # Modify the file name to insure it's unique.
701        my $seq = 0;
702        while (-e "$retVal.$seq.tbl") { $seq++ }
703        # Use the computed sequence number to get the correct file name.
704        $retVal .= ".$seq.tbl";
705        # Return the result.
706        return $retVal;
707    }
708    
709  The best performance is achieved by searching for a particular key for a specified  =head3 BackupAllAttributes
 feature or genome.  
710    
711  =head3 GetAttributes  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
712    
713  C<< my @attributeList = GetAttributes($objectID, $key, @valuePatterns); >>  Backup all of the attributes to a file. The attributes will be stored in a
714    tab-delimited file suitable for reloading via L</LoadAttributesFrom>.
715    
716  or  =over 4
717    
718  C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @valuePatterns); >>  =item fileName
719    
720  The first form will connect to the database and release it. The second form  Name of the file to which the attribute data should be backed up.
 uses the database connection contained in the object.  
721    
722  In the database, attribute values are sectioned into pieces using a splitter  =item options
 value specified in the constructor (L</new>). This is not a requirement of  
 the attribute system as a whole, merely a convenience for the purpose of  
 these methods. If you are using the static method calls instead of the  
 object-based calls, the splitter will always be the default value of  
 double colons (C<::>). If a value has multiple sections, each section  
 is matched against the correspond criterion in the I<@valuePatterns> list.  
723    
724  This method returns a series of tuples that match the specified criteria. Each tuple  Hash of options for the backup.
 will contain an object ID, a key, and one or more values. The parameters to this  
 method therefore correspond structurally to the values expected in each tuple.  
725    
726      my @attributeList = GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);  =item RETURN
727    
728  would return something like  Returns a statistics object describing the backup.
729    
730      ['fig}100226.1.peg.1004', 'structure', 1, 2]  =back
     ['fig}100226.1.peg.1004', 'structure1', 1, 2]  
     ['fig}100226.1.peg.1004', 'structure2', 1, 2]  
     ['fig}100226.1.peg.1004', 'structureA', 1, 2]  
731    
732  Use of C<undef> in any position acts as a wild card (all values). In addition,  Currently there are no options defined.
 the I<$key> and I<@valuePatterns> parameters can contain SQL pattern characters: C<%>, which  
 matches any sequence of characters, and C<_>, which matches any single character.  
 (You can use an escape sequence C<\%> or C<\_> to match an actual percent sign or  
 underscore.)  
733    
734  In addition to values in multiple sections, a single attribute key can have multiple  =cut
 values, so even  
735    
736      my @attributeList = GetAttributes($peg, 'virulent');  sub BackupAllAttributes {
737        # Get the parameters.
738        my ($self, $fileName, %options) = @_;
739        # Declare the return variable.
740        my $retVal = Stats->new();
741        # Get a list of the keys.
742        my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
743        Trace(scalar(@keys) . " keys found during backup.") if T(2);
744        # Open the file for output.
745        my $fh = Open(undef, ">$fileName");
746        # Loop through the keys.
747        for my $key (@keys) {
748            Trace("Backing up attribute $key.") if T(3);
749            $retVal->Add(keys => 1);
750            # Loop through this key's values.
751            my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
752            my $valuesFound = 0;
753            while (my $line = $query->Fetch()) {
754                $valuesFound++;
755                # Get this row's data.
756                my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',
757                                                                 'HasValueFor(from-link)',
758                                                                 'HasValueFor(subkey)',
759                                                                 'HasValueFor(value)']);
760                # Check for a subkey.
761                if ($subKey ne '') {
762                    $key = "$key$self->{splitter}$subKey";
763                }
764                # Write it to the file.
765                Tracer::PutLine($fh, [$id, $key, $value]);
766            }
767            Trace("$valuesFound values backed up for key $key.") if T(3);
768            $retVal->Add(values => $valuesFound);
769        }
770        # Log the operation.
771        $self->LogOperation("Backup Data", $fileName, $retVal->Display());
772        # Return the result.
773        return $retVal;
774    }
775    
776  which has no wildcard in the key or the object ID, may return multiple tuples.  =head3 FieldMenu
777    
778  For reasons of backward compatability, we examine the structure of the object ID to  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>
 determine the entity type. In that case the only two types allowed are C<Genome> and  
 C<Feature>. An alternative method is to use a list reference, with the list consisting  
 of an entity type name and the actual ID. Thus, the above example could equivalently  
 be written as  
779    
780      my @attributeList = GetAttributes([Feature => $peg], 'virulent');  Return the HTML for a menu to select an attribute field. The menu will
781    be a standard SELECT/OPTION thing which is called "popup menu" in the
782    CGI package, but actually looks like a list. The list will contain
783    one selectable row per field.
784    
785  The list-reference approach allows us to add attributes to other entity types in  =over 4
 the future. Doing so, however, will require modifying the L</Refresh> method and  
 updated the database design XML.  
786    
787  The list-reference approach also allows for a more fault-tolerant approach to  =item cgi
 getting all objects with a particular attribute.  
788    
789      my @attributeList = GetAttributes([Feature => undef], 'virulent');  CGI query object used to generate HTML.
790    
791  will only return feature attributes, while  =item height
792    
793      my @attributeList = GetAttributes(undef, 'virulent');  Number of lines to display in the list.
794    
795  could at some point in the future get you attributes for genomes or even subsystems  =item name
796  as well as features.  
797    Name to give to the menu. This is the name under which the value will
798    appear when the form is submitted.
799    
800    =item keys
801    
802    Reference to a hash mapping each attribute key name to a list reference,
803    the list itself consisting of the attribute data type, its description,
804    and a list of its groups.
805    
806    =item options
807    
808    Hash containing options that modify the generation of the menu.
809    
810    =item RETURN
811    
812    Returns the HTML to create a form field that can be used to select an
813    attribute from the custom attributes system.
814    
815    =back
816    
817    The permissible options are as follows.
818    
819    =over 4
820    
821    =item new
822    
823    If TRUE, then extra rows will be provided to allow the user to select
824    a new attribute. In other words, the user can select an existing
825    attribute, or can choose a C<(new)> marker to indicate a field to
826    be created in the parent entity.
827    
828    =item notes
829    
830    If specified, the name of a variable for displaying the notes attached
831    to the field. This must be in Javascript form ready for assignment.
832    So, for example, if you have a variable called C<notes> that
833    represents a paragraph element, you should code C<notes.innerHTML>.
834    If it actually represents a form field you should code C<notes.value>.
835    If an C<innerHTML> coding is used, the text will be HTML-escaped before
836    it is copied in. Specifying this parameter generates Javascript for
837    displaying the field description when a field is selected.
838    
839    =item type
840    
841    If specified, the name of a variable for displaying the field's
842    data type. Data types are a much more controlled vocabulary than
843    notes, so there is no worry about HTML translation. Instead, the
844    raw value is put into the specified variable. Otherwise, the same
845    rules apply to this value that apply to I<$noteControl>.
846    
847    =item groups
848    
849    If specified, the name of a multiple-selection list control (also called
850    a popup menu) which shall be used to display the selected groups.
851    
852    =back
853    
854    =cut
855    
856    sub FieldMenu {
857        # Get the parameters.
858        my ($self, $cgi, $height, $name, $keys, %options) = @_;
859        # Reformat the list of keys.
860        my %keys = %{$keys};
861        # Add the (new) key, if needed.
862        if ($options{new}) {
863            $keys{NewName()} = ["string", ""];
864        }
865        # Get a sorted list of key.
866        my @keys = sort keys %keys;
867        # We need to create the name for the onChange function. This function
868        # may not do anything, but we need to know the name to generate the HTML
869        # for the menu.
870        my $changeName = "${name}_setNotes";
871        my $retVal = $cgi->popup_menu({name => $name,
872                                       size => $height,
873                                       onChange => "$changeName(this.value)",
874                                       values => \@keys,
875                                      });
876        # Create the change function.
877        $retVal .= "\n<script language=\"javascript\">\n";
878        $retVal .= "    function $changeName(fieldValue) {\n";
879        # The function only has a body if we have a control to store data about the
880        # attribute.
881        if ($options{notes} || $options{type} || $options{groups}) {
882            # Check to see if we're storing HTML or text into the note control.
883            my $noteControl = $options{notes};
884            my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);
885            # We use a CASE statement based on the newly-selected field value. The
886            # field description will be stored in the JavaScript variable "myText"
887            # and the data type in "myType". Note the default data type is a normal
888            # string, but the default notes is an empty string.
889            $retVal .= "        var myText = \"\";\n";
890            $retVal .= "        var myType = \"string\";\n";
891            $retVal .= "        switch (fieldValue) {\n";
892            # Loop through the keys.
893            for my $key (@keys) {
894                # Generate this case.
895                $retVal .= "        case \"$key\" :\n";
896                # Here we either want to update the note display, the
897                # type display, the group list, or a combination of them.
898                my ($type, $notes, @groups) = @{$keys{$key}};
899                if ($noteControl) {
900                    # Insure it's in the proper form.
901                    if ($htmlMode) {
902                        $notes = ERDB::HTMLNote($notes);
903                    }
904                    # Escape it for use as a string literal.
905                    $notes =~ s/\n/\\n/g;
906                    $notes =~ s/"/\\"/g;
907                    $retVal .= "           myText = \"$notes\";\n";
908                }
909                if ($options{type}) {
910                    # Here we want the type updated.
911                    $retVal .= "           myType = \"$type\";\n";
912                }
913                if ($options{groups}) {
914                    # Here we want the groups shown. Get a list of this attribute's groups.
915                    # We'll search through this list for each group to see if it belongs with
916                    # our attribute.
917                    my $groupLiteral = "=" . join("=", @groups) . "=";
918                    # Now we need some variables containing useful code for the javascript. It's
919                    # worth knowing we go through a bit of pain to insure $groupField[i] isn't
920                    # parsed as an array element.
921                    my $groupField = $options{groups};
922                    my $currentField = $groupField . "[i]";
923                    # Do the javascript.
924                    $retVal .= "           var groupList = \"$groupLiteral\";\n";
925                    $retVal .= "           for (var i = 0; i < $groupField.length; i++) {\n";
926                    $retVal .= "              var srchString = \"=\" + $currentField.value + \"=\";\n";
927                    $retVal .= "              var srchLoc = groupList.indexOf(srchString);\n";
928                    $retVal .= "              $currentField.checked = (srchLoc >= 0);\n";
929                    $retVal .= "           }\n";
930                }
931                # Close this case.
932                $retVal .= "           break;\n";
933            }
934            # Close the CASE statement and make the appropriate assignments.
935            $retVal .= "        }\n";
936            if ($noteControl) {
937                $retVal .= "        $noteControl = myText;\n";
938            }
939            if ($options{type}) {
940                $retVal .= "        $options{type} = myType;\n";
941            }
942        }
943        # Terminate the change function.
944        $retVal .= "    }\n";
945        $retVal .= "</script>\n";
946        # Return the result.
947        return $retVal;
948    }
949    
950    =head3 GetGroups
951    
952    C<< my @groups = $attrDB->GetGroups(); >>
953    
954    Return a list of the available groups.
955    
956    =cut
957    
958    sub GetGroups {
959        # Get the parameters.
960        my ($self) = @_;
961        # Get the groups.
962        my @retVal = $self->GetFlat(['AttributeGroup'], "", [], 'AttributeGroup(id)');
963        # Return them.
964        return @retVal;
965    }
966    
967    =head3 GetAttributeData
968    
969    C<< my %keys = $attrDB->GetAttributeData($type, @list); >>
970    
971    Return attribute data for the selected attributes. The attribute
972    data is a hash mapping each attribute key name to a n-tuple containing the
973    data type, the description, and the groups. This is the same format expected in
974    the L</FieldMenu> and L</ControlForm> methods for the list of attributes to display.
975    
976    =over 4
977    
978    =item type
979    
980    Type of attribute criterion: C<name> for attributes whose names begin with the
981    specified string, or C<group> for attributes in the specified group.
982    
983    =item list
984    
985    List containing the names of the groups or keys for the desired attributes.
986    
987    =item RETURN
988    
989    Returns a hash mapping each attribute key name to its data type, description, and
990    parent groups.
991    
992    =back
993    
994    =cut
995    
996    sub GetAttributeData {
997        # Get the parameters.
998        my ($self, $type, @list) = @_;
999        # Set up a hash to store the attribute data.
1000        my %retVal = ();
1001        # Loop through the list items.
1002        for my $item (@list) {
1003            # Set up a query for the desired attributes.
1004            my $query;
1005            if ($type eq 'name') {
1006                # Here we're doing a generic name search. We need to escape it and then tack
1007                # on a %.
1008                my $parm = $item;
1009                $parm =~ s/_/\\_/g;
1010                $parm =~ s/%/\\%/g;
1011                $parm .= "%";
1012                # Ask for matching attributes. (Note that if the user passed in a null string
1013                # he'll get everything.)
1014                $query = $self->Get(['AttributeKey'], "AttributeKey(id) LIKE ?", [$parm]);
1015            } elsif ($type eq 'group') {
1016                $query = $self->Get(['IsInGroup', 'AttributeKey'], "IsInGroup(to-link) = ?", [$item]);
1017            } else {
1018                Confess("Unknown attribute query type \"$type\".");
1019            }
1020            while (my $row = $query->Fetch()) {
1021                # Get this attribute's data.
1022                my ($key, $type, $notes) = $row->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
1023                                                         'AttributeKey(description)']);
1024                # If it's new, get its groups and add it to the return hash.
1025                if (! exists $retVal{$key}) {
1026                    my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",
1027                                                [$key], 'IsInGroup(to-link)');
1028                    $retVal{$key} = [$type, $notes, @groups];
1029                }
1030            }
1031        }
1032        # Return the result.
1033        return %retVal;
1034    }
1035    
1036    =head3 LogOperation
1037    
1038    C<< $ca->LogOperation($action, $target, $description); >>
1039    
1040    Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).
1041    
1042    =over 4
1043    
1044    =item action
1045    
1046    Action being logged (e.g. C<Delete Group> or C<Load Key>).
1047    
1048    =item target
1049    
1050    ID of the key or group affected.
1051    
1052    =item description
1053    
1054    Short description of the action.
1055    
1056    =back
1057    
1058    =cut
1059    
1060    sub LogOperation {
1061        # Get the parameters.
1062        my ($self, $action, $target, $description) = @_;
1063        # Get the user ID.
1064        my $user = $self->{user};
1065        # Get a timestamp.
1066        my $timeString = Tracer::Now();
1067        # Open the log file for appending.
1068        my $oh = Open(undef, ">>$FIG_Config::var/attributes.log");
1069        # Write the data to it.
1070        Tracer::PutLine($oh, [$timeString, $user, $action, $target, $description]);
1071        # Close the log file.
1072        close $oh;
1073    }
1074    
1075    =head2 Internal Utility Methods
1076    
1077    =head3 _KeywordString
1078    
1079    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
1080    
1081    Compute the keyword string for a specified key/value pair. This consists of the
1082    key name and value converted to lower case with underscores translated to spaces.
1083    
1084    This method is for internal use only. It is called whenever we need to update or
1085    insert a B<HasValueFor> record.
1086    
1087    =over 4
1088    
1089    =item key
1090    
1091    Name of the relevant attribute key.
1092    
1093    =item target
1094    
1095    ID of the target object to which this key/value pair will be associated.
1096    
1097    =item value
1098    
1099    The value to store for this key/object combination.
1100    
1101    =item RETURN
1102    
1103    Returns the value that should be stored as the keyword string for the specified
1104    key/value pair.
1105    
1106    =back
1107    
1108    =cut
1109    
1110    sub _KeywordString {
1111        # Get the parameters.
1112        my ($self, $key, $value) = @_;
1113        # Get a copy of the key name and convert underscores to spaces.
1114        my $keywordString = $key;
1115        $keywordString =~ s/_/ /g;
1116        # Add the value convert it all to lower case.
1117        my $retVal = lc "$keywordString $value";
1118        # Return the result.
1119        return $retVal;
1120    }
1121    
1122    =head3 _QueryResults
1123    
1124    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1125    
1126    Match the results of a B<HasValueFor> query against value criteria and return
1127    the results. This is an internal method that splits the values coming back
1128    and matches the sections against the specified section patterns. It serves
1129    as the back end to L</GetAttributes> and L</FindAttributes>.
1130    
1131    =over 4
1132    
1133    =item query
1134    
1135    A query object that will return the desired B<HasValueFor> records.
1136    
1137    =item values
1138    
1139    List of the desired attribute values, section by section. If C<undef>
1140    or an empty string is specified, all values in that section will match. A
1141    generic match can be requested by placing a percent sign (C<%>) at the end.
1142    In that case, all values that match up to and not including the percent sign
1143    will match. You may also specify a regular expression enclosed
1144    in slashes. All values that match the regular expression will be returned. For
1145    performance reasons, only values have this extra capability.
1146    
1147    =item RETURN
1148    
1149    Returns a list of tuples. The first element in the tuple is an object ID, the
1150    second is an attribute key, and the remaining elements are the sections of
1151    the attribute value. All of the tuples will match the criteria set forth in
1152    the parameter list.
1153    
1154    =back
1155    
1156    =cut
1157    
1158    sub _QueryResults {
1159        # Get the parameters.
1160        my ($self, $query, @values) = @_;
1161        # Declare the return value.
1162        my @retVal = ();
1163        # Get the number of value sections we have to match.
1164        my $sectionCount = scalar(@values);
1165        # Loop through the assignments found.
1166        while (my $row = $query->Fetch()) {
1167            # Get the current row's data.
1168            my ($id, $realKey, $subKey, $valueString) = $row->Values(['HasValueFor(to-link)',
1169                                                                      'HasValueFor(from-link)',
1170                                                                      'HasValueFor(subkey)',
1171                                                                      'HasValueFor(value)'
1172                                                                    ]);
1173            # Form the key from the real key and the sub key.
1174            my $key = $self->JoinKey($realKey, $subKey);
1175            # Break the value into sections.
1176            my @sections = split($self->{splitter}, $valueString);
1177            # Match each section against the incoming values. We'll assume we're
1178            # okay unless we learn otherwise.
1179            my $matching = 1;
1180            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1181                # We need to check to see if this section is generic.
1182                my $value = $values[$i];
1183                Trace("Current value pattern is \"$value\".") if T(4);
1184                if (substr($value, -1, 1) eq '%') {
1185                    Trace("Generic match used.") if T(4);
1186                    # Here we have a generic match.
1187                    my $matchLen = length($values[$i]) - 1;
1188                    $matching = substr($sections[$i], 0, $matchLen) eq
1189                                substr($values[$i], 0, $matchLen);
1190                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1191                    Trace("Regular expression detected.") if T(4);
1192                    # Here we have a regular expression match.
1193                    my $section = $sections[$i];
1194                    $matching = eval("\$section =~ $value");
1195                } else {
1196                    # Here we have a strict match.
1197                    Trace("Strict match used.") if T(4);
1198                    $matching = ($sections[$i] eq $values[$i]);
1199                }
1200            }
1201            # If we match, output this row to the return list.
1202            if ($matching) {
1203                push @retVal, [$id, $key, @sections];
1204            }
1205        }
1206        # Return the rows found.
1207        return @retVal;
1208    }
1209    
1210    =head2 FIG Method Replacements
1211    
1212    The following methods are used by B<FIG.pm> to replace the previous attribute functionality.
1213    Some of the old functionality is no longer present: controlled vocabulary is no longer
1214    supported and there is no longer any searching by URL. Fortunately, neither of these
1215    capabilities were used in the old system.
1216    
1217    The methods here are the only ones supported by the B<RemoteCustomAttributes> object.
1218    The idea is that these methods represent attribute manipulation allowed by all users, while
1219    the others are only for privileged users with access to the attribute server.
1220    
1221    In the previous implementation, an attribute had a value and a URL. In this implementation,
1222    each attribute has only a value. These methods will treat the value as a list with the individual
1223    elements separated by the value of the splitter parameter on the constructor (L</new>). The default
1224    is double colons C<::>.
1225    
1226    So, for example, an old-style keyword with a value of C<essential> and a URL of
1227    C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default
1228    splitter value would be stored as
1229    
1230        essential::http://www.sciencemag.org/cgi/content/abstract/293/5538/2266
1231    
1232    The best performance is achieved by searching for a particular key for a specified
1233    feature or genome.
1234    
1235    =head3 GetAttributes
1236    
1237    C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @values); >>
1238    
1239    In the database, attribute values are sectioned into pieces using a splitter
1240    value specified in the constructor (L</new>). This is not a requirement of
1241    the attribute system as a whole, merely a convenience for the purpose of
1242    these methods. If a value has multiple sections, each section
1243    is matched against the corresponding criterion in the I<@valuePatterns> list.
1244    
1245    This method returns a series of tuples that match the specified criteria. Each tuple
1246    will contain an object ID, a key, and one or more values. The parameters to this
1247    method therefore correspond structurally to the values expected in each tuple. In
1248    addition, you can ask for a generic search by suffixing a percent sign (C<%>) to any
1249    of the parameters. So, for example,
1250    
1251        my @attributeList = $attrDB->GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);
1252    
1253    would return something like
1254    
1255        ['fig}100226.1.peg.1004', 'structure', 1, 2]
1256        ['fig}100226.1.peg.1004', 'structure1', 1, 2]
1257        ['fig}100226.1.peg.1004', 'structure2', 1, 2]
1258        ['fig}100226.1.peg.1004', 'structureA', 1, 2]
1259    
1260    Use of C<undef> in any position acts as a wild card (all values). You can also specify
1261    a list reference in the ID column. Thus,
1262    
1263        my @attributeList = $attrDB->GetAttributes(['100226.1', 'fig|100226.1.%'], 'PUBMED');
1264    
1265    would get the PUBMED attribute data for Streptomyces coelicolor A3(2) and all its
1266    features.
1267    
1268    In addition to values in multiple sections, a single attribute key can have multiple
1269    values, so even
1270    
1271        my @attributeList = $attrDB->GetAttributes($peg, 'virulent');
1272    
1273    which has no wildcard in the key or the object ID, may return multiple tuples.
1274    
1275    Value matching in this system works very poorly, because of the way multiple values are
1276    stored. For the object ID, key name, and first value, we create queries that filter for the
1277    desired results. On any filtering by value, we must do a comparison after the attributes are
1278    retrieved from the database, since the database has no notion of the multiple values, which
1279    are stored in a single string. As a result, queries in which filter only on value end up
1280    reading a lot more than they need to.
1281    
1282  =over 4  =over 4
1283    
1284  =item objectID  =item objectID
1285    
1286  ID of the genome or feature whose attributes are desired. In general, an ID that  ID of object whose attributes are desired. If the attributes are desired for multiple
1287  starts with C<fig|> is treated as a feature ID, and an ID that is all digits with a  objects, this parameter can be specified as a list reference. If the attributes are
1288  single period is treated as a genome ID. For other entity types, use a list reference; in  desired for all objects, specify C<undef> or an empty string. Finally, you can specify
1289  this case the first list element is the entity type and the second is the ID. A value of  attributes for a range of object IDs by putting a percent sign (C<%>) at the end.
 C<undef> here will match all objects.  
1290    
1291  =item key  =item key
1292    
1293  Attribute key name. Since attributes are stored as fields in the database with a  Attribute key name. A value of C<undef> or an empty string will match all
1294  field name equal to the key name, it is very fast to find a list of all the  attribute keys. If the values are desired for multiple keys, this parameter can be
1295  matching keys. Each key's values require a separate query, however, which may  specified as a list reference. Finally, you can specify attributes for a range of
1296  be a performance problem if the pattern matches a lot of keys. Wild cards are  keys by putting a percent sign (C<%>) at the end.
 acceptable here, and a value of C<undef> will match all attribute keys.  
1297    
1298  =item valuePatterns  =item values
1299    
1300  List of the desired attribute values, section by section. If C<undef>  List of the desired attribute values, section by section. If C<undef>
1301  is specified, all values in that section will match.  or an empty string is specified, all values in that section will match. A
1302    generic match can be requested by placing a percent sign (C<%>) at the end.
1303    In that case, all values that match up to and not including the percent sign
1304    will match. You may also specify a regular expression enclosed
1305    in slashes. All values that match the regular expression will be returned. For
1306    performance reasons, only values have this extra capability.
1307    
1308  =item RETURN  =item RETURN
1309    
# Line 1056  Line 1317 
1317  =cut  =cut
1318    
1319  sub GetAttributes {  sub GetAttributes {
1320      # Connect to the database. The tricky part is knowing whether or not we      # Get the parameters.
1321      # are an instance method (in which case the first parameter is a      my ($self, $objectID, $key, @values) = @_;
1322      # CustomAttributes object) or a static method (in which case we must      # This hash will map "HasValueFor" fields to patterns. We use it to build the
1323      # connect manually.      # SQL statement.
1324      my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());      my %data;
1325      # Get the remaining parameters.      # Before we do anything else, we must parse the key. The key is treated by the
1326      my ($objectID, $key, @valuePatterns) = @_;      # user as a single field, but to us it's actually a real key and a subkey.
1327      # Declare the return variable.      # If the key has no splitter and is exact, the real key is the original key
1328      my @retVal = ();      # and the subkey is an empty string. If the key has a splitter, it is
1329      # Determine the entity types for our search.      # split into two pieces and each piece is processed separately. If the key has
1330      my @objects = ();      # no splitter and is generic, the real key is the incoming key and the subkey
1331      my ($actualObjectID, $computedType);      # is allowed to be wild. Of course, this only matters if an actual key has
1332      if (! defined($objectID)) {      # been specified.
1333          push @objects, $self->GetEntityTypes();      if (defined $key) {
1334            if ($key =~ /$self->{splitter}/) {
1335                # Here we have a two-part key, so we split it normally.
1336                my ($realKey, $subKey) = $self->SplitKey($key);
1337                $data{'HasValueFor(from-link)'} = $realKey;
1338                $data{'HasValueFor(subkey)'} = $subKey;
1339            } elsif (substr($key, -1, 1) eq '%') {
1340                $data{'HasValueFor(from-link)'} = $key;
1341            } else {
1342                $data{'HasValueFor(from-link)'} = $key;
1343                $data{'HasValueFor(subkey)'} = '';
1344            }
1345        }
1346        # Add the object ID to the key information.
1347        $data{'HasValueFor(to-link)'} = $objectID;
1348        # The first value represents a problem, because we can search it using SQL, but not
1349        # in the normal way. If the user specifies a generic search or exact match for
1350        # every alternative value (remember, the values may be specified as a list),
1351        # then we can create SQL filtering for it. If any of the values are specified
1352        # as a regular expression, however, that's a problem, because we need to read
1353        # every value to verify a match.
1354        if (@values > 0) {
1355            # Get the first value and put its alternatives in an array.
1356            my $valueParm = $values[0];
1357            my @valueList;
1358            if (ref $valueParm eq 'ARRAY') {
1359                @valueList = @{$valueParm};
1360      } else {      } else {
1361          ($computedType, $actualObjectID) = ComputeObjectTypeFromID($objectID);              @valueList = ($valueParm);
         push @objects, $computedType;  
1362      }      }
1363      # Loop through the entity types.          # Okay, now we have all the possible criteria for the first value in the list
1364      for my $entityType (@objects) {          # @valueList. We'll copy the values to a new array in which they have been
1365          # Now we need to find all the matching keys. The keys are actually stored in          # converted to generic requests. If we find a regular-expression match
1366          # our database object, so this process is fast. Note that our          # anywhere in the list, we toss the whole thing.
1367          # MatchSqlPattern method          my @valuePatterns = ();
1368          my %secondaries = $self->GetSecondaryFields($entityType);          my $okValues = 1;
1369          my @fieldList = grep { MatchSqlPattern($_, $key) } keys %secondaries;          for my $valuePattern (@valueList) {
1370          # Now we figure out whether or not we need to filter by object.              # Check the pattern type.
1371          my $filter = "";              if (substr($valuePattern, 0, 1) eq '/') {
1372          my @params = ();                  # Regular expressions invalidate the entire process.
1373          if (defined($actualObjectID)) {                  $okValues = 0;
1374              # Here the caller wants to filter on object ID.              } elsif (substr($valuePattern, -1, 1) eq '%') {
1375              $filter = "$entityType(id) = ?";                  # A Generic pattern is passed in unmodified.
1376              push @params, $actualObjectID;                  push @valuePatterns, $valuePattern;
1377          }              } else {
1378          # It's time to begin making queries. We process one attribute key at a time, because                  # An exact match is converted to generic.
1379          # each attribute is actually a different field in the database. We know here that                  push @valuePatterns, "$valuePattern%";
         # all the keys we've collected are for the correct entity because we got them from  
         # the DBD. That's a good thing, because an invalid key name will cause an SQL error.  
         for my $key (@fieldList) {  
             # Get all of the attribute values for this key.  
             my @dataRows = $self->GetAll([$entityType], $filter, \@params,  
                                          ["$entityType(id)", "$entityType($key)"]);  
             # Process each value separately. We need to verify the values and reformat the  
             # tuples. Note that GetAll will give us one row per matching object ID,  
             # with the ID first followed by a list of the data values. This is very  
             # different from the structure we'll be returning, which has one row  
             # per value.  
             for my $dataRow (@dataRows) {  
                 # Get the object ID and the list of values.  
                 my ($rowObjectID, @dataValues) = @{$dataRow};  
                 # Loop through the values. There will be one result row per attribute value.  
                 for my $dataValue (@dataValues) {  
                     # Separate this value into sections.  
                     my @sections = split("::", $dataValue);  
                     # Loop through the value patterns, looking for a mismatch. Note that  
                     # since we're working through parallel arrays, we are using an index  
                     # loop. As soon as a match fails we stop checking. This means that  
                     # if the value pattern list is longer than the number of sections,  
                     # we will fail as soon as we run out of sections.  
                     my $match = 1;  
                     for (my $i = 0; $i <= $#valuePatterns && $match; $i++) {  
                         $match = MatchSqlPattern($sections[$i], $valuePatterns[$i]);  
                     }  
                     # If we match, we save this value in the output list.  
                     if ($match) {  
                         push @retVal, [$rowObjectID, $key, @sections];  
                     }  
                 }  
                 # Here we've processed all the attribute values for the current object ID.  
1380              }              }
             # Here we've processed all the rows returned by GetAll. In general, there will  
             # be one row per object ID.  
1381          }          }
1382          # Here we've processed all the matching attribute keys.          # If everything works, add the value data to the filtering hash.
1383            if ($okValues) {
1384                $data{'HasValueFor(value)'} = \@valuePatterns;
1385            }
1386        }
1387        # Create some lists to contain the filter fragments and parameter values.
1388        my @filter = ();
1389        my @parms = ();
1390        # This next loop goes through the different fields that can be specified in the
1391        # parameter list and generates filters for each. The %data hash that we built above
1392        # contains all the necessary information to do this.
1393        for my $field (keys %data) {
1394            # Accumulate filter information for this field. We will OR together all the
1395            # elements accumulated to create the final result.
1396            my @fieldFilter = ();
1397            # Get the specified data from the caller.
1398            my $fieldPattern = $data{$field};
1399            # Only proceed if the pattern is one that won't match everything.
1400            if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {
1401                # Convert the pattern to an array.
1402                my @patterns = ();
1403                if (ref $fieldPattern eq 'ARRAY') {
1404                    push @patterns, @{$fieldPattern};
1405                } else {
1406                    push @patterns, $fieldPattern;
1407      }      }
1408      # Here we've processed all the entity types. That means @retVal has all the matching              # Only proceed if the array is nonempty. The loop will work fine if the
1409      # results.              # array is empty, but when we build the filter string at the end we'll
1410                # get "()" in the filter list, which will result in an SQL syntax error.
1411                if (@patterns) {
1412                    # Loop through the individual patterns.
1413                    for my $pattern (@patterns) {
1414                        # Check for a generic request.
1415                        if (substr($pattern, -1, 1) ne '%') {
1416                            # Here we have a normal request.
1417                            push @fieldFilter, "$field = ?";
1418                            push @parms, $pattern;
1419                        } else {
1420                            # Here we have a generic request, so we will use the LIKE operator to
1421                            # filter the field to this value pattern.
1422                            push @fieldFilter, "$field LIKE ?";
1423                            # We must convert the pattern value to an SQL match pattern. First
1424                            # we get a copy of it.
1425                            my $actualPattern = $pattern;
1426                            # Now we escape the underscores. Underscores are an SQL wild card
1427                            # character, but they are used frequently in key names and object IDs.
1428                            $actualPattern =~ s/_/\\_/g;
1429                            # Add the escaped pattern to the bound parameter list.
1430                            push @parms, $actualPattern;
1431                        }
1432                    }
1433                    # Form the filter for this field.
1434                    my $fieldFilterString = join(" OR ", @fieldFilter);
1435                    push @filter, "($fieldFilterString)";
1436                }
1437            }
1438        }
1439        # Now @filter contains one or more filter strings and @parms contains the parameter
1440        # values to bind to them.
1441        my $actualFilter = join(" AND ", @filter);
1442        # Now we're ready to make our query.
1443        my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1444        # Format the results.
1445        my @retVal = $self->_QueryResults($query, @values);
1446        # Return the rows found.
1447      return @retVal;      return @retVal;
1448  }  }
1449    
# Line 1139  Line 1451 
1451    
1452  C<< $attrDB->AddAttribute($objectID, $key, @values); >>  C<< $attrDB->AddAttribute($objectID, $key, @values); >>
1453    
 or  
   
 C<< AddAttribute($objectID, $key, @values); >>  
   
1454  Add an attribute key/value pair to an object. This method cannot add a new key, merely  Add an attribute key/value pair to an object. This method cannot add a new key, merely
1455  add a value to an existing key. Use L</StoreAttributeKey> to create a new key.  add a value to an existing key. Use L</StoreAttributeKey> to create a new key.
1456    
 The first form will connect to the database and release it. The second form  
 uses the database connection contained in the object.  
   
1457  =over 4  =over 4
1458    
1459  =item objectID  =item objectID
1460    
1461  ID of the genome or feature to which the attribute is to be added. In general, an ID that  ID of the object to which the attribute is to be added.
 starts with C<fig|> is treated as a feature ID, and an ID that is all digits and periods  
 is treated as a genome ID. For IDs of other types, this parameter should be a reference  
 to a 2-tuple consisting of the entity type name followed by the object ID.  
1462    
1463  =item key  =item key
1464    
1465  Attribute key name. This corresponds to the name of a field in the database.  Attribute key name.
1466    
1467  =item values  =item values
1468    
# Line 1173  Line 1475 
1475  =cut  =cut
1476    
1477  sub AddAttribute {  sub AddAttribute {
     # Connect to the database. The tricky part is knowing whether or not we  
     # are an instance method (in which case the first parameter is a  
     # CustomAttributes object) or a static method (in which case we must  
     # connect manually.  
     my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());  
1478      # Get the parameters.      # Get the parameters.
1479      my ($objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1480      # Don't allow undefs.      # Don't allow undefs.
1481      if (! defined($objectID)) {      if (! defined($objectID)) {
1482          Confess("No object ID specified for AddAttribute call.");          Confess("No object ID specified for AddAttribute call.");
# Line 1188  Line 1485 
1485      } elsif (! @values) {      } elsif (! @values) {
1486          Confess("No values specified in AddAttribute call for key $key.");          Confess("No values specified in AddAttribute call for key $key.");
1487      } else {      } else {
1488          # Okay, now we have some reason to believe we can do this. Start by          # Okay, now we have some reason to believe we can do this. Form the values
1489          # computing the object type and ID.          # into a scalar.
         my ($entityName, $id) = ComputeObjectTypeFromID($objectID);  
         # Form the values into a scalar.  
1490          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1491          # Insert the value.          # Split up the key.
1492          $self->InsertValue($id, "$entityName($key)", $valueString);          my ($realKey, $subKey) = $self->SplitKey($key);
1493            # Connect the object to the key.
1494            $self->InsertObject('HasValueFor', { 'from-link' => $realKey,
1495                                                 'to-link'   => $objectID,
1496                                                 'subkey'    => $subKey,
1497                                                 'value'     => $valueString,
1498                                           });
1499      }      }
1500      # Return a one. We do this for backward compatability.      # Return a one, indicating success. We do this for backward compatability.
1501      return 1;      return 1;
1502  }  }
1503    
# Line 1204  Line 1505 
1505    
1506  C<< $attrDB->DeleteAttribute($objectID, $key, @values); >>  C<< $attrDB->DeleteAttribute($objectID, $key, @values); >>
1507    
 or  
   
 C<< DeleteAttribute($objectID, $key, @values); >>  
   
1508  Delete the specified attribute key/value combination from the database.  Delete the specified attribute key/value combination from the database.
1509    
 The first form will connect to the database and release it. The second form  
 uses the database connection contained in the object.  
   
1510  =over 4  =over 4
1511    
1512  =item objectID  =item objectID
1513    
1514  ID of the genome or feature to which the attribute is to be added. In general, an ID that  ID of the object whose attribute is to be deleted.
 starts with C<fig|> is treated as a feature ID, and an ID that is all digits and periods  
 is treated as a genome ID. For IDs of other types, this parameter should be a reference  
 to a 2-tuple consisting of the entity type name followed by the object ID.  
1515    
1516  =item key  =item key
1517    
1518  Attribute key name. This corresponds to the name of a field in the database.  Attribute key name.
1519    
1520  =item values  =item values
1521    
1522  One or more values to be associated with the key.  One or more values associated with the key. If no values are specified, then all values
1523    will be deleted. Otherwise, only a matching value will be deleted.
1524    
1525  =back  =back
1526    
1527  =cut  =cut
1528    
1529  sub DeleteAttribute {  sub DeleteAttribute {
     # Connect to the database. The tricky part is knowing whether or not we  
     # are an instance method (in which case the first parameter is a  
     # CustomAttributes object) or a static method (in which case we must  
     # connect manually.  
     my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());  
1530      # Get the parameters.      # Get the parameters.
1531      my ($objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1532      # Don't allow undefs.      # Don't allow undefs.
1533      if (! defined($objectID)) {      if (! defined($objectID)) {
1534          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1535      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1536          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
     } elsif (! @values) {  
         Confess("No values specified in DeleteAttribute call for key $key.");  
1537      } else {      } else {
1538          # Now compute the object type and ID.          # Split the key into the real key and the subkey.
1539          my ($entityName, $id) = ComputeObjectTypeFromID($objectID);          my ($realKey, $subKey) = $self->SplitKey($key);
1540          # Form the values into a scalar.          if ($subKey eq '' && scalar(@values) == 0) {
1541                # Here we erase the entire key for this object.
1542                $self->DeleteRow('HasValueFor', $key, $objectID);
1543            } else {
1544                # Here we erase the matching values.
1545          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1546          # Delete the value.              $self->DeleteRow('HasValueFor', $realKey, $objectID,
1547          $self->DeleteValue($entityName, $id, $key, $valueString);                               { subkey => $subKey, value => $valueString });
1548            }
1549      }      }
1550      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1551      return 1;      return 1;
1552  }  }
1553    
1554  =head3 ComputeObjectTypeFromID  =head3 DeleteMatchingAttributes
1555    
1556  C<< my ($entityName, $id) = CustomAttributes::ComputeObjectTypeFromID($objectID); >>  C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1557    
1558  This method will compute the entity type corresponding to a specified object ID.  Delete all attributes that match the specified criteria. This is equivalent to
1559  If the object ID begins with C<fig|>, it is presumed to be a feature ID. If it  calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1560  is all digits with a single period, it is presumed to by a genome ID. Otherwise,  row found.
 it must be a list reference. In this last case the first list element will be  
 taken as the entity type and the second will be taken as the actual ID.  
1561    
1562  =over 4  =over 4
1563    
1564  =item objectID  =item objectID
1565    
1566  Object ID to examine.  ID of object whose attributes are to be deleted. If the attributes for multiple
1567    objects are to be deleted, this parameter can be specified as a list reference. If
1568    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1569    Finally, you can delete attributes for a range of object IDs by putting a percent
1570    sign (C<%>) at the end.
1571    
1572    =item key
1573    
1574    Attribute key name. A value of C<undef> or an empty string will match all
1575    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1576    specified as a list reference. Finally, you can delete attributes for a range of
1577    keys by putting a percent sign (C<%>) at the end.
1578    
1579    =item values
1580    
1581    List of the desired attribute values, section by section. If C<undef>
1582    or an empty string is specified, all values in that section will match. A
1583    generic match can be requested by placing a percent sign (C<%>) at the end.
1584    In that case, all values that match up to and not including the percent sign
1585    will match. You may also specify a regular expression enclosed
1586    in slashes. All values that match the regular expression will be deleted. For
1587    performance reasons, only values have this extra capability.
1588    
1589  =item RETURN  =item RETURN
1590    
1591  Returns a 2-element list consisting of the entity type followed by the specified ID.  Returns a list of tuples for the attributes that were deleted, in the
1592    same form as L</GetAttributes>.
1593    
1594  =back  =back
1595    
1596  =cut  =cut
1597    
1598  sub ComputeObjectTypeFromID {  sub DeleteMatchingAttributes {
1599      # Get the parameters.      # Get the parameters.
1600      my ($objectID) = @_;      my ($self, $objectID, $key, @values) = @_;
1601      # Declare the return variables.      # Get the matching attributes.
1602      my ($entityName, $id);      my @retVal = $self->GetAttributes($objectID, $key, @values);
1603      # Only proceed if the object ID is defined. If it's not, we'll be returning a      # Loop through the attributes, deleting them.
1604      # pair of undefs.      for my $tuple (@retVal) {
1605      if (defined($objectID)) {          $self->DeleteAttribute(@{$tuple});
1606          if (ref $objectID eq 'ARRAY') {      }
1607              # Here we have the new-style list reference. Pull out its pieces.      # Log this operation.
1608              ($entityName, $id) = @{$objectID};      my $count = @retVal;
1609          } else {      $self->LogOperation("Mass Delete", $key, "$count matching attributes deleted.");
1610              # Here the ID is the outgoing ID, and we need to look at its structure      # Return the deleted attributes.
1611              # to determine the entity type.      return @retVal;
             $id = $objectID;  
             if ($objectID =~ /^\d+\.\d+/) {  
                 # Digits with a single period is a genome.  
                 $entityName = 'Genome';  
             } elsif ($objectID =~ /^fig\|/) {  
                 # The "fig|" prefix indicates a feature.  
                 $entityName = 'Feature';  
             } else {  
                 # Anything else is illegal!  
                 Confess("Invalid attribute ID specification \"$objectID\".");  
             }  
         }  
     }  
     # Return the result.  
     return ($entityName, $id);  
1612  }  }
1613    
1614  =head3 ChangeAttribute  =head3 ChangeAttribute
1615    
1616  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
1617    
 or  
   
 C<< ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  
   
1618  Change the value of an attribute key/value pair for an object.  Change the value of an attribute key/value pair for an object.
1619    
 The first form will connect to the database and release it. The second form  
 uses the database connection contained in the object.  
   
1620  =over 4  =over 4
1621    
1622  =item objectID  =item objectID
# Line 1355  Line 1643 
1643  =cut  =cut
1644    
1645  sub ChangeAttribute {  sub ChangeAttribute {
     # Connect to the database. The tricky part is knowing whether or not we  
     # are an instance method (in which case the first parameter is a  
     # CustomAttributes object) or a static method (in which case we must  
     # connect manually.  
     my $self = (UNIVERSAL::isa($_[0],__PACKAGE__) ? shift @_ : CustomAttributes->new());  
1646      # Get the parameters.      # Get the parameters.
1647      my ($objectID, $key, $oldValues, $newValues) = @_;      my ($self, $objectID, $key, $oldValues, $newValues) = @_;
1648      # Don't allow undefs.      # Don't allow undefs.
1649      if (! defined($objectID)) {      if (! defined($objectID)) {
1650          Confess("No object ID specified for ChangeAttribute call.");          Confess("No object ID specified for ChangeAttribute call.");
# Line 1372  Line 1655 
1655      } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {      } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {
1656          Confess("No new values specified in ChangeAttribute call for key $key.");          Confess("No new values specified in ChangeAttribute call for key $key.");
1657      } else {      } else {
1658          # Okay, now we do the change as a delete/add.          # We do the change as a delete/add.
1659          $self->DeleteAttribute($objectID, $key, @{$oldValues});          $self->DeleteAttribute($objectID, $key, @{$oldValues});
1660          $self->AddAttribute($objectID, $key, @{$newValues});          $self->AddAttribute($objectID, $key, @{$newValues});
1661      }      }
# Line 1380  Line 1663 
1663      return 1;      return 1;
1664  }  }
1665    
1666    =head3 EraseAttribute
1667    
1668    C<< $attrDB->EraseAttribute($key); >>
1669    
1670    Erase all values for the specified attribute key. This does not remove the
1671    key from the database; it merely removes all the values.
1672    
1673    =over 4
1674    
1675    =item key
1676    
1677    Key to erase. This must be a real key; that is, it cannot have a subkey
1678    component.
1679    
1680    =back
1681    
1682    =cut
1683    
1684    sub EraseAttribute {
1685        # Get the parameters.
1686        my ($self, $key) = @_;
1687        # Delete everything connected to the key.
1688        $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1689        # Log the operation.
1690        $self->LogOperation("Erase Data", $key);
1691        # Return a 1, for backward compatability.
1692        return 1;
1693    }
1694    
1695    =head3 GetAttributeKeys
1696    
1697    C<< my @keyList = $attrDB->GetAttributeKeys($groupName); >>
1698    
1699    Return a list of the attribute keys for a particular group.
1700    
1701    =over 4
1702    
1703    =item groupName
1704    
1705    Name of the group whose keys are desired.
1706    
1707    =item RETURN
1708    
1709    Returns a list of the attribute keys for the specified group.
1710    
1711    =back
1712    
1713    =cut
1714    
1715    sub GetAttributeKeys {
1716        # Get the parameters.
1717        my ($self, $groupName) = @_;
1718        # Get the attributes for the specified group.
1719        my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(to-link) = ?", [$groupName],
1720                                    'IsInGroup(from-link)');
1721        # Return the keys.
1722        return sort @groups;
1723    }
1724    
1725    =head2 Key and ID Manipulation Methods
1726    
1727    =head3 ParseID
1728    
1729    C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>
1730    
1731    Determine the type and object ID corresponding to an ID value from the attribute database.
1732    Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);
1733    however, Genomes, Features, and Subsystems are not stored with a type name, so we need to
1734    deduce the type from the ID value structure.
1735    
1736    The theory here is that you can plug the ID and type directly into a Sprout database method, as
1737    follows
1738    
1739        my ($type, $id) = CustomAttributes::ParseID($attrList[$num]->[0]);
1740        my $target = $sprout->GetEntity($type, $id);
1741    
1742    =over 4
1743    
1744    =item idValue
1745    
1746    ID value taken from the attribute database.
1747    
1748    =item RETURN
1749    
1750    Returns a two-element list. The first element is the type of object indicated by the ID value,
1751    and the second element is the actual object ID.
1752    
1753    =back
1754    
1755    =cut
1756    
1757    sub ParseID {
1758        # Get the parameters.
1759        my ($idValue) = @_;
1760        # Declare the return variables.
1761        my ($type, $id);
1762        # Parse the incoming ID. We first check for the presence of an entity name. Entity names
1763        # can only contain letters, which helps to insure typed object IDs don't collide with
1764        # subsystem names (which are untyped).
1765        if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1766            # Here we have a typed ID.
1767            ($type, $id) = ($1, $2);
1768        } elsif ($idValue =~ /fig\|/) {
1769            # Here we have a feature ID.
1770            ($type, $id) = (Feature => $idValue);
1771        } elsif ($idValue =~ /\d+\.\d+/) {
1772            # Here we have a genome ID.
1773            ($type, $id) = (Genome => $idValue);
1774        } else {
1775            # The default is a subsystem ID.
1776            ($type, $id) = (Subsystem => $idValue);
1777        }
1778        # Return the results.
1779        return ($type, $id);
1780    }
1781    
1782    =head3 FormID
1783    
1784    C<< my $idValue = CustomAttributes::FormID($type, $id); >>
1785    
1786    Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,
1787    genomes, and features are stored in the database without type information, but all other object IDs
1788    must be prefixed with the object type.
1789    
1790    =over 4
1791    
1792    =item type
1793    
1794    Relevant object type.
1795    
1796    =item id
1797    
1798    ID of the object in question.
1799    
1800    =item RETURN
1801    
1802    Returns a string that will be recognized as an object ID in the attribute database.
1803    
1804    =back
1805    
1806    =cut
1807    
1808    sub FormID {
1809        # Get the parameters.
1810        my ($type, $id) = @_;
1811        # Declare the return variable.
1812        my $retVal;
1813        # Compute the ID string from the type.
1814        if (grep { $type eq $_ } qw(Feature Genome Subsystem)) {
1815            $retVal = $id;
1816        } else {
1817            $retVal = "$type:$id";
1818        }
1819        # Return the result.
1820        return $retVal;
1821    }
1822    
1823    =head3 GetTargetObject
1824    
1825    C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>
1826    
1827    Return the database object corresponding to the specified attribute object ID. The
1828    object type associated with the ID value must correspond to an entity name in the
1829    specified database.
1830    
1831    =over 4
1832    
1833    =item erdb
1834    
1835    B<ERDB> object for accessing the target database.
1836    
1837    =item idValue
1838    
1839    ID value retrieved from the attribute database.
1840    
1841    =item RETURN
1842    
1843    Returns a B<DBObject> for the attribute value's target object.
1844    
1845    =back
1846    
1847    =cut
1848    
1849    sub GetTargetObject {
1850        # Get the parameters.
1851        my ($erdb, $idValue) = @_;
1852        # Declare the return variable.
1853        my $retVal;
1854        # Get the type and ID for the target object.
1855        my ($type, $id) = ParseID($idValue);
1856        # Plug them into the GetEntity method.
1857        $retVal = $erdb->GetEntity($type, $id);
1858        # Return the resulting object.
1859        return $retVal;
1860    }
1861    
1862    =head3 SplitKey
1863    
1864    C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>
1865    
1866    Split an external key (that is, one passed in by a caller) into the real key and the sub key.
1867    The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,
1868    then the sub key is presumed to be an empty string.
1869    
1870    =over 4
1871    
1872    =item key
1873    
1874    Incoming key to be split.
1875    
1876    =item RETURN
1877    
1878    Returns a two-element list, the first element of which is the real key and the second element of
1879    which is the sub key.
1880    
1881    =back
1882    
1883    =cut
1884    
1885    sub SplitKey {
1886        # Get the parameters.
1887        my ($self, $key) = @_;
1888        # Do the split.
1889        my ($realKey, $subKey) = split($self->{splitter}, $key, 2);
1890        # Insure the subkey has a value.
1891        if (! defined $subKey) {
1892            $subKey = '';
1893        }
1894        # Return the results.
1895        return ($realKey, $subKey);
1896    }
1897    
1898    =head3 JoinKey
1899    
1900    C<< my $key = $ca->JoinKey($realKey, $subKey); >>
1901    
1902    Join a real key and a subkey together to make an external key. The external key is the attribute key
1903    used by the caller. The real key and the subkey are how the keys are represented in the database. The
1904    real key is the key to the B<AttributeKey> entity. The subkey is an attribute of the B<HasValueFor>
1905    relationship.
1906    
1907    =over 4
1908    
1909    =item realKey
1910    
1911    The real attribute key.
1912    
1913    =item subKey
1914    
1915    The subordinate portion of the attribute key.
1916    
1917    =item RETURN
1918    
1919    Returns a single string representing both keys.
1920    
1921    =back
1922    
1923    =cut
1924    
1925    sub JoinKey {
1926        # Get the parameters.
1927        my ($self, $realKey, $subKey) = @_;
1928        # Declare the return variable.
1929        my $retVal;
1930        # Check for a subkey.
1931        if ($subKey eq '') {
1932            # No subkey, so the real key is the key.
1933            $retVal = $realKey;
1934        } else {
1935            # Subkey found, so the two pieces must be joined by a splitter.
1936            $retVal = "$realKey$self->{splitter}$subKey";
1937        }
1938        # Return the result.
1939        return $retVal;
1940    }
1941    
1942  1;  1;

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.21

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3