[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.18, Tue Feb 6 16:28:40 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 39  Line 40 
40  New attribute keys must be defined before they can be used. A web interface  New attribute keys must be defined before they can be used. A web interface
41  is provided for this purpose.  is provided for this purpose.
42    
43    Major attribute activity is recorded in a log (C<attributes.log>) in the
44    C<$FIG_Config::var> directory. The log reports the user name, time, and
45    the details of the operation. The user name will almost always be unknown,
46    except when it is specified in this object's constructor (see L</new>).
47    
48  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
49    
50  The following configuration parameters are used to manage custom attributes.  The following configuration parameters are used to manage custom attributes.
# Line 87  Line 93 
93    
94  =head3 new  =head3 new
95    
96  C<< my $attrDB = CustomAttributes->new($splitter); >>  C<< my $attrDB = CustomAttributes->new(%options); >>
97    
98  Construct a new CustomAttributes object.  Construct a new CustomAttributes object. The following options are
99    supported.
100    
101  =over 4  =over 4
102    
103  =item splitter  =item splitter
104    
105  Value to be used to split attribute values into sections in the  Value to be used to split attribute values into sections in the
106  L</Fig Replacement Methods>. The default is a double colon C<::>.  L</Fig Replacement Methods>. The default is a double colon C<::>,
107  If you do not use the replacement methods, you do not need to  and should only be overridden in extreme circumstances.
108  worry about this parameter.  
109    =item user
110    
111    Name of the current user. This will appear in the attribute log.
112    
113  =back  =back
114    
# Line 106  Line 116 
116    
117  sub new {  sub new {
118      # Get the parameters.      # Get the parameters.
119      my ($class, $splitter) = @_;      my ($class, %options) = @_;
120      # Connect to the database.      # Connect to the database.
121      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
122                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
# Line 116  Line 126 
126      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = $FIG_Config::attrDBD;
127      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
128      # Store the splitter value.      # Store the splitter value.
129      $retVal->{splitter} = (defined($splitter) ? $splitter : '::');      $retVal->{splitter} = $options{splitter} || '::';
130        # Store the user name.
131        $retVal->{user} = $options{user} || '<unknown>';
132        Trace("User $retVal->{user} selected for attribute object.") if T(3);
133      # Return the result.      # Return the result.
134      return $retVal;      return $retVal;
135  }  }
# Line 167  Line 180 
180      } elsif (! exists $types{$type}) {      } elsif (! exists $types{$type}) {
181          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid data type \"$type\" for $attributeName.");
182      } else {      } else {
183            # Create a variable to hold the action to be displayed for the log (Add or Update).
184            my $action;
185          # Okay, we're ready to begin. See if this key exists.          # Okay, we're ready to begin. See if this key exists.
186          my $attribute = $self->GetEntity('AttributeKey', $attributeName);          my $attribute = $self->GetEntity('AttributeKey', $attributeName);
187          if (defined($attribute)) {          if (defined($attribute)) {
188              # It does, so we do an update.              # It does, so we do an update.
189                $action = "Update Key";
190              $self->UpdateEntity('AttributeKey', $attributeName,              $self->UpdateEntity('AttributeKey', $attributeName,
191                                  { description => $notes, 'data-type' => $type });                                  { description => $notes, 'data-type' => $type });
192              # Detach the key from its current groups.              # Detach the key from its current groups.
193              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
194          } else {          } else {
195              # It doesn't, so we do an insert.              # It doesn't, so we do an insert.
196                $action = "Insert Key";
197              $self->InsertObject('AttributeKey', { id => $attributeName,              $self->InsertObject('AttributeKey', { id => $attributeName,
198                                  description => $notes, 'data-type' => $type });                                  description => $notes, 'data-type' => $type });
199          }          }
# Line 186  Line 203 
203              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,              $self->InsertObject('IsInGroup', { 'from-link' => $attributeName,
204                                                 'to-link'   => $group });                                                 'to-link'   => $group });
205          }          }
206            # Log the operation.
207            $self->LogOperation($action, $attributeName, "Group list is " . join(" ", @{$groups}));
208      }      }
209  }  }
210    
# Line 245  Line 264 
264      # Get the parameters.      # Get the parameters.
265      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;      my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;
266      # Create the return variable.      # Create the return variable.
267      my $retVal = Stats->new("lineIn", "shortLine", "newObject");      my $retVal = Stats->new("lineIn", "shortLine");
268      # Compute the minimum number of fields required in each input line.      # Compute the minimum number of fields required in each input line. The user specifies two
269        # columns, and we need to make sure both columns are in every record.
270      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;      my $minCols = ($idCol < $dataCol ? $idCol : $idCol) + 1;
271      # Insure the attribute key exists.      # Insure the attribute key exists.
272      my $found = $self->GetEntity('AttributeKey', $keyName);      my $found = $self->GetEntity('AttributeKey', $keyName);
# Line 270  Line 290 
290                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);                  my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);
291                  # Denote we're using this input line.                  # Denote we're using this input line.
292                  $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);  
                 }  
293                  # Now we insert the attribute.                  # Now we insert the attribute.
294                  $self->InsertObject('HasValueFor', { from => $keyName, to => $id, value => $value });                  $self->InsertObject('HasValueFor', { from => $keyName, to => $id,
295                                                         value => $value });
296                  $retVal->Add(newValue => 1);                  $retVal->Add(newValue => 1);
297              }              }
298          }          }
299            # Log this operation.
300            $self->LogOperation("Load Key", $keyName, $retVal->Display());
301      }      }
302      # Return the statistics.      # Return the statistics.
303      return $retVal;      return $retVal;
# Line 315  Line 329 
329      my ($self, $attributeName) = @_;      my ($self, $attributeName) = @_;
330      # Delete the attribute key.      # Delete the attribute key.
331      my $retVal = $self->Delete('AttributeKey', $attributeName);      my $retVal = $self->Delete('AttributeKey', $attributeName);
332        # Log this operation.
333        $self->LogOperation("Delete Key", $attributeName, "Key will no longer be available for use by anyone.");
334      # Return the result.      # Return the result.
335      return $retVal;      return $retVal;
336    
# Line 532  Line 548 
548      return $retVal;      return $retVal;
549  }  }
550    
551    =head3 BackupKeys
552    
553    C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>
554    
555    Backup the attribute key information from the attribute database.
556    
557    =over 4
558    
559    =item fileName
560    
561    Name of the output file.
562    
563    =item options
564    
565    Options for modifying the backup process.
566    
567    =item RETURN
568    
569    Returns a statistics object for the backup.
570    
571    =back
572    
573    Currently there are no options. The backup is straight to a text file in
574    tab-delimited format. Each key is backup up to two lines. The first line
575    is all of the data from the B<AttributeKey> table. The second is a
576    tab-delimited list of all the groups.
577    
578    =cut
579    
580    sub BackupKeys {
581        # Get the parameters.
582        my ($self, $fileName, %options) = @_;
583        # Declare the return variable.
584        my $retVal = Stats->new();
585        # Open the output file.
586        my $fh = Open(undef, ">$fileName");
587        # Set up to read the keys.
588        my $keyQuery = $self->Get(['AttributeKey'], "", []);
589        # Loop through the keys.
590        while (my $keyData = $keyQuery->Fetch()) {
591            $retVal->Add(key => 1);
592            # Get the fields.
593            my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',
594                                                              'AttributeKey(description)']);
595            # Escape any tabs or new-lines in the description.
596            my $escapedDescription = Tracer::Escape($description);
597            # Write the key data to the output.
598            Tracer::PutLine($fh, [$id, $type, $escapedDescription]);
599            # Get the key's groups.
600            my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
601                                        'IsInGroup(to-link)');
602            $retVal->Add(memberships => scalar(@groups));
603            # Write them to the output. Note we put a marker at the beginning to insure the line
604            # is nonempty.
605            Tracer::PutLine($fh, ['#GROUPS', @groups]);
606        }
607        # Log the operation.
608        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
609        # Return the result.
610        return $retVal;
611    }
612    
613    =head3 RestoreKeys
614    
615    C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>
616    
617    Restore the attribute keys and groups from a backup file.
618    
619    =over 4
620    
621    =item fileName
622    
623    Name of the file containing the backed-up keys. Each key has a pair of lines,
624    one containing the key data and one listing its groups.
625    
626    =back
627    
628    =cut
629    
630    sub RestoreKeys {
631        # Get the parameters.
632        my ($self, $fileName, %options) = @_;
633        # Declare the return variable.
634        my $retVal = Stats->new();
635        # Set up a hash to hold the group IDs.
636        my %groups = ();
637        # Open the file.
638        my $fh = Open(undef, "<$fileName");
639        # Loop until we're done.
640        while (! eof $fh) {
641            # Get a key record.
642            my ($id, $dataType, $description) = Tracer::GetLine($fh);
643            if ($id eq '#GROUPS') {
644                Confess("Group record found when key record expected.");
645            } elsif (! defined($description)) {
646                Confess("Invalid format found for key record.");
647            } else {
648                $retVal->Add("keyIn" => 1);
649                # Add this key to the database.
650                $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,
651                                                      description => Tracer::UnEscape($description) });
652                Trace("Attribute $id stored.") if T(3);
653                # Get the group line.
654                my ($marker, @groups) = Tracer::GetLine($fh);
655                if (! defined($marker)) {
656                    Confess("End of file found where group record expected.");
657                } elsif ($marker ne '#GROUPS') {
658                    Confess("Group record not found after key record.");
659                } else {
660                    $retVal->Add(memberships => scalar(@groups));
661                    # Connect the groups.
662                    for my $group (@groups) {
663                        # Find out if this is a new group.
664                        if (! $groups{$group}) {
665                            $retVal->Add(newGroup => 1);
666                            # Add the group.
667                            $self->InsertObject('AttributeGroup', { id => $group });
668                            Trace("Group $group created.") if T(3);
669                            # Make sure we know it's not new.
670                            $groups{$group} = 1;
671                        }
672                        # Connect the group to our key.
673                        $self->InsertObject('IsInGroup', { 'from-link' => $id, 'to-link' => $group });
674                    }
675                    Trace("$id added to " . scalar(@groups) . " groups.") if T(3);
676                }
677            }
678        }
679        # Log the operation.
680        $self->LogOperation("Backup Keys", $fileName, $retVal->Display());
681        # Return the result.
682        return $retVal;
683    }
684    
685    
686  =head3 BackupAllAttributes  =head3 BackupAllAttributes
687    
688  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>
# Line 568  Line 719 
719      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');
720      Trace(scalar(@keys) . " keys found during backup.") if T(2);      Trace(scalar(@keys) . " keys found during backup.") if T(2);
721      # Open the file for output.      # Open the file for output.
722      my $fh = Open(undef, $fileName);      my $fh = Open(undef, ">$fileName");
723      # Loop through the keys.      # Loop through the keys.
724      for my $key (@keys) {      for my $key (@keys) {
725          Trace("Backing up attribute $key.") if T(3);          Trace("Backing up attribute $key.") if T(3);
726          $retVal->Add(keys => 1);          $retVal->Add(keys => 1);
727          # Loop through this key's values.          # Loop through this key's values.
728          my $query = $self->Get(['HasValueFor'], "HasValueFor(to-link) = ?", [$key]);          my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);
729          my $valuesFound = 0;          my $valuesFound = 0;
730          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
731              $valuesFound++;              $valuesFound++;
732              # Get this row's data.              # Get this row's data.
733              my @row = $line->Values(['HasValueFor(from-link)', 'HasValueFor(to-link)',              my @row = $line->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
734                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
735              # Write it to the file.              # Write it to the file.
736              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, \@row);
# Line 587  Line 738 
738          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
739          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
740      }      }
741        # Log the operation.
742        $self->LogOperation("Backup Data", $fileName, $retVal->Display());
743      # Return the result.      # Return the result.
744      return $retVal;      return $retVal;
745  }  }
# Line 851  Line 1004 
1004      return %retVal;      return %retVal;
1005  }  }
1006    
1007    =head3 LogOperation
1008    
1009    C<< $ca->LogOperation($action, $target, $description); >>
1010    
1011    Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).
1012    
1013    =over 4
1014    
1015    =item action
1016    
1017    Action being logged (e.g. C<Delete Group> or C<Load Key>).
1018    
1019    =item target
1020    
1021    ID of the key or group affected.
1022    
1023    =item description
1024    
1025    Short description of the action.
1026    
1027    =back
1028    
1029    =cut
1030    
1031    sub LogOperation {
1032        # Get the parameters.
1033        my ($self, $action, $target, $description) = @_;
1034        # Get the user ID.
1035        my $user = $self->{user};
1036        # Get a timestamp.
1037        my $timeString = Tracer::Now();
1038        # Open the log file for appending.
1039        my $oh = Open(undef, ">>$FIG_Config::var/attributes.log");
1040        # Write the data to it.
1041        Tracer::PutLine($oh, [$timeString, $user, $action, $target, $description]);
1042        # Close the log file.
1043        close $oh;
1044    }
1045    
1046    =head2 Internal Utility Methods
1047    
1048    =head3 _KeywordString
1049    
1050    C<< my $keywordString = $ca->_KeywordString($key, $value); >>
1051    
1052    Compute the keyword string for a specified key/value pair. This consists of the
1053    key name and value converted to lower case with underscores translated to spaces.
1054    
1055    This method is for internal use only. It is called whenever we need to update or
1056    insert a B<HasValueFor> record.
1057    
1058    =over 4
1059    
1060    =item key
1061    
1062    Name of the relevant attribute key.
1063    
1064    =item target
1065    
1066    ID of the target object to which this key/value pair will be associated.
1067    
1068    =item value
1069    
1070    The value to store for this key/object combination.
1071    
1072    =item RETURN
1073    
1074    Returns the value that should be stored as the keyword string for the specified
1075    key/value pair.
1076    
1077    =back
1078    
1079    =cut
1080    
1081    sub _KeywordString {
1082        # Get the parameters.
1083        my ($self, $key, $value) = @_;
1084        # Get a copy of the key name and convert underscores to spaces.
1085        my $keywordString = $key;
1086        $keywordString =~ s/_/ /g;
1087        # Add the value convert it all to lower case.
1088        my $retVal = lc "$keywordString $value";
1089        # Return the result.
1090        return $retVal;
1091    }
1092    
1093    =head3 _QueryResults
1094    
1095    C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>
1096    
1097    Match the results of a B<HasValueFor> query against value criteria and return
1098    the results. This is an internal method that splits the values coming back
1099    and matches the sections against the specified section patterns. It serves
1100    as the back end to L</GetAttributes> and L</FindAttributes>.
1101    
1102    =over 4
1103    
1104    =item query
1105    
1106    A query object that will return the desired B<HasValueFor> records.
1107    
1108    =item values
1109    
1110    List of the desired attribute values, section by section. If C<undef>
1111    or an empty string is specified, all values in that section will match. A
1112    generic match can be requested by placing a percent sign (C<%>) at the end.
1113    In that case, all values that match up to and not including the percent sign
1114    will match. You may also specify a regular expression enclosed
1115    in slashes. All values that match the regular expression will be returned. For
1116    performance reasons, only values have this extra capability.
1117    
1118    =item RETURN
1119    
1120    Returns a list of tuples. The first element in the tuple is an object ID, the
1121    second is an attribute key, and the remaining elements are the sections of
1122    the attribute value. All of the tuples will match the criteria set forth in
1123    the parameter list.
1124    
1125    =back
1126    
1127    =cut
1128    
1129    sub _QueryResults {
1130        # Get the parameters.
1131        my ($self, $query, @values) = @_;
1132        # Declare the return value.
1133        my @retVal = ();
1134        # Get the number of value sections we have to match.
1135        my $sectionCount = scalar(@values);
1136        # Loop through the assignments found.
1137        while (my $row = $query->Fetch()) {
1138            # Get the current row's data.
1139            my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',
1140                                                          'HasValueFor(value)']);
1141            # Break the value into sections.
1142            my @sections = split($self->{splitter}, $valueString);
1143            # Match each section against the incoming values. We'll assume we're
1144            # okay unless we learn otherwise.
1145            my $matching = 1;
1146            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
1147                # We need to check to see if this section is generic.
1148                my $value = $values[$i];
1149                Trace("Current value pattern is \"$value\".") if T(4);
1150                if (substr($value, -1, 1) eq '%') {
1151                    Trace("Generic match used.") if T(4);
1152                    # Here we have a generic match.
1153                    my $matchLen = length($values[$i] - 1);
1154                    $matching = substr($sections[$i], 0, $matchLen) eq
1155                                substr($values[$i], 0, $matchLen);
1156                } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
1157                    Trace("Regular expression detected.") if T(4);
1158                    # Here we have a regular expression match.
1159                    my $section = $sections[$i];
1160                    $matching = eval("\$section =~ $value");
1161                } else {
1162                    # Here we have a strict match.
1163                    Trace("Strict match used.") if T(4);
1164                    $matching = ($sections[$i] eq $values[$i]);
1165                }
1166            }
1167            # If we match, output this row to the return list.
1168            if ($matching) {
1169                push @retVal, [$id, $key, @sections];
1170            }
1171        }
1172        # Return the rows found.
1173        return @retVal;
1174    }
1175    
1176  =head2 FIG Method Replacements  =head2 FIG Method Replacements
1177    
1178  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 1267 
1267  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
1268  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.
1269  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
1270  will match.  will match. You may also specify a regular expression enclosed
1271    in slashes. All values that match the regular expression will be returned. For
1272    performance reasons, only values have this extra capability.
1273    
1274  =item RETURN  =item RETURN
1275    
# Line 1017  Line 1341 
1341      # 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
1342      # values to bind to them.      # values to bind to them.
1343      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);  
1344      # Now we're ready to make our query.      # Now we're ready to make our query.
1345      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);
1346      # Loop through the assignments found.      # Format the results.
1347      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];  
         }  
     }  
1348      # Return the rows found.      # Return the rows found.
1349      return @retVal;      return @retVal;
1350  }  }
# Line 1137  Line 1434 
1434      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1435          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1436      } elsif (scalar(@values) == 0) {      } elsif (scalar(@values) == 0) {
1437          # Here we erase the entire key.          # Here we erase the entire key for this object.
1438          $self->EraseAttribute($key);          $self->DeleteRow('HasValueFor', $key, $objectID);
1439      } else {      } else {
1440          # Here we erase the matching values.          # Here we erase the matching values.
1441          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
# Line 1148  Line 1445 
1445      return 1;      return 1;
1446  }  }
1447    
1448    =head3 DeleteMatchingAttributes
1449    
1450    C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>
1451    
1452    Delete all attributes that match the specified criteria. This is equivalent to
1453    calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
1454    row found.
1455    
1456    =over 4
1457    
1458    =item objectID
1459    
1460    ID of object whose attributes are to be deleted. If the attributes for multiple
1461    objects are to be deleted, this parameter can be specified as a list reference. If
1462    attributes are to be deleted for all objects, specify C<undef> or an empty string.
1463    Finally, you can delete attributes for a range of object IDs by putting a percent
1464    sign (C<%>) at the end.
1465    
1466    =item key
1467    
1468    Attribute key name. A value of C<undef> or an empty string will match all
1469    attribute keys. If the values are to be deletedfor multiple keys, this parameter can be
1470    specified as a list reference. Finally, you can delete attributes for a range of
1471    keys by putting a percent sign (C<%>) at the end.
1472    
1473    =item values
1474    
1475    List of the desired attribute values, section by section. If C<undef>
1476    or an empty string is specified, all values in that section will match. A
1477    generic match can be requested by placing a percent sign (C<%>) at the end.
1478    In that case, all values that match up to and not including the percent sign
1479    will match. You may also specify a regular expression enclosed
1480    in slashes. All values that match the regular expression will be deleted. For
1481    performance reasons, only values have this extra capability.
1482    
1483    =item RETURN
1484    
1485    Returns a list of tuples for the attributes that were deleted, in the
1486    same form as L</GetAttributes>.
1487    
1488    =back
1489    
1490    =cut
1491    
1492    sub DeleteMatchingAttributes {
1493        # Get the parameters.
1494        my ($self, $objectID, $key, @values) = @_;
1495        # Get the matching attributes.
1496        my @retVal = $self->GetAttributes($objectID, $key, @values);
1497        # Loop through the attributes, deleting them.
1498        for my $tuple (@retVal) {
1499            $self->DeleteAttribute(@{$tuple});
1500        }
1501        # Log this operation.
1502        my $count = @retVal;
1503        $self->LogOperation("Mass Delete", $key, "$count matching attributes deleted.");
1504        # Return the deleted attributes.
1505        return @retVal;
1506    }
1507    
1508  =head3 ChangeAttribute  =head3 ChangeAttribute
1509    
1510  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>
# Line 1220  Line 1577 
1577  sub EraseAttribute {  sub EraseAttribute {
1578      # Get the parameters.      # Get the parameters.
1579      my ($self, $key) = @_;      my ($self, $key) = @_;
1580      # Delete everything connected to the key. The "keepRoot" option keeps the key in the      # Delete everything connected to the key.
1581      # datanase while deleting everything attached to it.      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1582      $self->Delete('AttributeKey', $key, keepRoot => 1);      # Log the operation.
1583        $self->LogOperation("Erase Data", $key);
1584      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
1585      return 1;      return 1;
1586  }  }

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3