[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.10, Tue Nov 28 01:00:08 2006 UTC revision 1.11, Wed Nov 29 20:28:52 2006 UTC
# Line 22  Line 22 
22  however, to the attribute database only the ID matters. This will create  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  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  types, but it is more consistent with the original attribute implementation
25  in the SEED (which this implementation replaces.  in the SEED (which this implementation replaces).
26    
27  An I<assignment> relates a specific attribute key to a specific object.  The actual attribute values are stored as a relationship between the attribute
28  Each assignment contains one or more values.  keys and the objects. There can be multiple values for a single key/object pair.
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
# Line 121  Line 121 
121      return $retVal;      return $retVal;
122  }  }
123    
 =head3 AssignmentKey  
   
 C<< my $hashedValue = $attrDB->AssignmentKey($id, $keyName); >>  
   
 Return the hashed key used in the assignment table for the specified object ID and  
 key name.  
   
 =over 4  
   
 =item id  
   
 ID of the object relevant to the assignment.  
   
 =item keyName  
   
 Name of the key being assigned values.  
   
 =item RETURN  
   
 Returns the ID that would be used for an B<Assignment> instance representing this  
 key/id pair.  
   
 =back  
   
 =cut  
   
 sub AssignmentKey {  
     # Get the parameters.  
     my ($self, $id, $keyName) = @_;  
     # Compute the result.  
     my $retVal = $self->DigestKey("$keyName=$id");  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 GetAssignment  
   
 C<< my $assign = $attrDB->GetAssignment($id, $keyName); >>  
   
 Check for an assignment between the specified attribute key and the specified object ID.  
 If an assignment exists, a B<DBObject> for it will be returned. If it does not exist, an  
 undefined value will be returned.  
   
 =over 4  
   
 =item id  
   
 ID of the object relevant to the assignment.  
   
 =item keyName  
   
 Attribute key name for the attribute to which the assignment is to be made.  
   
 =item RETURN  
   
 Returns a B<DBObject> for the indicated assignment, or C<undef> if the assignment  
 does not exist.  
   
 =back  
   
 =cut  
   
 sub GetAssignment {  
     # Get the parameters.  
     my ($self, $id, $keyName) = @_;  
     # Compute the assignment key.  
     my $hashKey = $self->AssignmentKey($id, $keyName);  
     # Check for an assignment.  
     my $retVal = $self->GetEntity('Assignment', $hashKey);  
     # Return the result.  
     return $retVal;  
 }  
   
124  =head3 StoreAttributeKey  =head3 StoreAttributeKey
125    
126  C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>  C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>
# Line 318  Line 245 
245      # Get the parameters.      # Get the parameters.
246      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;
247      # Create the return variable.      # Create the return variable.
248      my $retVal = Stats->new("lineIn", "shortLine", "lineUsed");      my $retVal = Stats->new("lineIn", "shortLine", "newObject");
249      # Compute the minimum number of fields required in each input line.      # Compute the minimum number of fields required in each input line.
250      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;
251      # Insure the attribute key exists.      # Insure the attribute key exists.
# Line 326  Line 253 
253      if (! defined $found) {      if (! defined $found) {
254          Confess("Attribute key \"$keyName\" not found in database.");          Confess("Attribute key \"$keyName\" not found in database.");
255      } else {      } else {
256          # We need three load files: one for "IsKeyOf", one for "Assignment", and          # Erase the key's current values.
257          # one for "AssignmentValue".          $self->EraseAttribute($keyName);
258          my $isKeyOfFileName = "$FIG_Config::temp/IsKeyOf$$.dtx";          # Save a list of the object IDs we need to add.
259          my $isKeyOfH = Open(undef, ">$isKeyOfFileName");          my %objectIDs = ();
         my $assignmentFileName = "$FIG_Config::temp/Assignment.dtx";  
         my $assignmentH = Open(undef, ">$assignmentFileName");  
         my $assignmentValueFileName = "$FIG_Config::temp/Assignment.dtx";  
         my $assignmentValueH = Open(undef, ">$assignmentValueFileName");  
         # We also need a hash to track the assignments we find.  
         my %assignHash = ();  
         # Find out if we intend to erase the key before loading.  
         my $erasing = $options{erase} || 0;  
260          # Loop through the input file.          # Loop through the input file.
261          while (! eof $fh) {          while (! eof $fh) {
262              # Get the next line of the file.              # Get the next line of the file.
# Line 351  Line 270 
270                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
271                  # Denote we're using this input line.                  # Denote we're using this input line.
272                  $retVal->Add(lineUsed => 1);                  $retVal->Add(lineUsed => 1);
273                  # Now the fun begins. Find out if we need an assignment for this object ID.                  # Now the fun begins. Find out if we need to create a target object record for this object ID.
274                  my $assignKey = "$keyName=$id";                  if (! exists $objectIDs{$id}) {
275                  my $assignValue = $assignHash{$assignKey};                      my $found = $self->Exists('TargetObject', $id);
276                  if (! defined $assignValue) {                      if (! $found) {
277                      # Here we have a new assignment. If we are using an erased key,                          $self->InsertObject('TargetObject', { id => $id });
278                      # we will create an assignment object for it. Otherwise, we have                      }
279                      # to check the database. First, we get the digested value.                      $objectIDs{$id} = 1;
280                      $assignValue = $self->AssignmentKey($id, $keyName);                      $retVal->Add(newObject => 1);
281                      # If we're erasing, we always need to create an assignment, but if                  }
282                      # we're not erasing we need to check the keys.                  # Now we insert the attribute.
283                      if ($erasing || ! $self->Exists('Assignment', $assignValue)) {                  $self->InsertObject('HasValueFor', { from => $keyName, to => $id, value => $value });
284                          # Here we need to create the assignment.                  $retVal->Add(newValue => 1);
285                          Tracer::PutLine($assignmentH, [$assignValue, $id]);              }
                         Tracer::PutLine($isKeyOfH, [$keyName, $assignValue]);  
                         # Save the assignment key in the hash.  
                         $assignHash{$assignKey} = $assignValue;  
                         # Update the counter.  
                         $retVal->Add(newAssignment => 1);  
                     }  
                 }  
                 # Now we have the assignment ID, so we can attach the new value to the  
                 # assignment.  
                 Tracer::PutLine($assignmentValueH, [$assignValue, $value]);  
             }  
         }  
         # Close all the files.  
         close $assignmentH;  
         close $assignmentValueH;  
         close $isKeyOfH;  
         # If we are erasing, erase the old key values.  
         if ($erasing) {  
             $self->EraseAttribute($keyName);  
286          }          }
         # If there are new assignments, load them.  
         if ($retVal->Ask("newAssignment") > 0) {  
             my $ikoStats = $self->LoadTable($isKeyOfFileName, "IsKeyOf", 0);  
             $retVal->Accumulate($ikoStats);  
             my $aStats = $self->LoadTable($assignmentFileName, "Assignment", 0);  
             $retVal->Accumulate($aStats);  
         }  
         # Finally, load the values.  
         my $avStats = $self->LoadTable($assignmentValueFileName, "AssignmentValue", 0);  
         $retVal->Accumulate($avStats);  
287      }      }
288      # Return the statistics.      # Return the statistics.
289      return $retVal;      return $retVal;
# Line 552  Line 442 
442      return join("\n", @retVal, "");      return join("\n", @retVal, "");
443  }  }
444    
445    =head3 LoadAttributesFrom
446    
447    C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
448    
449    Load attributes from the specified tab-delimited file. Each line of the file must
450    contain an object ID in the first column, an attribute key name in the second
451    column, and attribute values in the remaining columns. The attribute values will
452    be assembled into a single value using the splitter code.
453    
454    =over 4
455    
456    =item fileName
457    
458    Name of the file from which to load the attributes.
459    
460    =item options
461    
462    Hash of options for modifying the load process.
463    
464    =item RETURN
465    
466    Returns a statistics object describing the load.
467    
468    =back
469    
470    Permissible option values are as follows.
471    
472    =over 4
473    
474    =item append
475    
476    If TRUE, then the attributes will be appended to existing data; otherwise, the
477    first time a key name is encountered, it will be erased.
478    
479    =back
480    
481    =cut
482    
483    sub LoadAttributesFrom {
484        # Get the parameters.
485        my ($self, $fileName, %options) = @_;
486        # Declare the return variable.
487        my $retVal = Stats->new('keys', 'values');
488        # Check for append mode.
489        my $append = ($options{append} ? 1 : 0);
490        # Create a hash of key names found.
491        my %keyHash = ();
492        # Open the file for input.
493        my $fh = Open(undef, "<$fileName");
494        # Loop through the file.
495        while (! eof $fh) {
496            my ($id, $key, @values) = Tracer::GetLine($fh);
497            $retVal->Add(linesIn => 1);
498            # Do some validation.
499            if (! defined($id)) {
500                # We ignore blank lines.
501                $retVal->Add(blankLines => 1);
502            } elsif (! defined($key)) {
503                # An ID without a key is a serious error.
504                my $lines = $retVal->Ask('linesIn');
505                Confess("Line $lines in $fileName has no attribute key.");
506            } else {
507                # Now we need to check for a new key.
508                if (! exists $keyHash{$key}) {
509                    # This is a new key. Verify that it exists.
510                    if (! $self->Exists('AttributeKey', $key)) {
511                        my $line = $retVal->Ask('linesIn');
512                        Confess("Attribute \"$key\" on line $line of $fileName not found in database.");
513                    } else {
514                        # Make sure we know this is no longer a new key.
515                        $keyHash{$key} = 1;
516                        $retVal->Add(keys => 1);
517                        # If this is NOT append mode, erase the key.
518                        if (! $append) {
519                            $self->EraseAttribute($key);
520                        }
521                    }
522                    Trace("Key $key found.") if T(3);
523                }
524                # Now we know the key is valid. Add this value.
525                $self->AddAttribute($id, $key, @values);
526                my $progress = $retVal->Add(values => 1);
527                Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
528    
529            }
530        }
531        # Return the result.
532        return $retVal;
533    }
534    
535    =head3 BackupAllAttributes
536    
537    C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
538    
539    Backup all of the attributes to a file. The attributes will be stored in a
540    tab-delimited file suitable for reloading via L</LoadAttributesFrom>.
541    
542    =over 4
543    
544    =item fileName
545    
546    Name of the file to which the attribute data should be backed up.
547    
548    =item options
549    
550    Hash of options for the backup.
551    
552    =item RETURN
553    
554    Returns a statistics object describing the backup.
555    
556    =back
557    
558    Currently there are no options defined.
559    
560    =cut
561    
562    sub BackupAllAttributes {
563        # Get the parameters.
564        my ($self, $fileName, %options) = @_;
565        # Declare the return variable.
566        my $retVal = Stats->new();
567        # Get a list of the keys.
568        my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
569        Trace(scalar(@keys) . " keys found during backup.") if T(2);
570        # Open the file for output.
571        my $fh = Open(undef, $fileName);
572        # Loop through the keys.
573        for my $key (@keys) {
574            Trace("Backing up attribute $key.") if T(3);
575            $retVal->Add(keys => 1);
576            # Loop through this key's values.
577            my $query = $self->Get(['HasValueFor'], "HasValueFor(to-link) = ?", [$key]);
578            my $valuesFound = 0;
579            while (my $line = $query->Fetch()) {
580                $valuesFound++;
581                # Get this row's data.
582                my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',
583                                         'HasValueFor(value)']);
584                # Write it to the file.
585                Tracer::PutLine($fh, \@row);
586            }
587            Trace("$valuesFound values backed up for key $key.") if T(3);
588            $retVal->Add(values => $valuesFound);
589        }
590        # Return the result.
591        return $retVal;
592    }
593    
594  =head3 FieldMenu  =head3 FieldMenu
595    
596  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>  C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>
# Line 924  Line 963 
963      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
964      # We will create one big honking query. The following hash will build the filter      # We will create one big honking query. The following hash will build the filter
965      # clause and a parameter list.      # clause and a parameter list.
966      my %data = ('IsKeyOf(from-link)' => $key, 'Assignment(object-id)' => $objectID);      my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);
967      my @filter = ();      my @filter = ();
968      my @parms = ();      my @parms = ();
969      # This next loop goes through the different fields that can be specified in the      # This next loop goes through the different fields that can be specified in the
# Line 960  Line 999 
999                          # filter the field to this value pattern.                          # filter the field to this value pattern.
1000                          push @fieldFilter, "$field LIKE ?";                          push @fieldFilter, "$field LIKE ?";
1001                          # We must convert the pattern value to an SQL match pattern. First                          # We must convert the pattern value to an SQL match pattern. First
1002                          # we chop off the percent sign. (Note that I eschew chop because I                          # we get a copy of it.
1003                          # want a copy of the string.                          my $actualPattern = $pattern;
                         my $actualPattern = substr($pattern, 0, -1);  
1004                          # Now we escape the underscores. Underscores are an SQL wild card                          # Now we escape the underscores. Underscores are an SQL wild card
1005                          # character, but they are used frequently in key names and object IDs.                          # character, but they are used frequently in key names and object IDs.
1006                          $actualPattern = s/_/\\_/g;                          $actualPattern =~ s/_/\\_/g;
1007                          # Add the escaped pattern to the bound parameter list.                          # Add the escaped pattern to the bound parameter list.
1008                          push @parms, $actualPattern;                          push @parms, $actualPattern;
1009                      }                      }
# Line 984  Line 1022 
1022      # Get the number of value sections we have to match.      # Get the number of value sections we have to match.
1023      my $sectionCount = scalar(@values);      my $sectionCount = scalar(@values);
1024      # Now we're ready to make our query.      # Now we're ready to make our query.
1025      my $query = $self->Get(['IsKeyOf', 'Assignment'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1026      # Loop through the assignments found.      # Loop through the assignments found.
1027      while (my $row = $query->Fetch()) {      while (my $row = $query->Fetch()) {
1028          # Get the current row's data.          # Get the current row's data.
1029          my ($id, $key, @valueStrings) = $row->Values(['Assignment(object-id)', 'IsKeyOf(from-link)',          my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1030                                                        'Assignment(value)']);                                                        'HasValueFor(value)']);
         # Process each value string individually.  
         for my $valueString (@valueStrings) {  
1031              # Break the value into sections.              # Break the value into sections.
1032              my @sections = split($self->{splitter}, $valueString);              my @sections = split($self->{splitter}, $valueString);
1033              # Match each section against the incoming values. We'll assume we're              # Match each section against the incoming values. We'll assume we're
# Line 1012  Line 1048 
1048                  push @retVal, [$id, $key, @sections];                  push @retVal, [$id, $key, @sections];
1049              }              }
1050          }          }
     }  
1051      # Return the rows found.      # Return the rows found.
1052      return @retVal;      return @retVal;
1053  }  }
# Line 1055  Line 1090 
1090      } elsif (! @values) {      } elsif (! @values) {
1091          Confess("No values specified in AddAttribute call for key $key.");          Confess("No values specified in AddAttribute call for key $key.");
1092      } else {      } else {
1093          # Okay, now we have some reason to believe we can do this. Get the key for          # Okay, now we have some reason to believe we can do this. Form the values
1094          # the relevant assignment.          # into a scalar.
         my $assignKey = $self->AssignmentKey($objectID, $key);  
         # Form the values into a scalar.  
1095          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1096          # See if the assignment exists.          # Connect the object to the key.
1097          my $found = $self->Exists('Assignment', $assignKey);          $self->InsertObject('HasValueFor', { 'from-link' => $key,
1098          if (! $found) {                                               'to-link'   => $objectID,
1099              # Here we have a new assignment. Insure that the key is valid.                                               'value'     => $valueString,
             $found = $self->Exists('AttributeKey', $key);  
             if (! $found) {  
                 Confess("Attribute key \"$key\" not found in database.");  
             } else {  
                 # The key is valid, so we can create a new assignment.  
                 $self->InsertObject('Assignment', { id => $assignKey,  
                                                     'object-id' => $objectID,  
                                                     value => [$valueString],  
                                                   });  
                 # Connect the assignment to the key.  
                 $self->InsertObject('IsKeyOf', { 'from-link' => $key,  
                                                  'to-link' => $assignKey,  
1100                                                 });                                                 });
1101              }              }
         } else {  
             # An assignment already exists. Add the new value to it.  
             $self->InsertValue($assignKey, 'Assignment(value)', $valueString);  
         }  
     }  
1102      # Return a one, indicating success. We do this for backward compatability.      # Return a one, indicating success. We do this for backward compatability.
1103      return 1;      return 1;
1104  }  }
# Line 1120  Line 1136 
1136          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1137      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1138          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1139        } elsif (scalar(@values) == 0) {
1140            # Here we erase the entire key.
1141            $self->EraseAttribute($key);
1142      } else {      } else {
1143          # Get the assignment key for this object/attribute pair.          # Here we erase the matching values.
         my $assignKey = $self->AssignmentKey($objectID, $key);  
         # Only proceed if it exists.  
         my $found = $self->Exists('Assignment', $assignKey);  
         if ($found && ! @values) {  
             # Here the caller wants to delete the entire assignment.  
             $self->Delete('Assignment', $assignKey);  
         } else {  
             # Here we're looking to delete only the one value. First, we get all  
             # the values currently present.  
             my @currentValues = $self->GetFlat(['Assignment'], "Assignment(id) = ?",  
                                                [$assignKey], 'Assignment(value)');  
             # Find our value amongst them.  
1144              my $valueString = join($self->{splitter}, @values);              my $valueString = join($self->{splitter}, @values);
1145              my @matches = grep { $_ eq $valueString } @currentValues;          $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });
             # Only proceed if we found it.  
             if (@matches) {  
                 # Find out if it's the only value.  
                 if (scalar(@matches) == scalar(@currentValues)) {  
                     # It is, so delete the assignment.  
                     $self->Delete('Assignment', $assignKey);  
                 } else {  
                     # It's not, so only delete the value itself.  
                     $self->DeleteValue('Assignment', $assignKey, 'value', $valueString);  
                 }  
             }  
         }  
1146      }      }
1147      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1148      return 1;      return 1;
# Line 1207  Line 1202 
1202    
1203  =head3 EraseAttribute  =head3 EraseAttribute
1204    
1205  C<< $attrDB->EraseAttribute($entityName, $key); >>  C<< $attrDB->EraseAttribute($key); >>
1206    
1207  Erase all values for the specified attribute key. This does not remove the  Erase all values for the specified attribute key. This does not remove the
1208  key from the database; it merely removes all the values.  key from the database; it merely removes all the values.

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3