[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.10, Tue Nov 28 01:00:08 2006 UTC
# Line 15  Line 15 
15    
16  The Custom SEED Attributes Manager allows the user to upload and retrieve  The Custom SEED Attributes Manager allows the user to upload and retrieve
17  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
18  store the attributes, which are implemented as multi-valued fields  store the attributes.
19  of ERDB entities.  
20    Attributes are organized by I<attribute key>. Attribute values are
21    assigned to I<objects>. In the real world, objects have types and IDs;
22    however, to the attribute database only the ID matters. This will create
23    a problem if we have a single ID that applies to two objects of different
24    types, but it is more consistent with the original attribute implementation
25    in the SEED (which this implementation replaces.
26    
27    An I<assignment> relates a specific attribute key to a specific object.
28    Each assignment contains one or more values.
29    
30  The full suite of ERDB retrieval capabilities is provided. In addition,  The full suite of ERDB retrieval capabilities is provided. In addition,
31  custom methods are provided specific to this application. To get all  custom methods are provided specific to this application. To get all
32  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
33  would code  would code
34    
35      my @values = $attrDB->GetAttributes([Feature => $fid], 'essential');      my @values = $attrDB->GetAttributes($fid, 'essential');
36    
37  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.  
38    
39  New attributes are introduced by updating the database definition at  New attribute keys must be defined before they can be used. A web interface
40  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.  
41    
42  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
43    
# Line 76  Line 83 
83    
84  =back  =back
85    
 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.  
   
86  =head2 Public Methods  =head2 Public Methods
87    
88  =head3 new  =head3 new
89    
90  C<< my $attrDB = CustomAttributes->new($splitter); >>  C<< my $attrDB = CustomAttributes->new($splitter); >>
91    
92  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.  
93    
94  =over 4  =over 4
95    
# Line 157  Line 121 
121      return $retVal;      return $retVal;
122  }  }
123    
124  =head3 StoreAttributeKey  =head3 AssignmentKey
125    
126    C<< my $hashedValue = $attrDB->AssignmentKey($id, $keyName); >>
127    
128    Return the hashed key used in the assignment table for the specified object ID and
129    key name.
130    
131    =over 4
132    
133    =item id
134    
135    ID of the object relevant to the assignment.
136    
137    =item keyName
138    
139    Name of the key being assigned values.
140    
141    =item RETURN
142    
143    Returns the ID that would be used for an B<Assignment> instance representing this
144    key/id pair.
145    
146    =back
147    
148    =cut
149    
150    sub AssignmentKey {
151        # Get the parameters.
152        my ($self, $id, $keyName) = @_;
153        # Compute the result.
154        my $retVal = $self->DigestKey("$keyName=$id");
155        # Return the result.
156        return $retVal;
157    }
158    
159    =head3 GetAssignment
160    
161  C<< my $attrDB = CustomAttributes::StoreAttributeKey($entityName, $attributeName, $type, $notes); >>  C<< my $assign = $attrDB->GetAssignment($id, $keyName); >>
162    
163  Create or update an attribute for the database. This method will update the database definition  Check for an assignment between the specified attribute key and the specified object ID.
164  XML, but it will not create the table. It will connect to the database so that the caller  If an assignment exists, a B<DBObject> for it will be returned. If it does not exist, an
165  can upload the attribute values.  undefined value will be returned.
166    
167  =over 4  =over 4
168    
169  =item entityName  =item id
170    
171  Name of the entity containing the attribute. The entity must exist.  ID of the object relevant to the assignment.
172    
173    =item keyName
174    
175    Attribute key name for the attribute to which the assignment is to be made.
176    
177    =item RETURN
178    
179    Returns a B<DBObject> for the indicated assignment, or C<undef> if the assignment
180    does not exist.
181    
182    =back
183    
184    =cut
185    
186    sub GetAssignment {
187        # Get the parameters.
188        my ($self, $id, $keyName) = @_;
189        # Compute the assignment key.
190        my $hashKey = $self->AssignmentKey($id, $keyName);
191        # Check for an assignment.
192        my $retVal = $self->GetEntity('Assignment', $hashKey);
193        # Return the result.
194        return $retVal;
195    }
196    
197    =head3 StoreAttributeKey
198    
199    C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>
200    
201    Create or update an attribute for the database.
202    
203    =over 4
204    
205  =item attributeName  =item attributeName
206    
# Line 185  Line 216 
216    
217  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.
218    
219  =item RETURN  =item groups
220    
221  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.
222  error will be thrown.  This will replace any groups to which the attribute is currently attached.
223    
224  =back  =back
225    
# Line 196  Line 227 
227    
228  sub StoreAttributeKey {  sub StoreAttributeKey {
229      # Get the parameters.      # Get the parameters.
230      my ($entityName, $attributeName, $type, $notes) = @_;      my ($self, $attributeName, $type, $notes, $groups) = @_;
231      # Declare the return variable.      # Declare the return variable.
232      my $retVal;      my $retVal;
233      # Get the data type hash.      # Get the data type hash.
# Line 208  Line 239 
239          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
240      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
241          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.");  
242      } else {      } else {
243          # 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.
244          my $entityData = $entityHash->{$entityName};          my $attribute = $self->GetEntity('AttributeKey', $attributeName);
245          my $fieldHash = ERDB::GetEntityFieldHash($metadata, $entityName);          if (defined($attribute)) {
246          # Compare the old attribute data to the new data.              # It does, so we do an update.
247          my $bigChange = 1;              $self->UpdateEntity('AttributeKey', $attributeName,
248          if (exists $fieldHash->{$attributeName} && $fieldHash->{$attributeName}->{type} eq $type) {                                  { description => $notes, 'data-type' => $type });
249              $bigChange = 0;              # Detach the key from its current groups.
250          }              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
251          # Compute the attribute's relation name.          } else {
252          my $relName = join("", $entityName, map { ucfirst $_ } split(/-|_/, $attributeName));              # It doesn't, so we do an insert.
253          # Store the attribute's field data. Note the use of the "content" hash for              $self->InsertObject('AttributeKey', { id => $attributeName,
254          # the notes. This is how the XML writer knows Notes is a text tag instead of                                  description => $notes, 'data-type' => $type });
255          # an attribute.          }
256          $fieldHash->{$attributeName} = { type => $type, relation => $relName,          # Attach the key to the specified groups. (We presume the groups already
257                                           Notes => { content => $notes } };          # exist.)
258          # Insure we have an index for this attribute.          for my $group (@{$groups}) {
259          my $index = ERDB::FindIndexForEntity($metadata, $entityName, $attributeName);              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
260          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);  
261          }          }
262      }      }
     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);  
         }  
     }  
     # 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);  
263  }  }
264    
265  =head3 LoadAttributeKey  =head3 LoadAttributeKey
266    
267  C<< my $stats = $attrDB->LoadAttributeKey($entityName, $fieldName, $fh, $keyCol, $dataCol); >>  C<< my $stats = $attrDB->LoadAttributeKey($keyName, $fh, $keyCol, $dataCol, %options); >>
268    
269  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
270  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
271  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
272  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
273  corresponding attribute value.  corresponding attribute value.
274    
275  =over 4  =over 4
276    
277  =item entityName  =item keyName
   
 Name of the entity containing the attribute.  
278    
279  =item fieldName  Key of the attribute to load.
   
 Name of the actual attribute.  
280    
281  =item fh  =item fh
282    
283  Open file handle for the input file.  Open file handle for the input file.
284    
285  =item keyCol  =item idCol
286    
287  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
288  contain the ID of an instance of the named entity.  contain the ID of an instance of the named entity.
289    
290  =item dataCol  =item dataCol
291    
292  Index (0-based) of the column containing the data value field.  Index (0-based) of the column containing the data value field.
293    
294    =item options
295    
296    Hash specifying the options for this load.
297    
298  =item RETURN  =item RETURN
299    
300  Returns a statistics object for the load process.  Returns a statistics object for the load process.
301    
302  =back  =back
303    
304    The available options are as follows.
305    
306    =over 4
307    
308    =item erase
309    
310    If TRUE, the key's values will all be erased before loading. (Doing so
311    makes for a faster load.)
312    
313    =back
314    
315  =cut  =cut
316    
317  sub LoadAttributeKey {  sub LoadAttributeKey {
318      # Get the parameters.      # Get the parameters.
319      my ($self, $entityName, $fieldName, $fh, $keyCol, $dataCol) = @_;      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;
320      # Create the return variable.      # Create the return variable.
321      my $retVal;      my $retVal = Stats->new("lineIn", "shortLine", "lineUsed");
322      # Insure the entity exists.      # Compute the minimum number of fields required in each input line.
323      my $found = grep { $_ eq $entityName } $self->GetEntityTypes();      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;
324      if (! $found) {      # Insure the attribute key exists.
325          Confess("Entity \"$entityName\" not found in database.");      my $found = $self->GetEntity('AttributeKey', $keyName);
326        if (! defined $found) {
327            Confess("Attribute key \"$keyName\" not found in database.");
328      } else {      } else {
329          # Get the field structure for the named entity.          # We need three load files: one for "IsKeyOf", one for "Assignment", and
330          my $fieldHash = $self->GetFieldTable($entityName);          # one for "AssignmentValue".
331          # Verify that the attribute exists.          my $isKeyOfFileName = "$FIG_Config::temp/IsKeyOf$$.dtx";
332          if (! exists $fieldHash->{$fieldName}) {          my $isKeyOfH = Open(undef, ">$isKeyOfFileName");
333              Confess("Attribute key \"$fieldName\" does not exist in entity $entityName.");          my $assignmentFileName = "$FIG_Config::temp/Assignment.dtx";
334          } else {          my $assignmentH = Open(undef, ">$assignmentFileName");
335              # Create a loader for the specified attribute. We need the          my $assignmentValueFileName = "$FIG_Config::temp/Assignment.dtx";
336              # relation name first.          my $assignmentValueH = Open(undef, ">$assignmentValueFileName");
337              my $relName = $fieldHash->{$fieldName}->{relation};          # We also need a hash to track the assignments we find.
338              my $loadAttribute = ERDBLoad->new($self, $relName, $FIG_Config::temp);          my %assignHash = ();
339            # Find out if we intend to erase the key before loading.
340            my $erasing = $options{erase} || 0;
341              # Loop through the input file.              # Loop through the input file.
342              while (! eof $fh) {              while (! eof $fh) {
343                  # Get the next line of the file.                  # Get the next line of the file.
344                  my @fields = Tracer::GetLine($fh);                  my @fields = Tracer::GetLine($fh);
345                  $loadAttribute->Add("lineIn");              $retVal->Add(lineIn => 1);
346                  # Now we need to validate the line.                  # Now we need to validate the line.
347                  if ($#fields < $dataCol) {              if (scalar(@fields) < $minCols) {
348                      $loadAttribute->Add("shortLine");                  $retVal->Add(shortLine => 1);
                 } elsif (! $self->Exists($entityName, $fields[$keyCol])) {  
                     $loadAttribute->Add("badKey");  
349                  } else {                  } else {
350                      # It's valid,so send it to the loader.                  # It's valid, so get the ID and value.
351                      $loadAttribute->Put($fields[$keyCol], $fields[$dataCol]);                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
352                      $loadAttribute->Add("lineUsed");                  # Denote we're using this input line.
353                  }                  $retVal->Add(lineUsed => 1);
354              }                  # Now the fun begins. Find out if we need an assignment for this object ID.
355              # Finish the load.                  my $assignKey = "$keyName=$id";
356              $retVal = $loadAttribute->FinishAndLoad();                  my $assignValue = $assignHash{$assignKey};
357          }                  if (! defined $assignValue) {
358                        # Here we have a new assignment. If we are using an erased key,
359                        # we will create an assignment object for it. Otherwise, we have
360                        # to check the database. First, we get the digested value.
361                        $assignValue = $self->AssignmentKey($id, $keyName);
362                        # If we're erasing, we always need to create an assignment, but if
363                        # we're not erasing we need to check the keys.
364                        if ($erasing || ! $self->Exists('Assignment', $assignValue)) {
365                            # Here we need to create the assignment.
366                            Tracer::PutLine($assignmentH, [$assignValue, $id]);
367                            Tracer::PutLine($isKeyOfH, [$keyName, $assignValue]);
368                            # Save the assignment key in the hash.
369                            $assignHash{$assignKey} = $assignValue;
370                            # Update the counter.
371                            $retVal->Add(newAssignment => 1);
372                        }
373                    }
374                    # Now we have the assignment ID, so we can attach the new value to the
375                    # assignment.
376                    Tracer::PutLine($assignmentValueH, [$assignValue, $value]);
377                }
378            }
379            # Close all the files.
380            close $assignmentH;
381            close $assignmentValueH;
382            close $isKeyOfH;
383            # If we are erasing, erase the old key values.
384            if ($erasing) {
385                $self->EraseAttribute($keyName);
386            }
387            # If there are new assignments, load them.
388            if ($retVal->Ask("newAssignment") > 0) {
389                my $ikoStats = $self->LoadTable($isKeyOfFileName, "IsKeyOf", 0);
390                $retVal->Accumulate($ikoStats);
391                my $aStats = $self->LoadTable($assignmentFileName, "Assignment", 0);
392                $retVal->Accumulate($aStats);
393            }
394            # Finally, load the values.
395            my $avStats = $self->LoadTable($assignmentValueFileName, "AssignmentValue", 0);
396            $retVal->Accumulate($avStats);
397      }      }
398      # Return the statistics.      # Return the statistics.
399      return $retVal;      return $retVal;
# Line 386  Line 402 
402    
403  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
404    
405  C<< CustomAttributes::DeleteAttributeKey($entityName, $attributeName); >>  C<< my $stats = $attrDB->DeleteAttributeKey($attributeName); >>
406    
407  Delete an attribute from the custom attributes database.  Delete an attribute from the custom attributes database.
408    
409  =over 4  =over 4
410    
 =item entityName  
   
 Name of the entity possessing the attribute.  
   
411  =item attributeName  =item attributeName
412    
413  Name of the attribute to delete.  Name of the attribute to delete.
414    
415    =item RETURN
416    
417    Returns a statistics object describing the effects of the deletion.
418    
419  =back  =back
420    
421  =cut  =cut
422    
423  sub DeleteAttributeKey {  sub DeleteAttributeKey {
424      # Get the parameters.      # Get the parameters.
425      my ($entityName, $attributeName) = @_;      my ($self, $attributeName) = @_;
426      # Read in the XML for the database defintion. We need to verify that      # Delete the attribute key.
427      # the named entity exists and it has the named attribute.      my $retVal = $self->Delete('AttributeKey', $attributeName);
428      my $metadata = ERDB::ReadMetaXML($FIG_Config::attrDBD);      # Return the result.
429      my $entityHash = $metadata->{Entities};      return $retVal;
430      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);  
         }  
431      }      }
432    
433    =head3 NewName
434    
435    C<< my $text = CustomAttributes::NewName(); >>
436    
437    Return the string used to indicate the user wants to add a new attribute.
438    
439    =cut
440    
441    sub NewName {
442        return "(new)";
443  }  }
444    
445  =head3 ControlForm  =head3 ControlForm
446    
447  C<< my $formHtml = $attrDB->ControlForm($cgi, $name); >>  C<< my $formHtml = $attrDB->ControlForm($cgi, $name, \%keys); >>
448    
449  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
450  attributes.  attributes. Only a subset of the attribute keys will be displayed, as
451    determined by the incoming list.
452    
453  =over 4  =over 4
454    
# Line 458  Line 460 
460    
461  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.
462    
463    =item keys
464    
465    Reference to a hash mapping attribute keys to n-tuples. Each tuple will contain the
466    attribute's data type, its description, and a list of the groups in which it participates.
467    
468  =item RETURN  =item RETURN
469    
470  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
471  for loading, creating, or deleting an attribute.  for loading, creating, displaying, changing, or deleting an attribute. Note that only the form
472    controls are generated. The form tags are left to the caller.
473    
474  =back  =back
475    
# Line 469  Line 477 
477    
478  sub ControlForm {  sub ControlForm {
479      # Get the parameters.      # Get the parameters.
480      my ($self, $cgi, $name) = @_;      my ($self, $cgi, $name, $keys) = @_;
481      # Declare the return list.      # Declare the return list.
482      my @retVal = ();      my @retVal = ();
     # Start the form. We use multipart to support the upload control.  
     push @retVal, $cgi->start_multipart_form(-name => $name);  
483      # 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.
484      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });      push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });
485      # The first row is for selecting the field name.      # The first row is for selecting the field name.
486      push @retVal, $cgi->Tr($cgi->th("Select a Field"),      push @retVal, $cgi->Tr($cgi->th("Select a Field"),
487                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', 1,                             $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', $keys,
488                                                       "document.$name.notes.value",                                                       new => 1,
489                                                       "document.$name.dataType.value")));                                                       notes => "document.$name.notes.value",
490                                                         type => "document.$name.dataType.value",
491                                                         groups => "document.$name.groups")));
492      # 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
493      # data type names, and the labels will be the descriptions.      # data type names, and the labels will be the descriptions.
494      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
495      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;      my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;
496      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',      my $typeMenu = $cgi->popup_menu(-name   => 'dataType',
497                                      -values => [sort keys %types],                                      -values => [sort keys %types],
498                                      -labels => \%labelMap);                                      -labels => \%labelMap,
499                                        -default => 'string');
500        # Allow the user to specify a new field name. This is required if the
501        # user has selected the "(new)" marker. We put a little scriptlet in here that
502        # selects the (new) marker when the user enters the field.
503        push @retVal, "<script language=\"javaScript\">";
504        my $fieldField = "document.$name.fieldName";
505        my $newName = "\"" . NewName() . "\"";
506        push @retVal, $cgi->Tr($cgi->th("New Field Name"),
507                               $cgi->td($cgi->textfield(-name => 'newName',
508                                                        -size => 30,
509                                                        -value => "",
510                                                        -onFocus => "setIfEmpty($fieldField, $newName);")),
511                                        );
512      push @retVal, $cgi->Tr($cgi->th("Data type"),      push @retVal, $cgi->Tr($cgi->th("Data type"),
513                             $cgi->td($typeMenu));                             $cgi->td($typeMenu));
514      # The next row is for the notes.      # The next row is for the notes.
# Line 496  Line 517 
517                                                     -rows => 6,                                                     -rows => 6,
518                                                     -columns => 80))                                                     -columns => 80))
519                            );                            );
520      # 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.
521      # user has selected one of the "(new)" markers.      my @groups = $self->GetGroups();
522      push @retVal, $cgi->Tr($cgi->th("New Field Name"),      push @retVal, $cgi->Tr($cgi->th("Groups"),
523                             $cgi->td($cgi->textfield(-name => 'newName',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
524                                                      -size => 30)),                                      -values=> \@groups))
525                                      );                                      );
526      # 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
527      # an upload file name and column indicators.      # an upload file name and column indicators.
# Line 517  Line 538 
538                                                      -default => 1)                                                      -default => 1)
539                                     ),                                     ),
540                            );                            );
541      # Now the three buttons: UPDATE, SHOW, and DELETE.      # Now the three buttons: STORE, SHOW, and DELETE.
542      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
543                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'},
544                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .
# Line 527  Line 548 
548                            );                            );
549      # Close the table and the form.      # Close the table and the form.
550      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
     push @retVal, $cgi->end_form();  
551      # Return the assembled HTML.      # Return the assembled HTML.
552      return join("\n", @retVal, "");      return join("\n", @retVal, "");
553  }  }
554    
555  =head3 FieldMenu  =head3 FieldMenu
556    
557  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $newFlag, $noteControl, $typeControl); >>  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>
558    
559  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
560  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
561  CGI package, but actually looks like a list. The list will contain  CGI package, but actually looks like a list. The list will contain
562  one selectable row per field, grouped by entity.  one selectable row per field.
563    
564  =over 4  =over 4
565    
# Line 556  Line 576 
576  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
577  appear when the form is submitted.  appear when the form is submitted.
578    
579  =item newFlag (optional)  =item keys
580    
581    Reference to a hash mapping each attribute key name to a list reference,
582    the list itself consisting of the attribute data type, its description,
583    and a list of its groups.
584    
585    =item options
586    
587    Hash containing options that modify the generation of the menu.
588    
589    =item RETURN
590    
591    Returns the HTML to create a form field that can be used to select an
592    attribute from the custom attributes system.
593    
594    =back
595    
596    The permissible options are as follows.
597    
598    =over 4
599    
600    =item new
601    
602  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
603  a new attribute. In other words, the user can select an existing  a new attribute. In other words, the user can select an existing
604  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
605  be created in the parent entity.  be created in the parent entity.
606    
607  =item noteControl (optional)  =item notes
608    
609  If specified, the name of a variable for displaying the notes attached  If specified, the name of a variable for displaying the notes attached
610  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 615 
615  it is copied in. Specifying this parameter generates Javascript for  it is copied in. Specifying this parameter generates Javascript for
616  displaying the field description when a field is selected.  displaying the field description when a field is selected.
617    
618  =item typeControl (optional)  =item type
619    
620  If specified, the name of a variable for displaying the field's  If specified, the name of a variable for displaying the field's
621  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 623 
623  raw value is put into the specified variable. Otherwise, the same  raw value is put into the specified variable. Otherwise, the same
624  rules apply to this value that apply to I<$noteControl>.  rules apply to this value that apply to I<$noteControl>.
625    
626  =item RETURN  =item groups
627    
628  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
629  attribute from the custom attributes system.  a popup menu) which shall be used to display the selected groups.
630    
631  =back  =back
632    
# Line 593  Line 634 
634    
635  sub FieldMenu {  sub FieldMenu {
636      # Get the parameters.      # Get the parameters.
637      my ($self, $cgi, $height, $name, $newFlag, $noteControl, $typeControl) = @_;      my ($self, $cgi, $height, $name, $keys, %options) = @_;
638      # These next two hashes make everything happen. "entities"      # Reformat the list of keys.
639      # maps each entity name to the list of values to be put into its      my %keys = %{$keys};
640      # option group. "labels" maps each entity name to a map from values      # Add the (new) key, if needed.
641      # to labels.      if ($options{new}) {
642      my @entityNames = sort ($self->GetEntityTypes());          $keys{NewName()} = ["string", ""];
643      my %entities = map { $_ => [] } @entityNames;      }
644      my %labels = map { $_ => { }} @entityNames;      # Get a sorted list of key.
645      # Loop through the entities, adding the existing attributes.      my @keys = sort keys %keys;
646      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  
647      # 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
648      # for the menu.      # for the menu.
649      my $changeName = "${name}_setNotes";      my $changeName = "${name}_setNotes";
650      my $retVal = $cgi->popup_menu({name => $name,      my $retVal = $cgi->popup_menu({name => $name,
651                                     size => $height,                                     size => $height,
652                                     onChange => "$changeName(this.value)",                                     onChange => "$changeName(this.value)",
653                                     values => [map { $cgi->optgroup(-name => $_,                                     values => \@keys,
654                                                                     -values => $entities{$_},                                    });
                                                                    -labels => $labels{$_})  
                                                   } @entityNames]}  
                                  );  
655      # Create the change function.      # Create the change function.
656      $retVal .= "\n<script language=\"javascript\">\n";      $retVal .= "\n<script language=\"javascript\">\n";
657      $retVal .= "    function $changeName(fieldValue) {\n";      $retVal .= "    function $changeName(fieldValue) {\n";
658      # 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
659      if ($noteControl || $typeControl) {      # attribute.
660        if ($options{notes} || $options{type} || $options{groups}) {
661          # 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.
662            my $noteControl = $options{notes};
663          my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);          my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);
664          # 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
665          # field description will be stored in the JavaScript variable "myText"          # field description will be stored in the JavaScript variable "myText"
# Line 652  Line 668 
668          $retVal .= "        var myText = \"\";\n";          $retVal .= "        var myText = \"\";\n";
669          $retVal .= "        var myType = \"string\";\n";          $retVal .= "        var myType = \"string\";\n";
670          $retVal .= "        switch (fieldValue) {\n";          $retVal .= "        switch (fieldValue) {\n";
671          # Loop through the entities.          # Loop through the keys.
672          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};  
673                      # Generate this case.                      # Generate this case.
674                      $retVal .= "        case \"$value\" :\n";              $retVal .= "        case \"$key\" :\n";
675                      # Here we either want to update the note display, the                      # Here we either want to update the note display, the
676                      # type display, or both.              # type display, the group list, or a combination of them.
677                my ($type, $notes, @groups) = @{$keys{$key}};
678                      if ($noteControl) {                      if ($noteControl) {
                         # Here we want the notes updated.  
                         my $notes = $element->{Notes}->{content};  
679                          # Insure it's in the proper form.                          # Insure it's in the proper form.
680                          if ($htmlMode) {                          if ($htmlMode) {
681                              $notes = ERDB::HTMLNote($notes);                              $notes = ERDB::HTMLNote($notes);
# Line 679  Line 685 
685                          $notes =~ s/"/\\"/g;                          $notes =~ s/"/\\"/g;
686                          $retVal .= "           myText = \"$notes\";\n";                          $retVal .= "           myText = \"$notes\";\n";
687                      }                      }
688                      if ($typeControl) {              if ($options{type}) {
689                          # Here we want the type updated.                          # Here we want the type updated.
                         my $type = $element->{type};  
690                          $retVal .= "           myType = \"$type\";\n";                          $retVal .= "           myType = \"$type\";\n";
691                      }                      }
692                if ($options{groups}) {
693                    # Here we want the groups shown. Get a list of this attribute's groups.
694                    # We'll search through this list for each group to see if it belongs with
695                    # our attribute.
696                    my $groupLiteral = "=" . join("=", @groups) . "=";
697                    # Now we need some variables containing useful code for the javascript. It's
698                    # worth knowing we go through a bit of pain to insure $groupField[i] isn't
699                    # parsed as an array element.
700                    my $groupField = $options{groups};
701                    my $currentField = $groupField . "[i]";
702                    # Do the javascript.
703                    $retVal .= "           var groupList = \"$groupLiteral\";\n";
704                    $retVal .= "           for (var i = 0; i < $groupField.length; i++) {\n";
705                    $retVal .= "              var srchString = \"=\" + $currentField.value + \"=\";\n";
706                    $retVal .= "              var srchLoc = groupList.indexOf(srchString);\n";
707                    $retVal .= "              $currentField.checked = (srchLoc >= 0);\n";
708                    $retVal .= "           }\n";
709                }
710                      # Close this case.                      # Close this case.
711                      $retVal .= "           break;\n";                      $retVal .= "           break;\n";
712                  }                  }
             }  
         }  
713          # Close the CASE statement and make the appropriate assignments.          # Close the CASE statement and make the appropriate assignments.
714          $retVal .= "        }\n";          $retVal .= "        }\n";
715          if ($noteControl) {          if ($noteControl) {
716              $retVal .= "        $noteControl = myText;\n";              $retVal .= "        $noteControl = myText;\n";
717          }          }
718          if ($typeControl) {          if ($options{type}) {
719              $retVal .= "        $typeControl = myType;\n";              $retVal .= "        $options{type} = myType;\n";
720          }          }
721      }      }
722      # Terminate the change function.      # Terminate the change function.
# Line 705  Line 726 
726      return $retVal;      return $retVal;
727  }  }
728    
729  =head3 MatchSqlPattern  =head3 GetGroups
   
 C<< my $matched = CustomAttributes::MatchSqlPattern($value, $pattern); >>  
730    
731  Determine whether or not a specified value matches an SQL pattern. An SQL  C<< my @groups = $attrDB->GetGroups(); >>
 pattern has two wild card characters: C<%> that matches multiple characters,  
 and C<_> that matches a single character. These can be escaped using a  
 backslash (C<\>). We pull this off by converting the SQL pattern to a  
 PERL regular expression. As per SQL rules, the match is case-insensitive.  
732    
733  =over 4  Return a list of the available groups.
   
 =item value  
   
 Value to be matched against the pattern. Note that an undefined or empty  
 value will not match anything.  
   
 =item pattern  
   
 SQL pattern against which to match the value. An undefined or empty pattern will  
 match everything.  
   
 =item RETURN  
   
 Returns TRUE if the value and pattern match, else FALSE.  
   
 =back  
734    
735  =cut  =cut
736    
737  sub MatchSqlPattern {  sub GetGroups {
738      # Get the parameters.      # Get the parameters.
739      my ($value, $pattern) = @_;      my ($self) = @_;
740      # Declare the return variable.      # Get the groups.
741      my $retVal;      my @retVal = $self->GetFlat(['AttributeGroup'], "", [], 'AttributeGroup(id)');
742      # Insure we have a pattern.      # Return them.
743      if (! defined($pattern) || $pattern eq "") {      return @retVal;
         $retVal = 1;  
     } else {  
         # Break the pattern into pieces around the wildcard characters. Because we  
         # use parentheses in the split function's delimiter expression, we'll get  
         # list elements for the delimiters as well as the rest of the string.  
         my @pieces = split /([_%]|\\[_%])/, $pattern;  
         # Check some fast special cases.  
         if ($pattern eq '%') {  
             # A null pattern matches everything.  
             $retVal = 1;  
         } elsif (@pieces == 1) {  
             # No wildcards, so we have a literal comparison. Note we're case-insensitive.  
             $retVal = (lc($value) eq lc($pattern));  
         } elsif (@pieces == 2 && $pieces[1] eq '%') {  
             # A wildcard at the end, so we have a substring match. This is also case-insensitive.  
             $retVal = (lc(substr($value, 0, length($pieces[0]))) eq lc($pieces[0]));  
         } else {  
             # Okay, we have to do it the hard way. Convert each piece to a PERL pattern.  
             my $realPattern = "";  
             for my $piece (@pieces) {  
                 # Determine the type of piece.  
                 if ($piece eq "") {  
                     # Empty pieces are ignored.  
                 } elsif ($piece eq "%") {  
                     # Here we have a multi-character wildcard. Note that it can match  
                     # zero or more characters.  
                     $realPattern .= ".*"  
                 } elsif ($piece eq "_") {  
                     # Here we have a single-character wildcard.  
                     $realPattern .= ".";  
                 } elsif ($piece eq "\\%" || $piece eq "\\_") {  
                     # This is an escape sequence (which is a rare thing, actually).  
                     $realPattern .= substr($piece, 1, 1);  
                 } else {  
                     # Here we have raw text.  
                     $realPattern .= quotemeta($piece);  
                 }  
             }  
             # Do the match.  
             $retVal = ($value =~ /^$realPattern$/i ? 1 : 0);  
         }  
     }  
     # Return the result.  
     return $retVal;  
744  }  }
745    
746  =head3 MigrateAttributes  =head3 GetAttributeData
747    
748  C<< CustomAttributes::MigrateAttributes($fig); >>  C<< my %keys = $attrDB->GetAttributeData($type, @list); >>
749    
750  Migrate all the attributes data from the specified FIG instance. This is a long, slow  Return attribute data for the selected attributes. The attribute
751  method used to convert the old attribute data to the new system. Only attribute  data is a hash mapping each attribute key name to a n-tuple containing the
752  keys that are not already in the database will be loaded, and only for entity instances  data type, the description, and the groups. This is the same format expected in
753  current in the database. To get an accurate capture of the attributes in the given  the L</FieldMenu> and L</ControlForm> methods for the list of attributes to display.
 instance, you may want to clear the database and the DBD before starting and  
 run L</Refresh> to populate the entities.  
754    
755  =over 4  =over 4
756    
757  =item fig  =item type
   
 A FIG object that can be used to retrieve attributes for migration purposes.  
   
 =back  
   
 =cut  
   
 sub MigrateAttributes {  
     # Get the parameters.  
     my ($fig) = @_;  
     # Get a list of the objects to migrate. This requires connecting. Note we  
     # will map each entity type to a file name. The file will contain a list  
     # of the object's IDs so we can get to them when we're not connected to  
     # the database.  
     my $ca = CustomAttributes->new();  
     my %objects = map { $_ => "$FIG_Config::temp/$_.keys.tbl" } $ca->GetEntityTypes();  
     # Set up hash of the existing attribute keys for each entity type.  
     my %oldKeys = ();  
     # Finally, we have a hash that counts the IDs for each entity type.  
     my %idCounts = map { $_ => 0 } keys %objects;  
     # Loop through the list, creating key files to read back in.  
     for my $entityType (keys %objects) {  
         Trace("Retrieving keys for $entityType.") if T(2);  
         # Create the key file.  
         my $idFile = Open(undef, ">$objects{$entityType}");  
         # Loop through the keys.  
         my @ids = $ca->GetFlat([$entityType], "", [], "$entityType(id)");  
         for my $id (@ids) {  
             print $idFile "$id\n";  
         }  
         close $idFile;  
         # In addition to the key file, we must get a list of attributes already  
         # in the database. This avoids a circularity problem that might occur if the $fig  
         # object is retrieving from the custom attributes database already.  
         my %fields = $ca->GetSecondaryFields($entityType);  
         $oldKeys{$entityType} = \%fields;  
         # Finally, we have the ID count.  
         $idCounts{$entityType} = scalar @ids;  
     }  
     # Release the custom attributes database so we can add attributes.  
     undef $ca;  
     # Loop through the objects.  
     for my $entityType (keys %objects) {  
         # Get a hash of all the attributes already in this database. These are  
         # left untouched.  
         my $myOldKeys = $oldKeys{$entityType};  
         # Create a hash to control the load file names for each attribute key we find.  
         my %keyHash = ();  
         # Set up some counters so we can trace our progress.  
         my ($totalIDs, $processedIDs, $keyCount, $valueCount) = ($idCounts{$entityType}, 0, 0, 0);  
         # Open this object's ID file.  
         Trace("Migrating data for $entityType. $totalIDs found.") if T(3);  
         my $keysIn = Open(undef, "<$objects{$entityType}");  
         while (my $id = <$keysIn>) {  
             # Remove the EOL characters.  
             chomp $id;  
             # Get this object's attributes.  
             my @allData = $fig->get_attributes($id);  
             Trace(scalar(@allData) . " attribute values found for $entityType($id).") if T(4);  
             # Loop through the attribute values one at a time.  
             for my $dataTuple (@allData) {  
                 # Get the key, value, and URL. We ignore the first element because that's the  
                 # object ID, and we already know the object ID.  
                 my (undef, $key, $value, $url) = @{$dataTuple};  
                 # 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);  
 }  
   
 =head3 ComputeObjectTypeFromID  
   
 C<< my ($entityName, $id) = CustomAttributes::ComputeObjectTypeFromID($objectID); >>  
   
 This method will compute the entity type corresponding to a specified object ID.  
 If the object ID begins with C<fig|>, it is presumed to be a feature ID. If it  
 is all digits with a single period, it is presumed to by a genome ID. Otherwise,  
 it must be a list reference. In this last case the first list element will be  
 taken as the entity type and the second will be taken as the actual ID.  
758    
759  =over 4  Type of attribute criterion: C<name> for attributes whose names begin with the
760    specified string, or C<group> for attributes in the specified group.
761    
762  =item objectID  =item list
763    
764  Object ID to examine.  List containing the names of the groups or keys for the desired attributes.
765    
766  =item RETURN  =item RETURN
767    
768  Returns a 2-element list consisting of the entity type followed by the specified ID.  Returns a hash mapping each attribute key name to its data type, description, and
769    parent groups.
770    
771  =back  =back
772    
773  =cut  =cut
774    
775  sub ComputeObjectTypeFromID {  sub GetAttributeData {
776      # Get the parameters.      # Get the parameters.
777      my ($objectID) = @_;      my ($self, $type, @list) = @_;
778      # Declare the return variables.      # Set up a hash to store the attribute data.
779      my ($entityName, $id);      my %retVal = ();
780      # Only proceed if the object ID is defined. If it's not, we'll be returning a      # Loop through the list items.
781      # pair of undefs.      for my $item (@list) {
782      if ($objectID) {          # Set up a query for the desired attributes.
783          if (ref $objectID eq 'ARRAY') {          my $query;
784              # Here we have the new-style list reference. Pull out its pieces.          if ($type eq 'name') {
785              ($entityName, $id) = @{$objectID};              # Here we're doing a generic name search. We need to escape it and then tack
786          } else {              # on a %.
787              # Here the ID is the outgoing ID, and we need to look at its structure              my $parm = $item;
788              # to determine the entity type.              $parm =~ s/_/\\_/g;
789              $id = $objectID;              $parm =~ s/%/\\%/g;
790              if ($objectID =~ /^\d+\.\d+/) {              $parm .= "%";
791                  # Digits with a single period is a genome.              # Ask for matching attributes. (Note that if the user passed in a null string
792                  $entityName = 'Genome';              # he'll get everything.)
793              } elsif ($objectID =~ /^fig\|/) {              $query = $self->Get(['AttributeKey'], "AttributeKey(id) LIKE ?", [$parm]);
794                  # The "fig|" prefix indicates a feature.          } elsif ($type eq 'group') {
795                  $entityName = 'Feature';              $query = $self->Get(['IsInGroup', 'AttributeKey'], "IsInGroup(to-link) = ?", [$item]);
796              } else {              } else {
797                  # Anything else is illegal!              Confess("Unknown attribute query type \"$type\".");
798                  Confess("Invalid attribute ID specification \"$objectID\".");          }
799            while (my $row = $query->Fetch()) {
800                # Get this attribute's data.
801                my ($key, $type, $notes) = $row->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
802                                                         'AttributeKey(description)']);
803                # If it's new, get its groups and add it to the return hash.
804                if (! exists $retVal{$key}) {
805                    my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",
806                                                [$key], 'IsInGroup(to-link)');
807                    $retVal{$key} = [$type, $notes, @groups];
808              }              }
809          }          }
810      }      }
811      # Return the result.      # Return the result.
812      return ($entityName, $id);      return %retVal;
813  }  }
814    
815  =head2 FIG Method Replacements  =head2 FIG Method Replacements
816    
817  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.
818  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
819  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
820  capabilities were used in the old system.  capabilities were used in the old system.
821    
# Line 999  Line 829 
829  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
830  colons C<::>.  colons C<::>.
831    
832  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
833  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
834  splitter value would be stored as  splitter value would be stored as
835    
# Line 1010  Line 840 
840    
841  =head3 GetAttributes  =head3 GetAttributes
842    
843  C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @valuePatterns); >>  C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @values); >>
844    
845  In the database, attribute values are sectioned into pieces using a splitter  In the database, attribute values are sectioned into pieces using a splitter
846  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
847  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
848  these methods. If you are using the static method calls instead of the  these methods. If a value has multiple sections, each section
849  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.  
850    
851  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
852  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
853  method therefore correspond structurally to the values expected in each tuple.  method therefore correspond structurally to the values expected in each tuple. In
854    addition, you can ask for a generic search by suffixing a percent sign (C<%>) to any
855    of the parameters. So, for example,
856    
857      my @attributeList = GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);      my @attributeList = $attrDB->GetAttributes('fig|100226.1.peg.1004', 'structure%', 1, 2);
858    
859  would return something like  would return something like
860    
# Line 1033  Line 863 
863      ['fig}100226.1.peg.1004', 'structure2', 1, 2]      ['fig}100226.1.peg.1004', 'structure2', 1, 2]
864      ['fig}100226.1.peg.1004', 'structureA', 1, 2]      ['fig}100226.1.peg.1004', 'structureA', 1, 2]
865    
866  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
867  the I<$key> and I<@valuePatterns> parameters can contain SQL pattern characters: C<%>, which  a list reference in the ID column. Thus,
868  matches any sequence of characters, and C<_>, which matches any single character.  
869  (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');
870  underscore.)  
871    would get the PUBMED attribute data for Streptomyces coelicolor A3(2) and all its
872    features.
873    
874  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
875  values, so even  values, so even
876    
877      my @attributeList = GetAttributes($peg, 'virulent');      my @attributeList = $attrDB->GetAttributes($peg, 'virulent');
878    
879  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.
880    
881  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
882  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
883  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
884  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
885  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.  
886    
887  =over 4  =over 4
888    
889  =item objectID  =item objectID
890    
891  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
892  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
893  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
894  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.  
895    
896  =item key  =item key
897    
898  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
899  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
900  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
901  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.  
902    
903  =item valuePatterns  =item values
904    
905  List of the desired attribute values, section by section. If C<undef>  List of the desired attribute values, section by section. If C<undef>
906  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
907    generic match can be requested by placing a percent sign (C<%>) at the end.
908    In that case, all values that match up to and not including the percent sign
909    will match.
910    
911  =item RETURN  =item RETURN
912    
# Line 1107  Line 921 
921    
922  sub GetAttributes {  sub GetAttributes {
923      # Get the parameters.      # Get the parameters.
924      my ($self, $objectID, $key, @valuePatterns) = @_;      my ($self, $objectID, $key, @values) = @_;
925        # We will create one big honking query. The following hash will build the filter
926        # clause and a parameter list.
927        my %data = ('IsKeyOf(from-link)' => $key, 'Assignment(object-id)' => $objectID);
928        my @filter = ();
929        my @parms = ();
930        # This next loop goes through the different fields that can be specified in the
931        # parameter list and generates filters for each.
932        for my $field (keys %data) {
933            # Accumulate filter information for this field. We will OR together all the
934            # elements accumulated to create the final result.
935            my @fieldFilter = ();
936            # Get the specified data from the caller.
937            my $fieldPattern = $data{$field};
938            # Only proceed if the pattern is one that won't match everything.
939            if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {
940                # Convert the pattern to an array.
941                my @patterns = ();
942                if (ref $fieldPattern eq 'ARRAY') {
943                    push @patterns, @{$fieldPattern};
944                } else {
945                    push @patterns, $fieldPattern;
946                }
947                # Only proceed if the array is nonempty. The loop will work fine if the
948                # array is empty, but when we build the filter string at the end we'll
949                # get "()" in the filter list, which will result in an SQL syntax error.
950                if (@patterns) {
951                    # Loop through the individual patterns.
952                    for my $pattern (@patterns) {
953                        # Check for a generic request.
954                        if (substr($pattern, -1, 1) ne '%') {
955                            # Here we have a normal request.
956                            push @fieldFilter, "$field = ?";
957                            push @parms, $pattern;
958                        } else {
959                            # Here we have a generate request, so we will use the LIKE operator to
960                            # filter the field to this value pattern.
961                            push @fieldFilter, "$field LIKE ?";
962                            # We must convert the pattern value to an SQL match pattern. First
963                            # we chop off the percent sign. (Note that I eschew chop because I
964                            # want a copy of the string.
965                            my $actualPattern = substr($pattern, 0, -1);
966                            # Now we escape the underscores. Underscores are an SQL wild card
967                            # character, but they are used frequently in key names and object IDs.
968                            $actualPattern = s/_/\\_/g;
969                            # Add the escaped pattern to the bound parameter list.
970                            push @parms, $actualPattern;
971                        }
972                    }
973                    # Form the filter for this field.
974                    my $fieldFilterString = join(" OR ", @fieldFilter);
975                    push @filter, "($fieldFilterString)";
976                }
977            }
978        }
979        # Now @filter contains one or more filter strings and @parms contains the parameter
980        # values to bind to them.
981        my $actualFilter = join(" AND ", @filter);
982      # Declare the return variable.      # Declare the return variable.
983      my @retVal = ();      my @retVal = ();
984      # Determine the entity types for our search.      # Get the number of value sections we have to match.
985      my @objects = ();      my $sectionCount = scalar(@values);
986      my ($actualObjectID, $computedType);      # Now we're ready to make our query.
987      if (! $objectID) {      my $query = $self->Get(['IsKeyOf', 'Assignment'], $actualFilter, \@parms);
988          push @objects, $self->GetEntityTypes();      # Loop through the assignments found.
989        while (my $row = $query->Fetch()) {
990            # Get the current row's data.
991            my ($id, $key, @valueStrings) = $row->Values(['Assignment(object-id)', 'IsKeyOf(from-link)',
992                                                          'Assignment(value)']);
993            # Process each value string individually.
994            for my $valueString (@valueStrings) {
995                # Break the value into sections.
996                my @sections = split($self->{splitter}, $valueString);
997                # Match each section against the incoming values. We'll assume we're
998                # okay unless we learn otherwise.
999                my $matching = 1;
1000                for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1001                    # We need to check to see if this section is generic.
1002                    if (substr($values[$i], -1, 1) eq '%') {
1003                        my $matchLen = length($values[$i] - 1);
1004                        $matching = substr($sections[$i], 0, $matchLen) eq
1005                                    substr($values[$i], 0, $matchLen);
1006      } else {      } else {
1007          ($computedType, $actualObjectID) = ComputeObjectTypeFromID($objectID);                      $matching = ($sections[$i] eq $values[$i]);
         push @objects, $computedType;  
1008      }      }
     # Loop through the entity types.  
     for my $entityType (@objects) {  
         # Now we need to find all the matching keys. The keys are actually stored in  
         # our database object, so this process is fast. Note that our  
         # MatchSqlPattern method  
         my %secondaries = $self->GetSecondaryFields($entityType);  
         my @fieldList = grep { MatchSqlPattern($_, $key) } keys %secondaries;  
         # Now we figure out whether or not we need to filter by object. We will always  
         # filter by key to a limited extent, so if we're filtering by object we need an  
         # AND to join the object ID filter with the key filter.  
         my $filter = "";  
         my @params = ();  
         if (defined($actualObjectID)) {  
             # Here the caller wants to filter on object ID. Check for a pattern.  
             my $comparator = ($actualObjectID =~ /%/ ? "LIKE" : "=");  
             # Update the filter and the parameter list.  
             $filter = "$entityType(id) $comparator ? AND ";  
             push @params, $actualObjectID;  
         }  
         # It's time to begin making queries. We process one attribute key at a time, because  
         # each attribute is actually a different field in the database. We know here that  
         # all the keys we've collected are for the correct entity because we got them from  
         # the DBD. That's a good thing, because an invalid key name will cause an SQL error.  
         for my $key (@fieldList) {  
             # Get all of the attribute values for this key.  
             my @dataRows = $self->GetAll([$entityType], "$filter$entityType($key) IS NOT NULL",  
                                          \@params, ["$entityType(id)", "$entityType($key)"]);  
             # Process each value separately. We need to verify the values and reformat the  
             # tuples. Note that GetAll will give us one row per matching object ID,  
             # with the ID first followed by a list of the data values. This is very  
             # different from the structure we'll be returning, which has one row  
             # per value.  
             for my $dataRow (@dataRows) {  
                 # Get the object ID and the list of values.  
                 my ($rowObjectID, @dataValues) = @{$dataRow};  
                 # Loop through the values. There will be one result row per attribute value.  
                 for my $dataValue (@dataValues) {  
                     # Separate this value into sections.  
                     my @sections = split("::", $dataValue);  
                     # Loop through the value patterns, looking for a mismatch. Note that  
                     # since we're working through parallel arrays, we are using an index  
                     # loop. As soon as a match fails we stop checking. This means that  
                     # if the value pattern list is longer than the number of sections,  
                     # we will fail as soon as we run out of sections.  
                     my $match = 1;  
                     for (my $i = 0; $i <= $#valuePatterns && $match; $i++) {  
                         $match = MatchSqlPattern($sections[$i], $valuePatterns[$i]);  
                     }  
                     # If we match, we save this value in the output list.  
                     if ($match) {  
                         push @retVal, [$rowObjectID, $key, @sections];  
                     }  
                 }  
                 # Here we've processed all the attribute values for the current object ID.  
1009              }              }
1010              # Here we've processed all the rows returned by GetAll. In general, there will              # If we match, output this row to the return list.
1011              # be one row per object ID.              if ($matching) {
1012                    push @retVal, [$id, $key, @sections];
1013          }          }
         # Here we've processed all the matching attribute keys.  
1014      }      }
1015      # Here we've processed all the entity types. That means @retVal has all the matching      }
1016      # results.      # Return the rows found.
1017      return @retVal;      return @retVal;
1018  }  }
1019    
# Line 1195  Line 1028 
1028    
1029  =item objectID  =item objectID
1030    
1031  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.  
1032    
1033  =item key  =item key
1034    
1035  Attribute key name. This corresponds to the name of a field in the database.  Attribute key name.
1036    
1037  =item values  =item values
1038    
# Line 1225  Line 1055 
1055      } elsif (! @values) {      } elsif (! @values) {
1056          Confess("No values specified in AddAttribute call for key $key.");          Confess("No values specified in AddAttribute call for key $key.");
1057      } else {      } else {
1058          # 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. Get the key for
1059          # computing the object type and ID.          # the relevant assignment.
1060          my ($entityName, $id) = ComputeObjectTypeFromID($objectID);          my $assignKey = $self->AssignmentKey($objectID, $key);
1061          # Form the values into a scalar.          # Form the values into a scalar.
1062          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1063          # Insert the value.          # See if the assignment exists.
1064          $self->InsertValue($id, "$entityName($key)", $valueString);          my $found = $self->Exists('Assignment', $assignKey);
1065            if (! $found) {
1066                # Here we have a new assignment. Insure that the key is valid.
1067                $found = $self->Exists('AttributeKey', $key);
1068                if (! $found) {
1069                    Confess("Attribute key \"$key\" not found in database.");
1070                } else {
1071                    # The key is valid, so we can create a new assignment.
1072                    $self->InsertObject('Assignment', { id => $assignKey,
1073                                                        'object-id' => $objectID,
1074                                                        value => [$valueString],
1075                                                      });
1076                    # Connect the assignment to the key.
1077                    $self->InsertObject('IsKeyOf', { 'from-link' => $key,
1078                                                     'to-link' => $assignKey,
1079                                                   });
1080      }      }
1081      # Return a one. We do this for backward compatability.          } else {
1082                # An assignment already exists. Add the new value to it.
1083                $self->InsertValue($assignKey, 'Assignment(value)', $valueString);
1084            }
1085        }
1086        # Return a one, indicating success. We do this for backward compatability.
1087      return 1;      return 1;
1088  }  }
1089    
# Line 1243  Line 1093 
1093    
1094  Delete the specified attribute key/value combination from the database.  Delete the specified attribute key/value combination from the database.
1095    
 The first form will connect to the database and release it. The second form  
 uses the database connection contained in the object.  
   
1096  =over 4  =over 4
1097    
1098  =item objectID  =item objectID
1099    
1100  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.  
1101    
1102  =item key  =item key
1103    
1104  Attribute key name. This corresponds to the name of a field in the database.  Attribute key name.
1105    
1106  =item values  =item values
1107    
1108  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
1109    will be deleted. Otherwise, only a matching value will be deleted.
1110    
1111  =back  =back
1112    
# Line 1275  Line 1120 
1120          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1121      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1122          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
     } elsif (! @values) {  
         Confess("No values specified in DeleteAttribute call for key $key.");  
1123      } else {      } else {
1124          # Now compute the object type and ID.          # Get the assignment key for this object/attribute pair.
1125          my ($entityName, $id) = ComputeObjectTypeFromID($objectID);          my $assignKey = $self->AssignmentKey($objectID, $key);
1126          # Form the values into a scalar.          # Only proceed if it exists.
1127            my $found = $self->Exists('Assignment', $assignKey);
1128            if ($found && ! @values) {
1129                # Here the caller wants to delete the entire assignment.
1130                $self->Delete('Assignment', $assignKey);
1131            } else {
1132                # Here we're looking to delete only the one value. First, we get all
1133                # the values currently present.
1134                my @currentValues = $self->GetFlat(['Assignment'], "Assignment(id) = ?",
1135                                                   [$assignKey], 'Assignment(value)');
1136                # Find our value amongst them.
1137          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1138          # Delete the value.              my @matches = grep { $_ eq $valueString } @currentValues;
1139          $self->DeleteValue($entityName, $id, $key, $valueString);              # Only proceed if we found it.
1140                if (@matches) {
1141                    # Find out if it's the only value.
1142                    if (scalar(@matches) == scalar(@currentValues)) {
1143                        # It is, so delete the assignment.
1144                        $self->Delete('Assignment', $assignKey);
1145                    } else {
1146                        # It's not, so only delete the value itself.
1147                        $self->DeleteValue('Assignment', $assignKey, 'value', $valueString);
1148                    }
1149                }
1150            }
1151      }      }
1152      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1153      return 1;      return 1;
# Line 1333  Line 1197 
1197      } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {      } elsif (! defined($newValues) || ref $newValues ne 'ARRAY') {
1198          Confess("No new values specified in ChangeAttribute call for key $key.");          Confess("No new values specified in ChangeAttribute call for key $key.");
1199      } else {      } else {
1200          # Okay, now we do the change as a delete/add.          # We do the change as a delete/add.
1201          $self->DeleteAttribute($objectID, $key, @{$oldValues});          $self->DeleteAttribute($objectID, $key, @{$oldValues});
1202          $self->AddAttribute($objectID, $key, @{$newValues});          $self->AddAttribute($objectID, $key, @{$newValues});
1203      }      }
# Line 1350  Line 1214 
1214    
1215  =over 4  =over 4
1216    
 =item entityName  
   
 Name of the entity to which the key belongs. If undefined, all entities will be  
 examined for the desired key.  
   
1217  =item key  =item key
1218    
1219  Key to erase.  Key to erase.
# Line 1365  Line 1224 
1224    
1225  sub EraseAttribute {  sub EraseAttribute {
1226      # Get the parameters.      # Get the parameters.
1227      my ($self, $entityName, $key) = @_;      my ($self, $key) = @_;
1228      # Determine the relevant entity types.      # Delete everything connected to the key. The "keepRoot" option keeps the key in the
1229      my @objects = ();      # datanase while deleting everything attached to it.
1230      if (! $entityName) {      $self->Delete('AttributeKey', $key, keepRoot => 1);
         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);  
         }  
     }  
1231      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1232      return 1;      return 1;
1233  }  }
1234    
1235  =head3 GetAttributeKeys  =head3 GetAttributeKeys
1236    
1237  C<< my @keyList = $attrDB->GetAttributeKeys($entityName); >>  C<< my @keyList = $attrDB->GetAttributeKeys($groupName); >>
1238    
1239  Return a list of the attribute keys for a particular entity type.  Return a list of the attribute keys for a particular group.
1240    
1241  =over 4  =over 4
1242    
1243  =item entityName  =item groupName
1244    
1245  Name of the entity whose keys are desired.  Name of the group whose keys are desired.
1246    
1247  =item RETURN  =item RETURN
1248    
1249  Returns a list of the attribute keys for the specified entity.  Returns a list of the attribute keys for the specified group.
1250    
1251  =back  =back
1252    
# Line 1408  Line 1254 
1254    
1255  sub GetAttributeKeys {  sub GetAttributeKeys {
1256      # Get the parameters.      # Get the parameters.
1257      my ($self, $entityName) = @_;      my ($self, $groupName) = @_;
1258      # Get the entity's secondary fields.      # Get the attributes for the specified group.
1259      my %keyList = $self->GetSecondaryFields($entityName);      my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(to-link) = ?", [$groupName],
1260                                    'IsInGroup(from-link)');
1261      # Return the keys.      # Return the keys.
1262      return sort keys %keyList;      return sort @groups;
1263  }  }
1264    
1265  1;  1;

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3