[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.17, Thu Jan 25 02:41:12 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  The full suite of ERDB retrieval capabilities is provided. In addition,  The full suite of ERDB retrieval capabilities is provided. In addition,
32  custom methods are provided specific to this application. To get all  custom methods are provided specific to this application. To get all
33  the values of the attribute C<essential> in a specified B<Feature>, you  the values of the attribute C<essential> in a specified B<Feature>, you
34  would code  would code
35    
36      my @values = $attrDB->GetAttributes([Feature => $fid], 'essential');      my @values = $attrDB->GetAttributes($fid, 'essential');
37    
38  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.  
39    
40  New attributes are introduced by updating the database definition at  New attribute keys must be defined before they can be used. A web interface
41  run-time. Attribute values are stored by uploading data from files.  is provided for this purpose.
 A web interface is provided for both these activities.  
42    
43  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
44    
# Line 76  Line 84 
84    
85  =back  =back
86    
 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.  
   
87  =head2 Public Methods  =head2 Public Methods
88    
89  =head3 new  =head3 new
90    
91  C<< my $attrDB = CustomAttributes->new($splitter); >>  C<< my $attrDB = CustomAttributes->new($splitter); >>
92    
93  Construct a new CustomAttributes object. This object cannot be used to add or  Construct a new CustomAttributes object.
 delete keys because that requires modifying the database design. To do that,  
 you need to use the static L</StoreAttributeKey> or L</DeleteAttributeKey>  
 methods.  
94    
95  =over 4  =over 4
96    
# Line 159  Line 124 
124    
125  =head3 StoreAttributeKey  =head3 StoreAttributeKey
126    
127  C<< my $attrDB = CustomAttributes::StoreAttributeKey($entityName, $attributeName, $type, $notes); >>  C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>
128    
129  Create or update an attribute for the database. This method will update the database definition  Create or update an attribute for the database.
 XML, but it will not create the table. It will connect to the database so that the caller  
 can upload the attribute values.  
130    
131  =over 4  =over 4
132    
 =item entityName  
   
 Name of the entity containing the attribute. The entity must exist.  
   
133  =item attributeName  =item attributeName
134    
135  Name of the attribute. It must be a valid ERDB field name, consisting entirely of  Name of the attribute. It must be a valid ERDB field name, consisting entirely of
# Line 185  Line 144 
144    
145  Descriptive notes about the attribute. It is presumed to be raw text, not HTML.  Descriptive notes about the attribute. It is presumed to be raw text, not HTML.
146    
147  =item RETURN  =item groups
148    
149  Returns a Custom Attribute Database object if successful. If unsuccessful, an  Reference to a list of the groups to which the attribute should be associated.
150  error will be thrown.  This will replace any groups to which the attribute is currently attached.
151    
152  =back  =back
153    
# Line 196  Line 155 
155    
156  sub StoreAttributeKey {  sub StoreAttributeKey {
157      # Get the parameters.      # Get the parameters.
158      my ($entityName, $attributeName, $type, $notes) = @_;      my ($self, $attributeName, $type, $notes, $groups) = @_;
159      # Declare the return variable.      # Declare the return variable.
160      my $retVal;      my $retVal;
161      # Get the data type hash.      # Get the data type hash.
# Line 208  Line 167 
167          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
168      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
169          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid data type \"$type\" for $attributeName.");
     }  
     # Our next step is to read in the XML for the database defintion. We  
     # need to verify that the named entity exists.  
     my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);  
     my $entityHash = $metadata->{Entities};  
     if (! exists $entityHash->{$entityName}) {  
         Confess("Entity $entityName not found.");  
170      } else {      } else {
171          # Okay, we're ready to begin. Get the entity hash and the field hash.          # Okay, we're ready to begin. See if this key exists.
172          my $entityData = $entityHash->{$entityName};          my $attribute = $self->GetEntity('AttributeKey', $attributeName);
173          my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);          if (defined($attribute)) {
174          # Compare the old attribute data to the new data.              # It does, so we do an update.
175          my $bigChange = 1;              $self->UpdateEntity('AttributeKey', $attributeName,
176          if (exists $fieldHash->{$attributeName} && $fieldHash->{$attributeName}->{type} eq $type) {                                  { description => $notes, 'data-type' => $type });
177              $bigChange = 0;              # Detach the key from its current groups.
178          }              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
179          # Compute the attribute's relation name.          } else {
180          my $relName = join("", $entityName, map { ucfirst $_ } split(/-|_/, $attributeName));              # It doesn't, so we do an insert.
181          # Store the attribute's field data. Note the use of the "content" hash for              $self->InsertObject('AttributeKey', { id => $attributeName,
182          # the notes. This is how the XML writer knows Notes is a text tag instead of                                  description => $notes, 'data-type' => $type });
183          # an attribute.          }
184          $fieldHash->{$attributeName} = { type => $type, relation => $relName,          # Attach the key to the specified groups. (We presume the groups already
185                                           Notes => { content => $notes } };          # exist.)
186          # Insure we have an index for this attribute.          for my $group (@{$groups}) {
187          my $index = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
188          if (! defined($index)) {                                                 'to-link'   => $group });
             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);  
         }  
     }  
     return $retVal;  
 }  
   
 =head3 Refresh  
   
 C<< $attrDB->Refresh($fig); >>  
   
 Refresh the primary entity tables from the FIG data store. This method basically  
 drops and reloads the main tables of the custom attributes database.  
   
 =over 4  
   
 =item fig  
   
 FIG-like object that can be used to find genomes and features.  
   
 =back  
   
 =cut  
   
 sub Refresh {  
     # Get the parameters.  
     my ($self, $fig) = @_;  
     # Create load objects for the genomes and the features.  
     my $loadGenome = ERDBLoad->new($self, 'Genome', $FIG_Config::temp);  
     my $loadFeature = ERDBLoad->new($self, 'Feature', $FIG_Config::temp);  
     # Get the genome list.  
     my @genomes = $fig->genomes();  
     # Loop through the genomes.  
     for my $genomeID (@genomes) {  
         # Put this genome in the genome table.  
         $loadGenome->Put($genomeID);  
         Trace("Processing Genome $genomeID") if T(3);  
         # Put its features into the feature table. Note we have to use a hash to  
         # remove duplicates.  
         my %featureList = map { $_ => 1 } $fig->all_features($genomeID);  
         for my $fid (keys %featureList) {  
             $loadFeature->Put($fid);  
189          }          }
190      }      }
     # Get a variable for holding statistics objects.  
     my $stats;  
     # Finish the genome load.  
     Trace("Loading Genome relation.") if T(2);  
     $stats = $loadGenome->FinishAndLoad();  
     Trace("Genome table load statistics:\n" . $stats->Show()) if T(3);  
     # Finish the feature load.  
     Trace("Loading Feature relation.") if T(2);  
     $stats = $loadFeature->FinishAndLoad();  
     Trace("Feature table load statistics:\n" . $stats->Show()) if T(3);  
191  }  }
192    
193  =head3 LoadAttributeKey  =head3 LoadAttributeKey
194    
195  C<< my $stats = $attrDB->LoadAttributeKey($entityName, $fieldName, $fh, $keyCol, $dataCol); >>  C<< my $stats = $attrDB->LoadAttributeKey($keyName, $fh, $keyCol, $dataCol, %options); >>
196    
197  Load the specified attribute from the specified file. The file should be a  Load the specified attribute from the specified file. The file should be a
198  tab-delimited file with internal tab and new-line characters escaped. This is  tab-delimited file with internal tab and new-line characters escaped. This is
199  the typical TBL-style file used by most FIG applications. One of the columns  the typical TBL-style file used by most FIG applications. One of the columns
200  in the input file must contain the appropriate key value and the other the  in the input file must contain the appropriate object id value and the other the
201  corresponding attribute value.  corresponding attribute value.
202    
203  =over 4  =over 4
204    
205  =item entityName  =item keyName
   
 Name of the entity containing the attribute.  
206    
207  =item fieldName  Key of the attribute to load.
   
 Name of the actual attribute.  
208    
209  =item fh  =item fh
210    
211  Open file handle for the input file.  Open file handle for the input file.
212    
213  =item keyCol  =item idCol
214    
215  Index (0-based) of the column containing the key field. The key field should  Index (0-based) of the column containing the ID field. The ID field should
216  contain the ID of an instance of the named entity.  contain the ID of an instance of the named entity.
217    
218  =item dataCol  =item dataCol
219    
220  Index (0-based) of the column containing the data value field.  Index (0-based) of the column containing the data value field.
221    
222    =item options
223    
224    Hash specifying the options for this load.
225    
226  =item RETURN  =item RETURN
227    
228  Returns a statistics object for the load process.  Returns a statistics object for the load process.
229    
230  =back  =back
231    
232    The available options are as follows.
233    
234    =over 4
235    
236    =item erase
237    
238    If TRUE, the key's values will all be erased before loading. (Doing so
239    makes for a faster load.)
240    
241    =back
242    
243  =cut  =cut
244    
245  sub LoadAttributeKey {  sub LoadAttributeKey {
246      # Get the parameters.      # Get the parameters.
247      my ($self, $entityName, $fieldName, $fh, $keyCol, $dataCol) = @_;      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;
248      # Create the return variable.      # Create the return variable.
249      my $retVal;      my $retVal = Stats->new("lineIn", "shortLine", "newObject");
250      # Insure the entity exists.      # Compute the minimum number of fields required in each input line.
251      my $found = grep { $_ eq $entityName } $self->GetEntityTypes();      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;
252      if (! $found) {      # Insure the attribute key exists.
253          Confess("Entity \"$entityName\" not found in database.");      my $found = $self->GetEntity('AttributeKey', $keyName);
254      } else {      if (! defined $found) {
255          # Get the field structure for the named entity.          Confess("Attribute key \"$keyName\" not found in database.");
         my $fieldHash = $self->GetFieldTable($entityName);  
         # Verify that the attribute exists.  
         if (! exists $fieldHash->{$fieldName}) {  
             Confess("Attribute key \"$fieldName\" does not exist in entity $entityName.");  
256          } else {          } else {
257              # Create a loader for the specified attribute. We need the          # Erase the key's current values.
258              # relation name first.          $self->EraseAttribute($keyName);
259              my $relName = $fieldHash->{$fieldName}->{relation};          # Save a list of the object IDs we need to add.
260              my $loadAttribute = ERDBLoad->new($self, $relName, $FIG_Config::temp);          my %objectIDs = ();
261              # Loop through the input file.              # Loop through the input file.
262              while (! eof $fh) {              while (! eof $fh) {
263                  # Get the next line of the file.                  # Get the next line of the file.
264                  my @fields = Tracer::GetLine($fh);                  my @fields = Tracer::GetLine($fh);
265                  $loadAttribute->Add("lineIn");              $retVal->Add(lineIn => 1);
266                  # Now we need to validate the line.                  # Now we need to validate the line.
267                  if ($#fields < $dataCol) {              if (scalar(@fields) < $minCols) {
268                      $loadAttribute->Add("shortLine");                  $retVal->Add(shortLine => 1);
                 } elsif (! $self->Exists($entityName, $fields[$keyCol])) {  
                     $loadAttribute->Add("badKey");  
269                  } else {                  } else {
270                      # It's valid,so send it to the loader.                  # It's valid, so get the ID and value.
271                      $loadAttribute->Put($fields[$keyCol], $fields[$dataCol]);                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
272                      $loadAttribute->Add("lineUsed");                  # Denote we're using this input line.
273                    $retVal->Add(lineUsed => 1);
274                    # Now we insert the attribute.
275                    $self->InsertObject('HasValueFor', { from => $keyName, to => $id,
276                                                         value => $value });
277                    $retVal->Add(newValue => 1);
278                  }                  }
279              }              }
             # Finish the load.  
             $retVal = $loadAttribute->FinishAndLoad();  
         }  
280      }      }
281      # Return the statistics.      # Return the statistics.
282      return $retVal;      return $retVal;
# Line 386  Line 285 
285    
286  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
287    
288  C<< CustomAttributes::DeleteAttributeKey($entityName, $attributeName); >>  C<< my $stats = $attrDB->DeleteAttributeKey($attributeName); >>
289    
290  Delete an attribute from the custom attributes database.  Delete an attribute from the custom attributes database.
291    
292  =over 4  =over 4
293    
 =item entityName  
   
 Name of the entity possessing the attribute.  
   
294  =item attributeName  =item attributeName
295    
296  Name of the attribute to delete.  Name of the attribute to delete.
297    
298    =item RETURN
299    
300    Returns a statistics object describing the effects of the deletion.
301    
302  =back  =back
303    
304  =cut  =cut
305    
306  sub DeleteAttributeKey {  sub DeleteAttributeKey {
307      # Get the parameters.      # Get the parameters.
308      my ($entityName, $attributeName) = @_;      my ($self, $attributeName) = @_;
309      # Read in the XML for the database defintion. We need to verify that      # Delete the attribute key.
310      # the named entity exists and it has the named attribute.      my $retVal = $self->Delete('AttributeKey', $attributeName);
311      my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);      # Return the result.
312      my $entityHash = $metadata->{Entities};      return $retVal;
313      if (! exists $entityHash->{$entityName}) {  
         Confess("Entity \"$entityName\" not found.");  
     } else {  
         # Get the field hash.  
         my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);  
         if (! exists $fieldHash->{$attributeName}) {  
             Confess("Attribute key \"$attributeName\" not found in entity $entityName.");  
         } else {  
             # Get the attribute's relation name.  
             my $relName = $fieldHash->{$attributeName}->{relation};  
             # Check for an index.  
             my $indexIdx = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);  
             if (defined($indexIdx)) {  
                 Trace("Index for $attributeName found at position $indexIdx for $entityName.") if T(3);  
                 delete $entityHash->{$entityName}->{Indexes}->[$indexIdx];  
             }  
             # Delete the attribute from the field hash.  
             Trace("Deleting attribute $attributeName from $entityName.") if T(3);  
             delete $fieldHash->{$attributeName};  
             # Write the XML back out.  
             ERDB::WriteMetaXML($metadata, $FIG_Config::attrDBD);  
             # Insure the relation does not exist in the database. This requires connecting  
             # since we may have to do a table drop.  
             my $attrDB = CustomAttributes->new();  
             Trace("Dropping table $relName.") if T(3);  
             $attrDB->DropRelation($relName);  
         }  
314      }      }
315    
316    =head3 NewName
317    
318    C<< my $text = CustomAttributes::NewName(); >>
319    
320    Return the string used to indicate the user wants to add a new attribute.
321    
322    =cut
323    
324    sub NewName {
325        return "(new)";
326  }  }
327    
328  =head3 ControlForm  =head3 ControlForm
329    
330  C<< my $formHtml = $attrDB->ControlForm($cgi, $name); >>  C<< my $formHtml = $attrDB->ControlForm($cgi, $name, \%keys); >>
331    
332  Return a form that can be used to control the creation and modification of  Return a form that can be used to control the creation and modification of
333  attributes.  attributes. Only a subset of the attribute keys will be displayed, as
334    determined by the incoming list.
335    
336  =over 4  =over 4
337    
# Line 458  Line 343 
343    
344  Name to give to the form. This should be unique for the web page.  Name to give to the form. This should be unique for the web page.
345    
346    =item keys
347    
348    Reference to a hash mapping attribute keys to n-tuples. Each tuple will contain the
349    attribute's data type, its description, and a list of the groups in which it participates.
350    
351  =item RETURN  =item RETURN
352    
353  Returns the HTML for a form that submits instructions to the C<Attributes.cgi> script  Returns the HTML for a form that can be used to  submit instructions to the C<Attributes.cgi> script
354  for loading, creating, or deleting an attribute.  for loading, creating, displaying, changing, or deleting an attribute. Note that only the form
355    controls are generated. The form tags are left to the caller.
356    
357  =back  =back
358    
# Line 469  Line 360 
360    
361  sub ControlForm {  sub ControlForm {
362      # Get the parameters.      # Get the parameters.
363      my ($self, $cgi, $name) = @_;      my ($self, $cgi, $name, $keys) = @_;
364      # Declare the return list.      # Declare the return list.
365      my @retVal = ();      my @retVal = ();
     # Start the form. We use multipart to support the upload control.  
     push @retVal, $cgi->start_multipart_form(-name => $name);  
366      # We'll put the controls in a table. Nothing else ever seems to look nice.      # We'll put the controls in a table. Nothing else ever seems to look nice.
367      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });
368      # The first row is for selecting the field name.      # The first row is for selecting the field name.
369      push @retVal, $cgi->Tr($cgi->th("Select a Field"),      push @retVal, $cgi->Tr($cgi->th("Select a Field"),
370                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', 1,                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', $keys,
371                                                       "document.$name.notes.value",                                                       new => 1,
372                                                       "document.$name.dataType.value")));                                                       notes => "document.$name.notes.value",
373                                                         type => "document.$name.dataType.value",
374                                                         groups => "document.$name.groups")));
375      # Now we set up a dropdown for the data types. The values will be the      # Now we set up a dropdown for the data types. The values will be the
376      # data type names, and the labels will be the descriptions.      # data type names, and the labels will be the descriptions.
377      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
378      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;
379      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',
380                                      -values => [sort keys %types],                                      -values => [sort keys %types],
381                                      -labels => \%labelMap);                                      -labels => \%labelMap,
382                                        -default => 'string');
383        # Allow the user to specify a new field name. This is required if the
384        # user has selected the "(new)" marker. We put a little scriptlet in here that
385        # selects the (new) marker when the user enters the field.
386        push @retVal, "<script language=\"javaScript\">";
387        my $fieldField = "document.$name.fieldName";
388        my $newName = "\"" . NewName() . "\"";
389        push @retVal, $cgi->Tr($cgi->th("New Field Name"),
390                               $cgi->td($cgi->textfield(-name => 'newName',
391                                                        -size => 30,
392                                                        -value => "",
393                                                        -onFocus => "setIfEmpty($fieldField, $newName);")),
394                                        );
395      push @retVal, $cgi->Tr($cgi->th("Data type"),      push @retVal, $cgi->Tr($cgi->th("Data type"),
396                             $cgi->td($typeMenu));                             $cgi->td($typeMenu));
397      # The next row is for the notes.      # The next row is for the notes.
# Line 496  Line 400 
400                                                     -rows => 6,                                                     -rows => 6,
401                                                     -columns => 80))                                                     -columns => 80))
402                            );                            );
403      # Allow the user to specify a new field name. This is required if the      # Now we have the groups, which are implemented as a checkbox group.
404      # user has selected one of the "(new)" markers.      my @groups = $self->GetGroups();
405      push @retVal, $cgi->Tr($cgi->th("New Field Name"),      push @retVal, $cgi->Tr($cgi->th("Groups"),
406                             $cgi->td($cgi->textfield(-name => 'newName',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
407                                                      -size => 30)),                                      -values=> \@groups))
408                                      );                                      );
409      # If the user wants to upload new values for the field, then we have      # If the user wants to upload new values for the field, then we have
410      # an upload file name and column indicators.      # an upload file name and column indicators.
# Line 517  Line 421 
421                                                      -default => 1)                                                      -default => 1)
422                                     ),                                     ),
423                            );                            );
424      # Now the three buttons: UPDATE, SHOW, and DELETE.      # Now the three buttons: STORE, SHOW, and DELETE.
425      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
426                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'},
427                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .
# Line 527  Line 431 
431                            );                            );
432      # Close the table and the form.      # Close the table and the form.
433      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
     push @retVal, $cgi->end_form();  
434      # Return the assembled HTML.      # Return the assembled HTML.
435      return join("\n", @retVal, "");      return join("\n", @retVal, "");
436  }  }
437    
438    =head3 LoadAttributesFrom
439    
440    C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
441    
442    Load attributes from the specified tab-delimited file. Each line of the file must
443    contain an object ID in the first column, an attribute key name in the second
444    column, and attribute values in the remaining columns. The attribute values will
445    be assembled into a single value using the splitter code.
446    
447    =over 4
448    
449    =item fileName
450    
451    Name of the file from which to load the attributes.
452    
453    =item options
454    
455    Hash of options for modifying the load process.
456    
457    =item RETURN
458    
459    Returns a statistics object describing the load.
460    
461    =back
462    
463    Permissible option values are as follows.
464    
465    =over 4
466    
467    =item append
468    
469    If TRUE, then the attributes will be appended to existing data; otherwise, the
470    first time a key name is encountered, it will be erased.
471    
472    =back
473    
474    =cut
475    
476    sub LoadAttributesFrom {
477        # Get the parameters.
478        my ($self, $fileName, %options) = @_;
479        # Declare the return variable.
480        my $retVal = Stats->new('keys', 'values');
481        # Check for append mode.
482        my $append = ($options{append} ? 1 : 0);
483        # Create a hash of key names found.
484        my %keyHash = ();
485        # Open the file for input.
486        my $fh = Open(undef, "<$fileName");
487        # Loop through the file.
488        while (! eof $fh) {
489            my ($id, $key, @values) = Tracer::GetLine($fh);
490            $retVal->Add(linesIn => 1);
491            # Do some validation.
492            if (! defined($id)) {
493                # We ignore blank lines.
494                $retVal->Add(blankLines => 1);
495            } elsif (! defined($key)) {
496                # An ID without a key is a serious error.
497                my $lines = $retVal->Ask('linesIn');
498                Confess("Line $lines in $fileName has no attribute key.");
499            } else {
500                # Now we need to check for a new key.
501                if (! exists $keyHash{$key}) {
502                    # This is a new key. Verify that it exists.
503                    if (! $self->Exists('AttributeKey', $key)) {
504                        my $line = $retVal->Ask('linesIn');
505                        Confess("Attribute \"$key\" on line $line of $fileName not found in database.");
506                    } else {
507                        # Make sure we know this is no longer a new key.
508                        $keyHash{$key} = 1;
509                        $retVal->Add(keys => 1);
510                        # If this is NOT append mode, erase the key.
511                        if (! $append) {
512                            $self->EraseAttribute($key);
513                        }
514                    }
515                    Trace("Key $key found.") if T(3);
516                }
517                # Now we know the key is valid. Add this value.
518                $self->AddAttribute($id, $key, @values);
519                my $progress = $retVal->Add(values => 1);
520                Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
521    
522            }
523        }
524        # Return the result.
525        return $retVal;
526    }
527    
528    =head3 BackupKeys
529    
530    C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
531    
532    Backup the attribute key information from the attribute database.
533    
534    =over 4
535    
536    =item fileName
537    
538    Name of the output file.
539    
540    =item options
541    
542    Options for modifying the backup process.
543    
544    =item RETURN
545    
546    Returns a statistics object for the backup.
547    
548    =back
549    
550    Currently there are no options. The backup is straight to a text file in
551    tab-delimited format. Each key is backup up to two lines. The first line
552    is all of the data from the B<AttributeKey> table. The second is a
553    tab-delimited list of all the groups.
554    
555    =cut
556    
557    sub BackupKeys {
558        # Get the parameters.
559        my ($self, $fileName, %options) = @_;
560        # Declare the return variable.
561        my $retVal = Stats->new();
562        # Open the output file.
563        my $fh = Open(undef, ">$fileName");
564        # Set up to read the keys.
565        my $keyQuery = $self->Get(['AttributeKey'], "", []);
566        # Loop through the keys.
567        while (my $keyData = $keyQuery->Fetch()) {
568            $retVal->Add(key => 1);
569            # Get the fields.
570            my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
571                                                              'AttributeKey(description)']);
572            # Escape any tabs or new-lines in the description.
573            my $escapedDescription = Tracer::Escape($description);
574            # Write the key data to the output.
575            Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
576            # Get the key's groups.
577            my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
578                                        'IsInGroup(to-link)');
579            $retVal->Add(memberships => scalar(@groups));
580            # Write them to the output. Note we put a marker at the beginning to insure the line
581            # is nonempty.
582            Tracer::PutLine($fh, ['#GROUPS', @groups]);
583        }
584        # Return the result.
585        return $retVal;
586    }
587    
588    =head3 RestoreKeys
589    
590    C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
591    
592    Restore the attribute keys and groups from a backup file.
593    
594    =over 4
595    
596    =item fileName
597    
598    Name of the file containing the backed-up keys. Each key has a pair of lines,
599    one containing the key data and one listing its groups.
600    
601    =back
602    
603    =cut
604    
605    sub RestoreKeys {
606        # Get the parameters.
607        my ($self, $fileName, %options) = @_;
608        # Declare the return variable.
609        my $retVal = Stats->new();
610        # Set up a hash to hold the group IDs.
611        my %groups = ();
612        # Open the file.
613        my $fh = Open(undef, "<$fileName");
614        # Loop until we're done.
615        while (! eof $fh) {
616            # Get a key record.
617            my ($id, $dataType, $description) = Tracer::GetLine($fh);
618            if ($id eq '#GROUPS') {
619                Confess("Group record found when key record expected.");
620            } elsif (! defined($description)) {
621                Confess("Invalid format found for key record.");
622            } else {
623                $retVal->Add("keyIn" => 1);
624                # Add this key to the database.
625                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
626                                                      description => Tracer::UnEscape($description) });
627                Trace("Attribute $id stored.") if T(3);
628                # Get the group line.
629                my ($marker, @groups) = Tracer::GetLine($fh);
630                if (! defined($marker)) {
631                    Confess("End of file found where group record expected.");
632                } elsif ($marker ne '#GROUPS') {
633                    Confess("Group record not found after key record.");
634                } else {
635                    $retVal->Add(memberships => scalar(@groups));
636                    # Connect the groups.
637                    for my $group (@groups) {
638                        # Find out if this is a new group.
639                        if (! $groups{$group}) {
640                            $retVal->Add(newGroup => 1);
641                            # Add the group.
642                            $self->InsertObject('AttributeGroup', { id => $group });
643                            Trace("Group $group created.") if T(3);
644                            # Make sure we know it's not new.
645                            $groups{$group} = 1;
646                        }
647                        # Connect the group to our key.
648                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
649                    }
650                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
651                }
652            }
653        }
654        # Return the result.
655        return $retVal;
656    }
657    
658    
659    =head3 BackupAllAttributes
660    
661    C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
662    
663    Backup all of the attributes to a file. The attributes will be stored in a
664    tab-delimited file suitable for reloading via L</LoadAttributesFrom>.
665    
666    =over 4
667    
668    =item fileName
669    
670    Name of the file to which the attribute data should be backed up.
671    
672    =item options
673    
674    Hash of options for the backup.
675    
676    =item RETURN
677    
678    Returns a statistics object describing the backup.
679    
680    =back
681    
682    Currently there are no options defined.
683    
684    =cut
685    
686    sub BackupAllAttributes {
687        # Get the parameters.
688        my ($self, $fileName, %options) = @_;
689        # Declare the return variable.
690        my $retVal = Stats->new();
691        # Get a list of the keys.
692        my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
693        Trace(scalar(@keys) . " keys found during backup.") if T(2);
694        # Open the file for output.
695        my $fh = Open(undef, ">$fileName");
696        # Loop through the keys.
697        for my $key (@keys) {
698            Trace("Backing up attribute $key.") if T(3);
699            $retVal->Add(keys => 1);
700            # Loop through this key's values.
701            my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
702            my $valuesFound = 0;
703            while (my $line = $query->Fetch()) {
704                $valuesFound++;
705                # Get this row's data.
706                my @row = $line->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
707                                         'HasValueFor(value)']);
708                # Write it to the file.
709                Tracer::PutLine($fh, \@row);
710            }
711            Trace("$valuesFound values backed up for key $key.") if T(3);
712            $retVal->Add(values => $valuesFound);
713        }
714        # Return the result.
715        return $retVal;
716    }
717    
718  =head3 FieldMenu  =head3 FieldMenu
719    
720  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $newFlag, $noteControl, $typeControl); >>  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>
721    
722  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
723  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
724  CGI package, but actually looks like a list. The list will contain  CGI package, but actually looks like a list. The list will contain
725  one selectable row per field, grouped by entity.  one selectable row per field.
726    
727  =over 4  =over 4
728    
# Line 556  Line 739 
739  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
740  appear when the form is submitted.  appear when the form is submitted.
741    
742  =item newFlag (optional)  =item keys
743    
744    Reference to a hash mapping each attribute key name to a list reference,
745    the list itself consisting of the attribute data type, its description,
746    and a list of its groups.
747    
748    =item options
749    
750    Hash containing options that modify the generation of the menu.
751    
752    =item RETURN
753    
754    Returns the HTML to create a form field that can be used to select an
755    attribute from the custom attributes system.
756    
757    =back
758    
759    The permissible options are as follows.
760    
761    =over 4
762    
763    =item new
764    
765  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
766  a new attribute. In other words, the user can select an existing  a new attribute. In other words, the user can select an existing
767  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
768  be created in the parent entity.  be created in the parent entity.
769    
770  =item noteControl (optional)  =item notes
771    
772  If specified, the name of a variable for displaying the notes attached  If specified, the name of a variable for displaying the notes attached
773  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 778 
778  it is copied in. Specifying this parameter generates Javascript for  it is copied in. Specifying this parameter generates Javascript for
779  displaying the field description when a field is selected.  displaying the field description when a field is selected.
780    
781  =item typeControl (optional)  =item type
782    
783  If specified, the name of a variable for displaying the field's  If specified, the name of a variable for displaying the field's
784  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 786 
786  raw value is put into the specified variable. Otherwise, the same  raw value is put into the specified variable. Otherwise, the same
787  rules apply to this value that apply to I<$noteControl>.  rules apply to this value that apply to I<$noteControl>.
788    
789  =item RETURN  =item groups
790    
791  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
792  attribute from the custom attributes system.  a popup menu) which shall be used to display the selected groups.
793    
794  =back  =back
795    
# Line 593  Line 797 
797    
798  sub FieldMenu {  sub FieldMenu {
799      # Get the parameters.      # Get the parameters.
800      my ($self, $cgi, $height, $name, $newFlag, $noteControl, $typeControl) = @_;      my ($self, $cgi, $height, $name, $keys, %options) = @_;
801      # These next two hashes make everything happen. "entities"      # Reformat the list of keys.
802      # maps each entity name to the list of values to be put into its      my %keys = %{$keys};
803      # option group. "labels" maps each entity name to a map from values      # Add the (new) key, if needed.
804      # to labels.      if ($options{new}) {
805      my @entityNames = sort ($self->GetEntityTypes());          $keys{NewName()} = ["string", ""];
806      my %entities = map { $_ => [] } @entityNames;      }
807      my %labels = map { $_ => { }} @entityNames;      # Get a sorted list of key.
808      # Loop through the entities, adding the existing attributes.      my @keys = sort keys %keys;
809      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  
810      # 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
811      # for the menu.      # for the menu.
812      my $changeName = "${name}_setNotes";      my $changeName = "${name}_setNotes";
813      my $retVal = $cgi->popup_menu({name => $name,      my $retVal = $cgi->popup_menu({name => $name,
814                                     size => $height,                                     size => $height,
815                                     onChange => "$changeName(this.value)",                                     onChange => "$changeName(this.value)",
816                                     values => [map { $cgi->optgroup(-name => $_,                                     values => \@keys,
817                                                                     -values => $entities{$_},                                    });
                                                                    -labels => $labels{$_})  
                                                   } @entityNames]}  
                                  );  
818      # Create the change function.      # Create the change function.
819      $retVal .= "\n<script language=\"javascript\">\n";      $retVal .= "\n<script language=\"javascript\">\n";
820      $retVal .= "    function $changeName(fieldValue) {\n";      $retVal .= "    function $changeName(fieldValue) {\n";
821      # 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
822      if ($noteControl || $typeControl) {      # attribute.
823        if ($options{notes} || $options{type} || $options{groups}) {
824          # 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.
825            my $noteControl = $options{notes};
826          my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);          my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);
827          # 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
828          # field description will be stored in the JavaScript variable "myText"          # field description will be stored in the JavaScript variable "myText"
# Line 652  Line 831 
831          $retVal .= "        var myText = \"\";\n";          $retVal .= "        var myText = \"\";\n";
832          $retVal .= "        var myType = \"string\";\n";          $retVal .= "        var myType = \"string\";\n";
833          $retVal .= "        switch (fieldValue) {\n";          $retVal .= "        switch (fieldValue) {\n";
834          # Loop through the entities.          # Loop through the keys.
835          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};  
836                      # Generate this case.                      # Generate this case.
837                      $retVal .= "        case \"$value\" :\n";              $retVal .= "        case \"$key\" :\n";
838                      # Here we either want to update the note display, the                      # Here we either want to update the note display, the
839                      # type display, or both.              # type display, the group list, or a combination of them.
840                my ($type, $notes, @groups) = @{$keys{$key}};
841                      if ($noteControl) {                      if ($noteControl) {
                         # Here we want the notes updated.  
                         my $notes = $element->{Notes}->{content};  
842                          # Insure it's in the proper form.                          # Insure it's in the proper form.
843                          if ($htmlMode) {                          if ($htmlMode) {
844                              $notes = ERDB::HTMLNote($notes);                              $notes = ERDB::HTMLNote($notes);
# Line 679  Line 848 
848                          $notes =~ s/"/\\"/g;                          $notes =~ s/"/\\"/g;
849                          $retVal .= "           myText = \"$notes\";\n";                          $retVal .= "           myText = \"$notes\";\n";
850                      }                      }
851                      if ($typeControl) {              if ($options{type}) {
852                          # Here we want the type updated.                          # Here we want the type updated.
                         my $type = $element->{type};  
853                          $retVal .= "           myType = \"$type\";\n";                          $retVal .= "           myType = \"$type\";\n";
854                      }                      }
855                if ($options{groups}) {
856                    # Here we want the groups shown. Get a list of this attribute's groups.
857                    # We'll search through this list for each group to see if it belongs with
858                    # our attribute.
859                    my $groupLiteral = "=" . join("=", @groups) . "=";
860                    # Now we need some variables containing useful code for the javascript. It's
861                    # worth knowing we go through a bit of pain to insure $groupField[i] isn't
862                    # parsed as an array element.
863                    my $groupField = $options{groups};
864                    my $currentField = $groupField . "[i]";
865                    # Do the javascript.
866                    $retVal .= "           var groupList = \"$groupLiteral\";\n";
867                    $retVal .= "           for (var i = 0; i < $groupField.length; i++) {\n";
868                    $retVal .= "              var srchString = \"=\" + $currentField.value + \"=\";\n";
869                    $retVal .= "              var srchLoc = groupList.indexOf(srchString);\n";
870                    $retVal .= "              $currentField.checked = (srchLoc >= 0);\n";
871                    $retVal .= "           }\n";
872                }
873                      # Close this case.                      # Close this case.
874                      $retVal .= "           break;\n";                      $retVal .= "           break;\n";
875                  }                  }
             }  
         }  
876          # Close the CASE statement and make the appropriate assignments.          # Close the CASE statement and make the appropriate assignments.
877          $retVal .= "        }\n";          $retVal .= "        }\n";
878          if ($noteControl) {          if ($noteControl) {
879              $retVal .= "        $noteControl = myText;\n";              $retVal .= "        $noteControl = myText;\n";
880          }          }
881          if ($typeControl) {          if ($options{type}) {
882              $retVal .= "        $typeControl = myType;\n";              $retVal .= "        $options{type} = myType;\n";
883          }          }
884      }      }
885      # Terminate the change function.      # Terminate the change function.
# Line 705  Line 889 
889      return $retVal;      return $retVal;
890  }  }
891    
892  =head3 MatchSqlPattern  =head3 GetGroups
893    
894    C<< my @groups = $attrDB->GetGroups(); >>
895    
896    Return a list of the available groups.
897    
898    =cut
899    
900    sub GetGroups {
901        # Get the parameters.
902        my ($self) = @_;
903        # Get the groups.
904        my @retVal = $self->GetFlat(['AttributeGroup'], "", [], 'AttributeGroup(id)');
905        # Return them.
906        return @retVal;
907    }
908    
909    =head3 GetAttributeData
910    
911  C<< my $matched = CustomAttributes::MatchSqlPattern($value, $pattern); >>  C<< my %keys = $attrDB->GetAttributeData($type, @list); >>
912    
913  Determine whether or not a specified value matches an SQL pattern. An SQL  Return attribute data for the selected attributes. The attribute
914  pattern has two wild card characters: C<%> that matches multiple characters,  data is a hash mapping each attribute key name to a n-tuple containing the
915  and C<_> that matches a single character. These can be escaped using a  data type, the description, and the groups. This is the same format expected in
916  backslash (C<\>). We pull this off by converting the SQL pattern to a  the L</FieldMenu> and L</ControlForm> methods for the list of attributes to display.
 PERL regular expression. As per SQL rules, the match is case-insensitive.  
917    
918  =over 4  =over 4
919    
920  =item value  =item type
921    
922  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
923  value will not match anything.  specified string, or C<group> for attributes in the specified group.
924    
925  =item pattern  =item list
926    
927  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.  
928    
929  =item RETURN  =item RETURN
930    
931  Returns TRUE if the value and pattern match, else FALSE.  Returns a hash mapping each attribute key name to its data type, description, and
932    parent groups.
933    
934  =back  =back
935    
936  =cut  =cut
937    
938  sub MatchSqlPattern {  sub GetAttributeData {
939      # Get the parameters.      # Get the parameters.
940      my ($value, $pattern) = @_;      my ($self, $type, @list) = @_;
941      # Declare the return variable.      # Set up a hash to store the attribute data.
942      my $retVal;      my %retVal = ();
943      # Insure we have a pattern.      # Loop through the list items.
944      if (! defined($pattern) || $pattern eq "") {      for my $item (@list) {
945          $retVal = 1;          # Set up a query for the desired attributes.
946      } else {          my $query;
947          # Break the pattern into pieces around the wildcard characters. Because we          if ($type eq 'name') {
948          # 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
949          # list elements for the delimiters as well as the rest of the string.              # on a %.
950          my @pieces = split /([_%]|\\[_%])/, $pattern;              my $parm = $item;
951          # Check some fast special cases.              $parm =~ s/_/\\_/g;
952          if ($pattern eq '%') {              $parm =~ s/%/\\%/g;
953              # A null pattern matches everything.              $parm .= "%";
954              $retVal = 1;              # Ask for matching attributes. (Note that if the user passed in a null string
955          } elsif (@pieces == 1) {              # he'll get everything.)
956              # No wildcards, so we have a literal comparison. Note we're case-insensitive.              $query = $self->Get(['AttributeKey'], "AttributeKey(id) LIKE ?", [$parm]);
957              $retVal = (lc($value) eq lc($pattern));          } elsif ($type eq 'group') {
958          } 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]));  
959          } else {          } else {
960              # Okay, we have to do it the hard way. Convert each piece to a PERL pattern.              Confess("Unknown attribute query type \"$type\".");
             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);  
                 } else {  
                     # Here we have raw text.  
                     $realPattern .= quotemeta($piece);  
961                  }                  }
962            while (my $row = $query->Fetch()) {
963                # Get this attribute's data.
964                my ($key, $type, $notes) = $row->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
965                                                         'AttributeKey(description)']);
966                # If it's new, get its groups and add it to the return hash.
967                if (! exists $retVal{$key}) {
968                    my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",
969                                                [$key], 'IsInGroup(to-link)');
970                    $retVal{$key} = [$type, $notes, @groups];
971              }              }
             # Do the match.  
             $retVal = ($value =~ /^$realPattern$/i ? 1 : 0);  
972          }          }
973      }      }
974      # Return the result.      # Return the result.
975      return $retVal;      return %retVal;
976  }  }
977    
978  =head3 MigrateAttributes  =head2 Internal Utility Methods
979    
980    =head3 _KeywordString
981    
982  C<< CustomAttributes::MigrateAttributes($fig); >>  C<< my $keywordString = $ca->_KeywordString($key, $value); >>
983    
984  Migrate all the attributes data from the specified FIG instance. This is a long, slow  Compute the keyword string for a specified key/value pair. This consists of the
985  method used to convert the old attribute data to the new system. Only attribute  key name and value converted to lower case with underscores translated to spaces.
986  keys that are not already in the database will be loaded, and only for entity instances  
987  current in the database. To get an accurate capture of the attributes in the given  This method is for internal use only. It is called whenever we need to update or
988  instance, you may want to clear the database and the DBD before starting and  insert a B<HasValueFor> record.
 run L</Refresh> to populate the entities.  
989    
990  =over 4  =over 4
991    
992  =item fig  =item key
993    
994    Name of the relevant attribute key.
995    
996    =item target
997    
998    ID of the target object to which this key/value pair will be associated.
999    
1000    =item value
1001    
1002    The value to store for this key/object combination.
1003    
1004    =item RETURN
1005    
1006  A FIG object that can be used to retrieve attributes for migration purposes.  Returns the value that should be stored as the keyword string for the specified
1007    key/value pair.
1008    
1009  =back  =back
1010    
1011  =cut  =cut
1012    
1013  sub MigrateAttributes {  sub _KeywordString {
1014      # Get the parameters.      # Get the parameters.
1015      my ($fig) = @_;      my ($self, $key, $value) = @_;
1016      # Get a list of the objects to migrate. This requires connecting. Note we      # Get a copy of the key name and convert underscores to spaces.
1017      # will map each entity type to a file name. The file will contain a list      my $keywordString = $key;
1018      # of the object's IDs so we can get to them when we're not connected to      $keywordString =~ s/_/ /g;
1019      # the database.      # Add the value convert it all to lower case.
1020      my $ca = CustomAttributes->new();      my $retVal = lc "$keywordString $value";
1021      my %objects = map { $_ => "$FIG_Config::temp/$_.keys.tbl" } $ca->GetEntityTypes();      # Return the result.
1022      # Set up hash of the existing attribute keys for each entity type.      return $retVal;
     my %oldKeys = ();  
     # Finally, we have a hash that counts the IDs for each entity type.  
     my %idCounts = map { $_ => 0 } keys %objects;  
     # Loop through the list, creating key files to read back in.  
     for my $entityType (keys %objects) {  
         Trace("Retrieving keys for $entityType.") if T(2);  
         # Create the key file.  
         my $idFile = Open(undef, ">$objects{$entityType}");  
         # Loop through the keys.  
         my @ids = $ca->GetFlat([$entityType], "", [], "$entityType(id)");  
         for my $id (@ids) {  
             print $idFile "$id\n";  
         }  
         close $idFile;  
         # In addition to the key file, we must get a list of attributes already  
         # in the database. This avoids a circularity problem that might occur if the $fig  
         # object is retrieving from the custom attributes database already.  
         my %fields = $ca->GetSecondaryFields($entityType);  
         $oldKeys{$entityType} = \%fields;  
         # Finally, we have the ID count.  
         $idCounts{$entityType} = scalar @ids;  
     }  
     # Release the custom attributes database so we can add attributes.  
     undef $ca;  
     # Loop through the objects.  
     for my $entityType (keys %objects) {  
         # Get a hash of all the attributes already in this database. These are  
         # left untouched.  
         my $myOldKeys = $oldKeys{$entityType};  
         # Create a hash to control the load file names for each attribute key we find.  
         my %keyHash = ();  
         # Set up some counters so we can trace our progress.  
         my ($totalIDs, $processedIDs, $keyCount, $valueCount) = ($idCounts{$entityType}, 0, 0, 0);  
         # Open this object's ID file.  
         Trace("Migrating data for $entityType. $totalIDs found.") if T(3);  
         my $keysIn = Open(undef, "<$objects{$entityType}");  
         while (my $id = <$keysIn>) {  
             # Remove the EOL characters.  
             chomp $id;  
             # Get this object's attributes.  
             my @allData = $fig->get_attributes($id);  
             Trace(scalar(@allData) . " attribute values found for $entityType($id).") if T(4);  
             # Loop through the attribute values one at a time.  
             for my $dataTuple (@allData) {  
                 # Get the key, value, and URL. We ignore the first element because that's the  
                 # object ID, and we already know the object ID.  
                 my (undef, $key, $value, $url) = @{$dataTuple};  
                 # Remove the buggy "1" for $url.  
                 if ($url eq "1") {  
                     $url = undef;  
                 }  
                 # 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);  
1023  }  }
1024    
1025  =head3 ComputeObjectTypeFromID  =head3 _QueryResults
1026    
1027  C<< my ($entityName, $id) = CustomAttributes::ComputeObjectTypeFromID($objectID); >>  C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1028    
1029  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
1030  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
1031  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
1032  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.  
1033    
1034  =over 4  =over 4
1035    
1036  =item objectID  =item query
1037    
1038  Object ID to examine.  A query object that will return the desired B<HasValueFor> records.
1039    
1040    =item values
1041    
1042    List of the desired attribute values, section by section. If C<undef>
1043    or an empty string is specified, all values in that section will match. A
1044    generic match can be requested by placing a percent sign (C<%>) at the end.
1045    In that case, all values that match up to and not including the percent sign
1046    will match. You may also specify a regular expression enclosed
1047    in slashes. All values that match the regular expression will be returned. For
1048    performance reasons, only values have this extra capability.
1049    
1050  =item RETURN  =item RETURN
1051    
1052  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
1053    second is an attribute key, and the remaining elements are the sections of
1054    the attribute value. All of the tuples will match the criteria set forth in
1055    the parameter list.
1056    
1057  =back  =back
1058    
1059  =cut  =cut
1060    
1061  sub ComputeObjectTypeFromID {  sub _QueryResults {
1062      # Get the parameters.      # Get the parameters.
1063      my ($objectID) = @_;      my ($self, $query, @values) = @_;
1064      # Declare the return variables.      # Declare the return value.
1065      my ($entityName, $id);      my @retVal = ();
1066      # 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.
1067      # pair of undefs.      my $sectionCount = scalar(@values);
1068      if ($objectID) {      # Loop through the assignments found.
1069          if (ref $objectID eq 'ARRAY') {      while (my $row = $query->Fetch()) {
1070              # Here we have the new-style list reference. Pull out its pieces.          # Get the current row's data.
1071              ($entityName, $id) = @{$objectID};          my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1072          } else {                                                        'HasValueFor(value)']);
1073              # Here the ID is the outgoing ID, and we need to look at its structure          # Break the value into sections.
1074              # to determine the entity type.          my @sections = split($self->{splitter}, $valueString);
1075              $id = $objectID;          # Match each section against the incoming values. We'll assume we're
1076              if ($objectID =~ /^\d+\.\d+/) {          # okay unless we learn otherwise.
1077                  # Digits with a single period is a genome.          my $matching = 1;
1078                  $entityName = 'Genome';          for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1079              } elsif ($objectID =~ /^fig\|/) {              # We need to check to see if this section is generic.
1080                  # The "fig|" prefix indicates a feature.              my $value = $values[$i];
1081                  $entityName = 'Feature';              Trace("Current value pattern is \"$value\".") if T(4);
1082                if (substr($value, -1, 1) eq '%') {
1083                    Trace("Generic match used.") if T(4);
1084                    # Here we have a generic match.
1085                    my $matchLen = length($values[$i] - 1);
1086                    $matching = substr($sections[$i], 0, $matchLen) eq
1087                                substr($values[$i], 0, $matchLen);
1088                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1089                    Trace("Regular expression detected.") if T(4);
1090                    # Here we have a regular expression match.
1091                    my $section = $sections[$i];
1092                    $matching = eval("\$section =~ $value");
1093              } else {              } else {
1094                  # Anything else is illegal!                  # Here we have a strict match.
1095                  Confess("Invalid attribute ID specification \"$objectID\".");                  Trace("Strict match used.") if T(4);
1096                    $matching = ($sections[$i] eq $values[$i]);
1097              }              }
1098          }          }
1099            # If we match, output this row to the return list.
1100            if ($matching) {
1101                push @retVal, [$id, $key, @sections];
1102      }      }
1103      # Return the result.      }
1104      return ($entityName, $id);      # Return the rows found.
1105        return @retVal;
1106  }  }
1107    
1108  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1109    
1110  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.
1111  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
1112  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
1113  capabilities were used in the old system.  capabilities were used in the old system.
1114    
# Line 999  Line 1122 
1122  value of the splitter parameter on the constructor (L</new>). The default is double  value of the splitter parameter on the constructor (L</new>). The default is double
1123  colons C<::>.  colons C<::>.
1124    
1125  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
1126  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
1127  splitter value would be stored as  splitter value would be stored as
1128    
# Line 1010  Line 1133 
1133    
1134  =head3 GetAttributes  =head3 GetAttributes
1135    
1136  C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @valuePatterns); >>  C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @values); >>
1137    
1138  In the database, attribute values are sectioned into pieces using a splitter  In the database, attribute values are sectioned into pieces using a splitter
1139  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
1140  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
1141  these methods. If you are using the static method calls instead of the  these methods. If a value has multiple sections, each section
1142  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.  
1143    
1144  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
1145  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
1146  method therefore correspond structurally to the values expected in each tuple.  method therefore correspond structurally to the values expected in each tuple. In
1147    addition, you can ask for a generic search by suffixing a percent sign (C<%>) to any
1148    of the parameters. So, for example,
1149    
1150      my @attributeList = GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);      my @attributeList = $attrDB->GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);
1151    
1152  would return something like  would return something like
1153    
# Line 1033  Line 1156 
1156      ['fig}100226.1.peg.1004', 'structure2', 1, 2]      ['fig}100226.1.peg.1004', 'structure2', 1, 2]
1157      ['fig}100226.1.peg.1004', 'structureA', 1, 2]      ['fig}100226.1.peg.1004', 'structureA', 1, 2]
1158    
1159  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
1160  the I<$key> and I<@valuePatterns> parameters can contain SQL pattern characters: C<%>, which  a list reference in the ID column. Thus,
1161  matches any sequence of characters, and C<_>, which matches any single character.  
1162  (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');
1163  underscore.)  
1164    would get the PUBMED attribute data for Streptomyces coelicolor A3(2) and all its
1165    features.
1166    
1167  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
1168  values, so even  values, so even
1169    
1170      my @attributeList = GetAttributes($peg, 'virulent');      my @attributeList = $attrDB->GetAttributes($peg, 'virulent');
1171    
1172  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.
1173    
1174  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
1175  determine the entity type. In that case the only two types allowed are C<Genome> and  stored. For the object ID and key name, we create queries that filter for the desired
1176  C<Feature>. An alternative method is to use a list reference, with the list consisting  results. For the values, we do a comparison after the attributes are retrieved from the
1177  of an entity type name and the actual ID. Thus, the above example could equivalently  database. As a result, queries in which filter only on value end up reading the entire
1178  be written as  attribute table to find the desired results.
   
     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.  
1179    
1180  =over 4  =over 4
1181    
1182  =item objectID  =item objectID
1183    
1184  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
1185  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
1186  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
1187  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.  
1188    
1189  =item key  =item key
1190    
1191  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
1192  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
1193  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
1194  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.  
1195    
1196  =item valuePatterns  =item values
1197    
1198  List of the desired attribute values, section by section. If C<undef>  List of the desired attribute values, section by section. If C<undef>
1199  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
1200    generic match can be requested by placing a percent sign (C<%>) at the end.
1201    In that case, all values that match up to and not including the percent sign
1202    will match. You may also specify a regular expression enclosed
1203    in slashes. All values that match the regular expression will be returned. For
1204    performance reasons, only values have this extra capability.
1205    
1206  =item RETURN  =item RETURN
1207    
# Line 1107  Line 1216 
1216    
1217  sub GetAttributes {  sub GetAttributes {
1218      # Get the parameters.      # Get the parameters.
1219      my ($self, $objectID, $key, @valuePatterns) = @_;      my ($self, $objectID, $key, @values) = @_;
1220      # Declare the return variable.      # We will create one big honking query. The following hash will build the filter
1221      my @retVal = ();      # clause and a parameter list.
1222      # Determine the entity types for our search.      my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);
1223      my @objects = ();      my @filter = ();
1224      my ($actualObjectID, $computedType);      my @parms = ();
1225      if (! $objectID) {      # This next loop goes through the different fields that can be specified in the
1226          push @objects, $self->GetEntityTypes();      # parameter list and generates filters for each.
1227        for my $field (keys %data) {
1228            # Accumulate filter information for this field. We will OR together all the
1229            # elements accumulated to create the final result.
1230            my @fieldFilter = ();
1231            # Get the specified data from the caller.
1232            my $fieldPattern = $data{$field};
1233            # Only proceed if the pattern is one that won't match everything.
1234            if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {
1235                # Convert the pattern to an array.
1236                my @patterns = ();
1237                if (ref $fieldPattern eq 'ARRAY') {
1238                    push @patterns, @{$fieldPattern};
1239      } else {      } else {
1240          ($computedType, $actualObjectID) = ComputeObjectTypeFromID($objectID);                  push @patterns, $fieldPattern;
         push @objects, $computedType;  
1241      }      }
1242      # Loop through the entity types.              # Only proceed if the array is nonempty. The loop will work fine if the
1243      for my $entityType (@objects) {              # array is empty, but when we build the filter string at the end we'll
1244          # Now we need to find all the matching keys. The keys are actually stored in              # get "()" in the filter list, which will result in an SQL syntax error.
1245          # our database object, so this process is fast. Note that our              if (@patterns) {
1246          # MatchSqlPattern method                  # Loop through the individual patterns.
1247          my %secondaries = $self->GetSecondaryFields($entityType);                  for my $pattern (@patterns) {
1248          my @fieldList = grep { MatchSqlPattern($_, $key) } keys %secondaries;                      # Check for a generic request.
1249          # Now we figure out whether or not we need to filter by object. We will always                      if (substr($pattern, -1, 1) ne '%') {
1250          # filter by key to a limited extent, so if we're filtering by object we need an                          # Here we have a normal request.
1251          # AND to join the object ID filter with the key filter.                          push @fieldFilter, "$field = ?";
1252          my $filter = "";                          push @parms, $pattern;
1253          my @params = ();                      } else {
1254          if (defined($actualObjectID)) {                          # Here we have a generate request, so we will use the LIKE operator to
1255              # Here the caller wants to filter on object ID. Check for a pattern.                          # filter the field to this value pattern.
1256              my $comparator = ($actualObjectID =~ /%/ ? "LIKE" : "=");                          push @fieldFilter, "$field LIKE ?";
1257              # Update the filter and the parameter list.                          # We must convert the pattern value to an SQL match pattern. First
1258              $filter = "$entityType(id) $comparator ? AND ";                          # we get a copy of it.
1259              push @params, $actualObjectID;                          my $actualPattern = $pattern;
1260          }                          # Now we escape the underscores. Underscores are an SQL wild card
1261          # It's time to begin making queries. We process one attribute key at a time, because                          # character, but they are used frequently in key names and object IDs.
1262          # each attribute is actually a different field in the database. We know here that                          $actualPattern =~ s/_/\\_/g;
1263          # all the keys we've collected are for the correct entity because we got them from                          # Add the escaped pattern to the bound parameter list.
1264          # the DBD. That's a good thing, because an invalid key name will cause an SQL error.                          push @parms, $actualPattern;
1265          for my $key (@fieldList) {                      }
1266              # Get all of the attribute values for this key.                  }
1267              my @dataRows = $self->GetAll([$entityType], "$filter$entityType($key) IS NOT NULL",                  # Form the filter for this field.
1268                                           \@params, ["$entityType(id)", "$entityType($key)"]);                  my $fieldFilterString = join(" OR ", @fieldFilter);
1269              # Process each value separately. We need to verify the values and reformat the                  push @filter, "($fieldFilterString)";
             # 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.  
1270              }              }
             # Here we've processed all the rows returned by GetAll. In general, there will  
             # be one row per object ID.  
1271          }          }
         # Here we've processed all the matching attribute keys.  
1272      }      }
1273      # Here we've processed all the entity types. That means @retVal has all the matching      # Now @filter contains one or more filter strings and @parms contains the parameter
1274      # results.      # values to bind to them.
1275        my $actualFilter = join(" AND ", @filter);
1276        # Now we're ready to make our query.
1277        my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1278        # Format the results.
1279        my @retVal = $self->_QueryResults($query, @values);
1280        # Return the rows found.
1281      return @retVal;      return @retVal;
1282  }  }
1283    
# Line 1195  Line 1292 
1292    
1293  =item objectID  =item objectID
1294    
1295  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.  
1296    
1297  =item key  =item key
1298    
1299  Attribute key name. This corresponds to the name of a field in the database.  Attribute key name.
1300    
1301  =item values  =item values
1302    
# Line 1225  Line 1319 
1319      } elsif (! @values) {      } elsif (! @values) {
1320          Confess("No values specified in AddAttribute call for key $key.");          Confess("No values specified in AddAttribute call for key $key.");
1321      } else {      } else {
1322          # 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
1323          # computing the object type and ID.          # into a scalar.
         my ($entityName, $id) = ComputeObjectTypeFromID($objectID);  
         # Form the values into a scalar.  
1324          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1325          # Insert the value.          # Connect the object to the key.
1326          $self->InsertValue($id, "$entityName($key)", $valueString);          $self->InsertObject('HasValueFor', { 'from-link' => $key,
1327                                                 'to-link'   => $objectID,
1328                                                 'value'     => $valueString,
1329                                           });
1330      }      }
1331      # Return a one. We do this for backward compatability.      # Return a one, indicating success. We do this for backward compatability.
1332      return 1;      return 1;
1333  }  }
1334    
# Line 1243  Line 1338 
1338    
1339  Delete the specified attribute key/value combination from the database.  Delete the specified attribute key/value combination from the database.
1340    
 The first form will connect to the database and release it. The second form  
 uses the database connection contained in the object.  
   
1341  =over 4  =over 4
1342    
1343  =item objectID  =item objectID
1344    
1345  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.  
1346    
1347  =item key  =item key
1348    
1349  Attribute key name. This corresponds to the name of a field in the database.  Attribute key name.
1350    
1351  =item values  =item values
1352    
1353  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
1354    will be deleted. Otherwise, only a matching value will be deleted.
1355    
1356  =back  =back
1357    
# Line 1275  Line 1365 
1365          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1366      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1367          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1368      } elsif (! @values) {      } elsif (scalar(@values) == 0) {
1369          Confess("No values specified in DeleteAttribute call for key $key.");          # Here we erase the entire key for this object.
1370            $self->DeleteRow('HasValueFor', $key, $objectID);
1371      } else {      } else {
1372          # Now compute the object type and ID.          # Here we erase the matching values.
         my ($entityName, $id) = ComputeObjectTypeFromID($objectID);  
         # Form the values into a scalar.  
1373          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1374          # Delete the value.          $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });
         $self->DeleteValue($entityName, $id, $key, $valueString);  
1375      }      }
1376      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1377      return 1;      return 1;
1378  }  }
1379    
1380    =head3 DeleteMatchingAttributes
1381    
1382    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1383    
1384    Delete all attributes that match the specified criteria. This is equivalent to
1385    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1386    row found.
1387    
1388    =over 4
1389    
1390    =item objectID
1391    
1392    ID of object whose attributes are to be deleted. If the attributes for multiple
1393    objects are to be deleted, this parameter can be specified as a list reference. If
1394    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1395    Finally, you can delete attributes for a range of object IDs by putting a percent
1396    sign (C<%>) at the end.
1397    
1398    =item key
1399    
1400    Attribute key name. A value of C<undef> or an empty string will match all
1401    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1402    specified as a list reference. Finally, you can delete attributes for a range of
1403    keys by putting a percent sign (C<%>) at the end.
1404    
1405    =item values
1406    
1407    List of the desired attribute values, section by section. If C<undef>
1408    or an empty string is specified, all values in that section will match. A
1409    generic match can be requested by placing a percent sign (C<%>) at the end.
1410    In that case, all values that match up to and not including the percent sign
1411    will match. You may also specify a regular expression enclosed
1412    in slashes. All values that match the regular expression will be deleted. For
1413    performance reasons, only values have this extra capability.
1414    
1415    =item RETURN
1416    
1417    Returns a list of tuples for the attributes that were deleted, in the
1418    same form as L</GetAttributes>.
1419    
1420    =back
1421    
1422    =cut
1423    
1424    sub DeleteMatchingAttributes {
1425        # Get the parameters.
1426        my ($self, $objectID, $key, @values) = @_;
1427        # Get the matching attributes.
1428        my @retVal = $self->GetAttributes($objectID, $key, @values);
1429        # Loop through the attributes, deleting them.
1430        for my $tuple (@retVal) {
1431            $self->DeleteAttribute(@{$tuple});
1432        }
1433        # Return the deleted attributes.
1434        return @retVal;
1435    }
1436    
1437  =head3 ChangeAttribute  =head3 ChangeAttribute
1438    
1439  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1333  Line 1478 
1478      } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {      } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {
1479          Confess("No new values specified in ChangeAttribute call for key $key.");          Confess("No new values specified in ChangeAttribute call for key $key.");
1480      } else {      } else {
1481          # Okay, now we do the change as a delete/add.          # We do the change as a delete/add.
1482          $self->DeleteAttribute($objectID, $key, @{$oldValues});          $self->DeleteAttribute($objectID, $key, @{$oldValues});
1483          $self->AddAttribute($objectID, $key, @{$newValues});          $self->AddAttribute($objectID, $key, @{$newValues});
1484      }      }
# Line 1343  Line 1488 
1488    
1489  =head3 EraseAttribute  =head3 EraseAttribute
1490    
1491  C<< $attrDB->EraseAttribute($entityName, $key); >>  C<< $attrDB->EraseAttribute($key); >>
1492    
1493  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
1494  key from the database; it merely removes all the values.  key from the database; it merely removes all the values.
1495    
1496  =over 4  =over 4
1497    
 =item entityName  
   
 Name of the entity to which the key belongs. If undefined, all entities will be  
 examined for the desired key.  
   
1498  =item key  =item key
1499    
1500  Key to erase.  Key to erase.
# Line 1365  Line 1505 
1505    
1506  sub EraseAttribute {  sub EraseAttribute {
1507      # Get the parameters.      # Get the parameters.
1508      my ($self, $entityName, $key) = @_;      my ($self, $key) = @_;
1509      # Determine the relevant entity types.      # Delete everything connected to the key.
1510      my @objects = ();      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
     if (! $entityName) {  
         push @objects, $self->GetEntityTypes();  
     } 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);  
         }  
     }  
1511      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1512      return 1;      return 1;
1513  }  }
1514    
1515  =head3 GetAttributeKeys  =head3 GetAttributeKeys
1516    
1517  C<< my @keyList = $attrDB->GetAttributeKeys($entityName); >>  C<< my @keyList = $attrDB->GetAttributeKeys($groupName); >>
1518    
1519  Return a list of the attribute keys for a particular entity type.  Return a list of the attribute keys for a particular group.
1520    
1521  =over 4  =over 4
1522    
1523  =item entityName  =item groupName
1524    
1525  Name of the entity whose keys are desired.  Name of the group whose keys are desired.
1526    
1527  =item RETURN  =item RETURN
1528    
1529  Returns a list of the attribute keys for the specified entity.  Returns a list of the attribute keys for the specified group.
1530    
1531  =back  =back
1532    
# Line 1408  Line 1534 
1534    
1535  sub GetAttributeKeys {  sub GetAttributeKeys {
1536      # Get the parameters.      # Get the parameters.
1537      my ($self, $entityName) = @_;      my ($self, $groupName) = @_;
1538      # Get the entity's secondary fields.      # Get the attributes for the specified group.
1539      my %keyList = $self->GetSecondaryFields($entityName);      my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(to-link) = ?", [$groupName],
1540                                    'IsInGroup(from-link)');
1541      # Return the keys.      # Return the keys.
1542      return sort keys %keyList;      return sort @groups;
1543  }  }
1544    
1545  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3