[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.11, Wed Nov 29 20:28:52 2006 UTC revision 1.16, Wed Jan 24 09:50:29 2007 UTC
# Line 8  Line 8 
8      use strict;      use strict;
9      use Tracer;      use Tracer;
10      use ERDBLoad;      use ERDBLoad;
11        use Stats;
12    
13  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
14    
# Line 270  Line 271 
271                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
272                  # Denote we're using this input line.                  # Denote we're using this input line.
273                  $retVal->Add(lineUsed => 1);                  $retVal->Add(lineUsed => 1);
                 # Now the fun begins. Find out if we need to create a target object record for this object ID.  
                 if (! exists $objectIDs{$id}) {  
                     my $found = $self->Exists('TargetObject', $id);  
                     if (! $found) {  
                         $self->InsertObject('TargetObject', { id => $id });  
                     }  
                     $objectIDs{$id} = 1;  
                     $retVal->Add(newObject => 1);  
                 }  
274                  # Now we insert the attribute.                  # Now we insert the attribute.
275                  $self->InsertObject('HasValueFor', { from => $keyName, to => $id, value => $value });                  $self->InsertObject('HasValueFor', { from => $keyName, to => $id,
276                                                         keywords => $self->_KeywordString($keyName, $value),
277                                                         value => $value });
278                  $retVal->Add(newValue => 1);                  $retVal->Add(newValue => 1);
279              }              }
280          }          }
# Line 532  Line 526 
526      return $retVal;      return $retVal;
527  }  }
528    
529    =head3 BackupKeys
530    
531    C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
532    
533    Backup the attribute key information from the attribute database.
534    
535    =over 4
536    
537    =item fileName
538    
539    Name of the output file.
540    
541    =item options
542    
543    Options for modifying the backup process.
544    
545    =item RETURN
546    
547    Returns a statistics object for the backup.
548    
549    =back
550    
551    Currently there are no options. The backup is straight to a text file in
552    tab-delimited format. Each key is backup up to two lines. The first line
553    is all of the data from the B<AttributeKey> table. The second is a
554    tab-delimited list of all the groups.
555    
556    =cut
557    
558    sub BackupKeys {
559        # Get the parameters.
560        my ($self, $fileName, %options) = @_;
561        # Declare the return variable.
562        my $retVal = Stats->new();
563        # Open the output file.
564        my $fh = Open(undef, ">$fileName");
565        # Set up to read the keys.
566        my $keyQuery = $self->Get(['AttributeKey'], "", []);
567        # Loop through the keys.
568        while (my $keyData = $keyQuery->Fetch()) {
569            $retVal->Add(key => 1);
570            # Get the fields.
571            my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
572                                                              'AttributeKey(description)']);
573            # Escape any tabs or new-lines in the description.
574            my $escapedDescription = Tracer::Escape($description);
575            # Write the key data to the output.
576            Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
577            # Get the key's groups.
578            my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
579                                        'IsInGroup(to-link)');
580            $retVal->Add(memberships => scalar(@groups));
581            # Write them to the output. Note we put a marker at the beginning to insure the line
582            # is nonempty.
583            Tracer::PutLine($fh, ['#GROUPS', @groups]);
584        }
585        # Return the result.
586        return $retVal;
587    }
588    
589    =head3 RestoreKeys
590    
591    C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
592    
593    Restore the attribute keys and groups from a backup file.
594    
595    =over 4
596    
597    =item fileName
598    
599    Name of the file containing the backed-up keys. Each key has a pair of lines,
600    one containing the key data and one listing its groups.
601    
602    =back
603    
604    =cut
605    
606    sub RestoreKeys {
607        # Get the parameters.
608        my ($self, $fileName, %options) = @_;
609        # Declare the return variable.
610        my $retVal = Stats->new();
611        # Set up a hash to hold the group IDs.
612        my %groups = ();
613        # Open the file.
614        my $fh = Open(undef, "<$fileName");
615        # Loop until we're done.
616        while (! eof $fh) {
617            # Get a key record.
618            my ($id, $dataType, $description) = Tracer::GetLine($fh);
619            if ($id eq '#GROUPS') {
620                Confess("Group record found when key record expected.");
621            } elsif (! defined($description)) {
622                Confess("Invalid format found for key record.");
623            } else {
624                $retVal->Add("keyIn" => 1);
625                # Add this key to the database.
626                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
627                                                      description => Tracer::UnEscape($description) });
628                Trace("Attribute $id stored.") if T(3);
629                # Get the group line.
630                my ($marker, @groups) = Tracer::GetLine($fh);
631                if (! defined($marker)) {
632                    Confess("End of file found where group record expected.");
633                } elsif ($marker ne '#GROUPS') {
634                    Confess("Group record not found after key record.");
635                } else {
636                    $retVal->Add(memberships => scalar(@groups));
637                    # Connect the groups.
638                    for my $group (@groups) {
639                        # Find out if this is a new group.
640                        if (! $groups{$group}) {
641                            $retVal->Add(newGroup => 1);
642                            # Add the group.
643                            $self->InsertObject('AttributeGroup', { id => $group });
644                            Trace("Group $group created.") if T(3);
645                            # Make sure we know it's not new.
646                            $groups{$group} = 1;
647                        }
648                        # Connect the group to our key.
649                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
650                    }
651                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
652                }
653            }
654        }
655        # Return the result.
656        return $retVal;
657    }
658    
659    
660  =head3 BackupAllAttributes  =head3 BackupAllAttributes
661    
662  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
# Line 568  Line 693 
693      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
694      Trace(scalar(@keys) . " keys found during backup.") if T(2);      Trace(scalar(@keys) . " keys found during backup.") if T(2);
695      # Open the file for output.      # Open the file for output.
696      my $fh = Open(undef, $fileName);      my $fh = Open(undef, ">$fileName");
697      # Loop through the keys.      # Loop through the keys.
698      for my $key (@keys) {      for my $key (@keys) {
699          Trace("Backing up attribute $key.") if T(3);          Trace("Backing up attribute $key.") if T(3);
700          $retVal->Add(keys => 1);          $retVal->Add(keys => 1);
701          # Loop through this key's values.          # Loop through this key's values.
702          my $query = $self->Get(['HasValueFor'], "HasValueFor(to-link) = ?", [$key]);          my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
703          my $valuesFound = 0;          my $valuesFound = 0;
704          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
705              $valuesFound++;              $valuesFound++;
706              # Get this row's data.              # Get this row's data.
707              my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',              my @row = $line->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
708                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
709              # Write it to the file.              # Write it to the file.
710              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, \@row);
# Line 851  Line 976 
976      return %retVal;      return %retVal;
977  }  }
978    
979    =head2 Internal Utility Methods
980    
981    =head3 _KeywordString
982    
983    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
984    
985    Compute the keyword string for a specified key/value pair. This consists of the
986    key name and value converted to lower case with underscores translated to spaces.
987    
988    This method is for internal use only. It is called whenever we need to update or
989    insert a B<HasValueFor> record.
990    
991    =over 4
992    
993    =item key
994    
995    Name of the relevant attribute key.
996    
997    =item target
998    
999    ID of the target object to which this key/value pair will be associated.
1000    
1001    =item value
1002    
1003    The value to store for this key/object combination.
1004    
1005    =item RETURN
1006    
1007    Returns the value that should be stored as the keyword string for the specified
1008    key/value pair.
1009    
1010    =back
1011    
1012    =cut
1013    
1014    sub _KeywordString {
1015        # Get the parameters.
1016        my ($self, $key, $value) = @_;
1017        # Get a copy of the key name and convert underscores to spaces.
1018        my $keywordString = $key;
1019        $keywordString =~ s/_/ /g;
1020        # Add the value convert it all to lower case.
1021        my $retVal = lc "$keywordString $value";
1022        # Return the result.
1023        return $retVal;
1024    }
1025    
1026    =head3 _QueryResults
1027    
1028    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1029    
1030    Match the results of a B<HasValueFor> query against value criteria and return
1031    the results. This is an internal method that splits the values coming back
1032    and matches the sections against the specified section patterns. It serves
1033    as the back end to L</GetAttributes> and L</FindAttributes>.
1034    
1035    =over 4
1036    
1037    =item query
1038    
1039    A query object that will return the desired B<HasValueFor> records.
1040    
1041    =item values
1042    
1043    List of the desired attribute values, section by section. If C<undef>
1044    or an empty string is specified, all values in that section will match. A
1045    generic match can be requested by placing a percent sign (C<%>) at the end.
1046    In that case, all values that match up to and not including the percent sign
1047    will match. You may also specify a regular expression enclosed
1048    in slashes. All values that match the regular expression will be returned. For
1049    performance reasons, only values have this extra capability.
1050    
1051    =item RETURN
1052    
1053    Returns a list of tuples. The first element in the tuple is an object ID, the
1054    second is an attribute key, and the remaining elements are the sections of
1055    the attribute value. All of the tuples will match the criteria set forth in
1056    the parameter list.
1057    
1058    =back
1059    
1060    =cut
1061    
1062    sub _QueryResults {
1063        # Get the parameters.
1064        my ($self, $query, @values) = @_;
1065        # Declare the return value.
1066        my @retVal = ();
1067        # Get the number of value sections we have to match.
1068        my $sectionCount = scalar(@values);
1069        # Loop through the assignments found.
1070        while (my $row = $query->Fetch()) {
1071            # Get the current row's data.
1072            my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1073                                                          'HasValueFor(value)']);
1074            # Break the value into sections.
1075            my @sections = split($self->{splitter}, $valueString);
1076            # Match each section against the incoming values. We'll assume we're
1077            # okay unless we learn otherwise.
1078            my $matching = 1;
1079            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1080                # We need to check to see if this section is generic.
1081                my $value = $values[$i];
1082                Trace("Current value pattern is \"$value\".") if T(4);
1083                if (substr($value, -1, 1) eq '%') {
1084                    Trace("Generic match used.") if T(4);
1085                    # Here we have a generic match.
1086                    my $matchLen = length($values[$i] - 1);
1087                    $matching = substr($sections[$i], 0, $matchLen) eq
1088                                substr($values[$i], 0, $matchLen);
1089                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1090                    Trace("Regular expression detected.") if T(4);
1091                    # Here we have a regular expression match.
1092                    my $section = $sections[$i];
1093                    $matching = eval("\$section =~ $value");
1094                } else {
1095                    # Here we have a strict match.
1096                    Trace("Strict match used.") if T(4);
1097                    $matching = ($sections[$i] eq $values[$i]);
1098                }
1099            }
1100            # If we match, output this row to the return list.
1101            if ($matching) {
1102                push @retVal, [$id, $key, @sections];
1103            }
1104        }
1105        # Return the rows found.
1106        return @retVal;
1107    }
1108    
1109  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1110    
1111  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.
# Line 945  Line 1200 
1200  or an empty string is specified, all values in that section will match. A  or an empty string is specified, all values in that section will match. A
1201  generic match can be requested by placing a percent sign (C<%>) at the end.  generic match can be requested by placing a percent sign (C<%>) at the end.
1202  In that case, all values that match up to and not including the percent sign  In that case, all values that match up to and not including the percent sign
1203  will match.  will match. You may also specify a regular expression enclosed
1204    in slashes. All values that match the regular expression will be returned. For
1205    performance reasons, only values have this extra capability.
1206    
1207  =item RETURN  =item RETURN
1208    
# Line 1017  Line 1274 
1274      # Now @filter contains one or more filter strings and @parms contains the parameter      # Now @filter contains one or more filter strings and @parms contains the parameter
1275      # values to bind to them.      # values to bind to them.
1276      my $actualFilter = join(" AND ", @filter);      my $actualFilter = join(" AND ", @filter);
     # Declare the return variable.  
     my @retVal = ();  
     # Get the number of value sections we have to match.  
     my $sectionCount = scalar(@values);  
1277      # Now we're ready to make our query.      # Now we're ready to make our query.
1278      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1279      # Loop through the assignments found.      # Format the results.
1280      while (my $row = $query->Fetch()) {      my @retVal = $self->_QueryResults($query, @values);
         # Get the current row's data.  
         my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',  
                                                       'HasValueFor(value)']);  
         # Break the value into sections.  
         my @sections = split($self->{splitter}, $valueString);  
         # Match each section against the incoming values. We'll assume we're  
         # okay unless we learn otherwise.  
         my $matching = 1;  
         for (my $i = 0; $i < $sectionCount && $matching; $i++) {  
             # We need to check to see if this section is generic.  
             if (substr($values[$i], -1, 1) eq '%') {  
                 my $matchLen = length($values[$i] - 1);  
                 $matching = substr($sections[$i], 0, $matchLen) eq  
                             substr($values[$i], 0, $matchLen);  
             } else {  
                 $matching = ($sections[$i] eq $values[$i]);  
             }  
         }  
         # If we match, output this row to the return list.  
         if ($matching) {  
             push @retVal, [$id, $key, @sections];  
         }  
     }  
1281      # Return the rows found.      # Return the rows found.
1282      return @retVal;      return @retVal;
1283  }  }
1284    
1285    =head3 FindAttributes
1286    
1287    C<< my @attributeList = $attrDB->FindAttributes($searchString); >>
1288    
1289    Search for attributes relevant to a specified keyword. This method performs
1290    a full-text search for attribute data. It returns the same information as
1291    L</GetAttributes>, except instead of filtering on specific keys or objects we do
1292    a text search of the entire <strong>HasValueFor</strong> table.
1293    
1294    =over 4
1295    
1296    =item searchString
1297    
1298    Search string to use. The syntax is the same as it is for any ERDB keyword
1299    search.
1300    
1301    =item RETURN
1302    
1303    Returns a list of tuples. The first element in the tuple is an object ID, the
1304    second is an attribute key, and the remaining elements are the sections of
1305    the attribute value. All of the tuples will match the criteria expressed in
1306    the search string.
1307    
1308    =back
1309    
1310    =cut
1311    
1312    sub FindAttributes {
1313        # Get the parameters.
1314        my ($self, $searchString) = @_;
1315        # Search the database.
1316        my $query = $self->Search($searchString, 0, ['HasValueFor'], "", []);
1317        # Build the results from the query.
1318        my @retVal = $self->_QueryResults($query);
1319        # Return the result.
1320        return @retVal;
1321    }
1322    
1323  =head3 AddAttribute  =head3 AddAttribute
1324    
1325  C<< $attrDB->AddAttribute($objectID, $key, @values); >>  C<< $attrDB->AddAttribute($objectID, $key, @values); >>
# Line 1096  Line 1364 
1364          # Connect the object to the key.          # Connect the object to the key.
1365          $self->InsertObject('HasValueFor', { 'from-link' => $key,          $self->InsertObject('HasValueFor', { 'from-link' => $key,
1366                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1367                                                 'keywords' => $self->_KeywordString($key, $valueString),
1368                                               'value'     => $valueString,                                               'value'     => $valueString,
1369                                         });                                         });
1370      }      }
# Line 1137  Line 1406 
1406      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1407          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1408      } elsif (scalar(@values) == 0) {      } elsif (scalar(@values) == 0) {
1409          # Here we erase the entire key.          # Here we erase the entire key for this object.
1410          $self->EraseAttribute($key);          $self->DeleteRow('HasValueFor', $key, $objectID);
1411      } else {      } else {
1412          # Here we erase the matching values.          # Here we erase the matching values.
1413          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
# Line 1148  Line 1417 
1417      return 1;      return 1;
1418  }  }
1419    
1420    =head3 DeleteMatchingAttributes
1421    
1422    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1423    
1424    Delete all attributes that match the specified criteria. This is equivalent to
1425    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1426    row found.
1427    
1428    =over 4
1429    
1430    =item objectID
1431    
1432    ID of object whose attributes are to be deleted. If the attributes for multiple
1433    objects are to be deleted, this parameter can be specified as a list reference. If
1434    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1435    Finally, you can delete attributes for a range of object IDs by putting a percent
1436    sign (C<%>) at the end.
1437    
1438    =item key
1439    
1440    Attribute key name. A value of C<undef> or an empty string will match all
1441    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1442    specified as a list reference. Finally, you can delete attributes for a range of
1443    keys by putting a percent sign (C<%>) at the end.
1444    
1445    =item values
1446    
1447    List of the desired attribute values, section by section. If C<undef>
1448    or an empty string is specified, all values in that section will match. A
1449    generic match can be requested by placing a percent sign (C<%>) at the end.
1450    In that case, all values that match up to and not including the percent sign
1451    will match. You may also specify a regular expression enclosed
1452    in slashes. All values that match the regular expression will be deleted. For
1453    performance reasons, only values have this extra capability.
1454    
1455    =item RETURN
1456    
1457    Returns a list of tuples for the attributes that were deleted, in the
1458    same form as L</GetAttributes>.
1459    
1460    =back
1461    
1462    =cut
1463    
1464    sub DeleteMatchingAttributes {
1465        # Get the parameters.
1466        my ($self, $objectID, $key, @values) = @_;
1467        # Get the matching attributes.
1468        my @retVal = $self->GetAttributes($objectID, $key, @values);
1469        # Loop through the attributes, deleting them.
1470        for my $tuple (@retVal) {
1471            $self->DeleteAttribute(@{$tuple});
1472        }
1473        # Return the deleted attributes.
1474        return @retVal;
1475    }
1476    
1477  =head3 ChangeAttribute  =head3 ChangeAttribute
1478    
1479  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1220  Line 1546 
1546  sub EraseAttribute {  sub EraseAttribute {
1547      # Get the parameters.      # Get the parameters.
1548      my ($self, $key) = @_;      my ($self, $key) = @_;
1549      # Delete everything connected to the key. The "keepRoot" option keeps the key in the      # Delete everything connected to the key.
1550      # datanase while deleting everything attached to it.      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
     $self->Delete('AttributeKey', $key, keepRoot => 1);  
1551      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1552      return 1;      return 1;
1553  }  }

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3