[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.17, Thu Jan 25 02:41:12 2007 UTC
# Line 8  Line 8 
8      use strict;      use strict;
9      use Tracer;      use Tracer;
10      use ERDBLoad;      use ERDBLoad;
11        use Stats;
12    
13  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
14    
# Line 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                                                         value => $value });
277                  $retVal->Add(newValue => 1);                  $retVal->Add(newValue => 1);
278              }              }
279          }          }
# Line 532  Line 525 
525      return $retVal;      return $retVal;
526  }  }
527    
528    =head3 BackupKeys
529    
530    C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
531    
532    Backup the attribute key information from the attribute database.
533    
534    =over 4
535    
536    =item fileName
537    
538    Name of the output file.
539    
540    =item options
541    
542    Options for modifying the backup process.
543    
544    =item RETURN
545    
546    Returns a statistics object for the backup.
547    
548    =back
549    
550    Currently there are no options. The backup is straight to a text file in
551    tab-delimited format. Each key is backup up to two lines. The first line
552    is all of the data from the B<AttributeKey> table. The second is a
553    tab-delimited list of all the groups.
554    
555    =cut
556    
557    sub BackupKeys {
558        # Get the parameters.
559        my ($self, $fileName, %options) = @_;
560        # Declare the return variable.
561        my $retVal = Stats->new();
562        # Open the output file.
563        my $fh = Open(undef, ">$fileName");
564        # Set up to read the keys.
565        my $keyQuery = $self->Get(['AttributeKey'], "", []);
566        # Loop through the keys.
567        while (my $keyData = $keyQuery->Fetch()) {
568            $retVal->Add(key => 1);
569            # Get the fields.
570            my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
571                                                              'AttributeKey(description)']);
572            # Escape any tabs or new-lines in the description.
573            my $escapedDescription = Tracer::Escape($description);
574            # Write the key data to the output.
575            Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
576            # Get the key's groups.
577            my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
578                                        'IsInGroup(to-link)');
579            $retVal->Add(memberships => scalar(@groups));
580            # Write them to the output. Note we put a marker at the beginning to insure the line
581            # is nonempty.
582            Tracer::PutLine($fh, ['#GROUPS', @groups]);
583        }
584        # Return the result.
585        return $retVal;
586    }
587    
588    =head3 RestoreKeys
589    
590    C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
591    
592    Restore the attribute keys and groups from a backup file.
593    
594    =over 4
595    
596    =item fileName
597    
598    Name of the file containing the backed-up keys. Each key has a pair of lines,
599    one containing the key data and one listing its groups.
600    
601    =back
602    
603    =cut
604    
605    sub RestoreKeys {
606        # Get the parameters.
607        my ($self, $fileName, %options) = @_;
608        # Declare the return variable.
609        my $retVal = Stats->new();
610        # Set up a hash to hold the group IDs.
611        my %groups = ();
612        # Open the file.
613        my $fh = Open(undef, "<$fileName");
614        # Loop until we're done.
615        while (! eof $fh) {
616            # Get a key record.
617            my ($id, $dataType, $description) = Tracer::GetLine($fh);
618            if ($id eq '#GROUPS') {
619                Confess("Group record found when key record expected.");
620            } elsif (! defined($description)) {
621                Confess("Invalid format found for key record.");
622            } else {
623                $retVal->Add("keyIn" => 1);
624                # Add this key to the database.
625                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
626                                                      description => Tracer::UnEscape($description) });
627                Trace("Attribute $id stored.") if T(3);
628                # Get the group line.
629                my ($marker, @groups) = Tracer::GetLine($fh);
630                if (! defined($marker)) {
631                    Confess("End of file found where group record expected.");
632                } elsif ($marker ne '#GROUPS') {
633                    Confess("Group record not found after key record.");
634                } else {
635                    $retVal->Add(memberships => scalar(@groups));
636                    # Connect the groups.
637                    for my $group (@groups) {
638                        # Find out if this is a new group.
639                        if (! $groups{$group}) {
640                            $retVal->Add(newGroup => 1);
641                            # Add the group.
642                            $self->InsertObject('AttributeGroup', { id => $group });
643                            Trace("Group $group created.") if T(3);
644                            # Make sure we know it's not new.
645                            $groups{$group} = 1;
646                        }
647                        # Connect the group to our key.
648                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
649                    }
650                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
651                }
652            }
653        }
654        # Return the result.
655        return $retVal;
656    }
657    
658    
659  =head3 BackupAllAttributes  =head3 BackupAllAttributes
660    
661  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
# Line 568  Line 692 
692      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
693      Trace(scalar(@keys) . " keys found during backup.") if T(2);      Trace(scalar(@keys) . " keys found during backup.") if T(2);
694      # Open the file for output.      # Open the file for output.
695      my $fh = Open(undef, $fileName);      my $fh = Open(undef, ">$fileName");
696      # Loop through the keys.      # Loop through the keys.
697      for my $key (@keys) {      for my $key (@keys) {
698          Trace("Backing up attribute $key.") if T(3);          Trace("Backing up attribute $key.") if T(3);
699          $retVal->Add(keys => 1);          $retVal->Add(keys => 1);
700          # Loop through this key's values.          # Loop through this key's values.
701          my $query = $self->Get(['HasValueFor'], "HasValueFor(to-link) = ?", [$key]);          my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
702          my $valuesFound = 0;          my $valuesFound = 0;
703          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
704              $valuesFound++;              $valuesFound++;
705              # Get this row's data.              # Get this row's data.
706              my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',              my @row = $line->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
707                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
708              # Write it to the file.              # Write it to the file.
709              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, \@row);
# Line 851  Line 975 
975      return %retVal;      return %retVal;
976  }  }
977    
978    =head2 Internal Utility Methods
979    
980    =head3 _KeywordString
981    
982    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
983    
984    Compute the keyword string for a specified key/value pair. This consists of the
985    key name and value converted to lower case with underscores translated to spaces.
986    
987    This method is for internal use only. It is called whenever we need to update or
988    insert a B<HasValueFor> record.
989    
990    =over 4
991    
992    =item key
993    
994    Name of the relevant attribute key.
995    
996    =item target
997    
998    ID of the target object to which this key/value pair will be associated.
999    
1000    =item value
1001    
1002    The value to store for this key/object combination.
1003    
1004    =item RETURN
1005    
1006    Returns the value that should be stored as the keyword string for the specified
1007    key/value pair.
1008    
1009    =back
1010    
1011    =cut
1012    
1013    sub _KeywordString {
1014        # Get the parameters.
1015        my ($self, $key, $value) = @_;
1016        # Get a copy of the key name and convert underscores to spaces.
1017        my $keywordString = $key;
1018        $keywordString =~ s/_/ /g;
1019        # Add the value convert it all to lower case.
1020        my $retVal = lc "$keywordString $value";
1021        # Return the result.
1022        return $retVal;
1023    }
1024    
1025    =head3 _QueryResults
1026    
1027    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1028    
1029    Match the results of a B<HasValueFor> query against value criteria and return
1030    the results. This is an internal method that splits the values coming back
1031    and matches the sections against the specified section patterns. It serves
1032    as the back end to L</GetAttributes> and L</FindAttributes>.
1033    
1034    =over 4
1035    
1036    =item query
1037    
1038    A query object that will return the desired B<HasValueFor> records.
1039    
1040    =item values
1041    
1042    List of the desired attribute values, section by section. If C<undef>
1043    or an empty string is specified, all values in that section will match. A
1044    generic match can be requested by placing a percent sign (C<%>) at the end.
1045    In that case, all values that match up to and not including the percent sign
1046    will match. You may also specify a regular expression enclosed
1047    in slashes. All values that match the regular expression will be returned. For
1048    performance reasons, only values have this extra capability.
1049    
1050    =item RETURN
1051    
1052    Returns a list of tuples. The first element in the tuple is an object ID, the
1053    second is an attribute key, and the remaining elements are the sections of
1054    the attribute value. All of the tuples will match the criteria set forth in
1055    the parameter list.
1056    
1057    =back
1058    
1059    =cut
1060    
1061    sub _QueryResults {
1062        # Get the parameters.
1063        my ($self, $query, @values) = @_;
1064        # Declare the return value.
1065        my @retVal = ();
1066        # Get the number of value sections we have to match.
1067        my $sectionCount = scalar(@values);
1068        # Loop through the assignments found.
1069        while (my $row = $query->Fetch()) {
1070            # Get the current row's data.
1071            my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1072                                                          'HasValueFor(value)']);
1073            # Break the value into sections.
1074            my @sections = split($self->{splitter}, $valueString);
1075            # Match each section against the incoming values. We'll assume we're
1076            # okay unless we learn otherwise.
1077            my $matching = 1;
1078            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1079                # We need to check to see if this section is generic.
1080                my $value = $values[$i];
1081                Trace("Current value pattern is \"$value\".") if T(4);
1082                if (substr($value, -1, 1) eq '%') {
1083                    Trace("Generic match used.") if T(4);
1084                    # Here we have a generic match.
1085                    my $matchLen = length($values[$i] - 1);
1086                    $matching = substr($sections[$i], 0, $matchLen) eq
1087                                substr($values[$i], 0, $matchLen);
1088                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1089                    Trace("Regular expression detected.") if T(4);
1090                    # Here we have a regular expression match.
1091                    my $section = $sections[$i];
1092                    $matching = eval("\$section =~ $value");
1093                } else {
1094                    # Here we have a strict match.
1095                    Trace("Strict match used.") if T(4);
1096                    $matching = ($sections[$i] eq $values[$i]);
1097                }
1098            }
1099            # If we match, output this row to the return list.
1100            if ($matching) {
1101                push @retVal, [$id, $key, @sections];
1102            }
1103        }
1104        # Return the rows found.
1105        return @retVal;
1106    }
1107    
1108  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1109    
1110  The following methods are used by B<FIG.pm> to replace the previous attribute functionality.  The following methods are used by B<FIG.pm> to replace the previous attribute functionality.
# Line 945  Line 1199 
1199  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
1200  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.
1201  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
1202  will match.  will match. You may also specify a regular expression enclosed
1203    in slashes. All values that match the regular expression will be returned. For
1204    performance reasons, only values have this extra capability.
1205    
1206  =item RETURN  =item RETURN
1207    
# Line 1017  Line 1273 
1273      # 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
1274      # values to bind to them.      # values to bind to them.
1275      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);  
1276      # Now we're ready to make our query.      # Now we're ready to make our query.
1277      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1278      # Loop through the assignments found.      # Format the results.
1279      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];  
         }  
     }  
1280      # Return the rows found.      # Return the rows found.
1281      return @retVal;      return @retVal;
1282  }  }
# Line 1137  Line 1366 
1366      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1367          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1368      } elsif (scalar(@values) == 0) {      } elsif (scalar(@values) == 0) {
1369          # Here we erase the entire key.          # Here we erase the entire key for this object.
1370          $self->EraseAttribute($key);          $self->DeleteRow('HasValueFor', $key, $objectID);
1371      } else {      } else {
1372          # Here we erase the matching values.          # Here we erase the matching values.
1373          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
# Line 1148  Line 1377 
1377      return 1;      return 1;
1378  }  }
1379    
1380    =head3 DeleteMatchingAttributes
1381    
1382    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1383    
1384    Delete all attributes that match the specified criteria. This is equivalent to
1385    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1386    row found.
1387    
1388    =over 4
1389    
1390    =item objectID
1391    
1392    ID of object whose attributes are to be deleted. If the attributes for multiple
1393    objects are to be deleted, this parameter can be specified as a list reference. If
1394    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1395    Finally, you can delete attributes for a range of object IDs by putting a percent
1396    sign (C<%>) at the end.
1397    
1398    =item key
1399    
1400    Attribute key name. A value of C<undef> or an empty string will match all
1401    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1402    specified as a list reference. Finally, you can delete attributes for a range of
1403    keys by putting a percent sign (C<%>) at the end.
1404    
1405    =item values
1406    
1407    List of the desired attribute values, section by section. If C<undef>
1408    or an empty string is specified, all values in that section will match. A
1409    generic match can be requested by placing a percent sign (C<%>) at the end.
1410    In that case, all values that match up to and not including the percent sign
1411    will match. You may also specify a regular expression enclosed
1412    in slashes. All values that match the regular expression will be deleted. For
1413    performance reasons, only values have this extra capability.
1414    
1415    =item RETURN
1416    
1417    Returns a list of tuples for the attributes that were deleted, in the
1418    same form as L</GetAttributes>.
1419    
1420    =back
1421    
1422    =cut
1423    
1424    sub DeleteMatchingAttributes {
1425        # Get the parameters.
1426        my ($self, $objectID, $key, @values) = @_;
1427        # Get the matching attributes.
1428        my @retVal = $self->GetAttributes($objectID, $key, @values);
1429        # Loop through the attributes, deleting them.
1430        for my $tuple (@retVal) {
1431            $self->DeleteAttribute(@{$tuple});
1432        }
1433        # Return the deleted attributes.
1434        return @retVal;
1435    }
1436    
1437  =head3 ChangeAttribute  =head3 ChangeAttribute
1438    
1439  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1220  Line 1506 
1506  sub EraseAttribute {  sub EraseAttribute {
1507      # Get the parameters.      # Get the parameters.
1508      my ($self, $key) = @_;      my ($self, $key) = @_;
1509      # Delete everything connected to the key. The "keepRoot" option keeps the key in the      # Delete everything connected to the key.
1510      # datanase while deleting everything attached to it.      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
     $self->Delete('AttributeKey', $key, keepRoot => 1);  
1511      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1512      return 1;      return 1;
1513  }  }

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3