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

Legend:
Removed from v.1.9  
changed lines
  Added in v.1.23

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3