[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.19, Fri Feb 9 22:59:18 2007 UTC revision 1.20, Sun Feb 18 21:25:37 2007 UTC
# Line 70  Line 70 
70    
71  where I<$fid> contains the ID of the desired feature.  where I<$fid> contains the ID of the desired feature.
72    
73  New attribute keys must be defined before they can be used. A web interface  Keys can be split into two pieces using the splitter value defined in the
74  is provided for this purpose.  constructor (the default is C<::>). The first piece of the key is called
75    the I<real key>. This portion of the key must be defined using the
76    web interface (C<Attributes.cgi>). The second portion of the key is called
77    the I<sub key>, and can take any value.
78    
79  Major attribute activity is recorded in a log (C<attributes.log>) in the  Major attribute activity is recorded in a log (C<attributes.log>) in the
80  C<$FIG_Config::var> directory. The log reports the user name, time, and  C<$FIG_Config::var> directory. The log reports the user name, time, and
81  the details of the operation. The user name will almost always be unknown,  the details of the operation. The user name will almost always be unknown,
82  except when it is specified in this object's constructor (see L</new>).  the exception being when it is specified in this object's constructor
83    (see L</new>).
84    
85  =head2 FIG_Config Parameters  =head2 FIG_Config Parameters
86    
# Line 177  Line 181 
181    
182  =item attributeName  =item attributeName
183    
184  Name of the attribute. It must be a valid ERDB field name, consisting entirely of  Name of the attribute (the real key). If it does not exist already, it will be created.
 letters, digits, and hyphens, with a letter at the beginning. If it does not  
 exist already, it will be created.  
185    
186  =item type  =item type
187    
# Line 206  Line 208 
208      # Get the data type hash.      # Get the data type hash.
209      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
210      # Validate the initial input values.      # Validate the initial input values.
211      if (! ERDB::ValidateFieldName($attributeName)) {      if ($attributeName =~ /$self->{splitter}/) {
212          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
213      } elsif (! $notes || length($notes) < 25) {      } elsif (! $notes || length($notes) < 25) {
214          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing or incomplete description for $attributeName.");
# Line 241  Line 243 
243      }      }
244  }  }
245    
 =head3 LoadAttributeKey  
   
 C<< my $stats = $attrDB->LoadAttributeKey($keyName, $fh, $keyCol, $dataCol, %options); >>  
   
 Load the specified attribute from the specified file. The file should be a  
 tab-delimited file with internal tab and new-line characters escaped. This is  
 the typical TBL-style file used by most FIG applications. One of the columns  
 in the input file must contain the appropriate object id value and the other the  
 corresponding attribute value. The current contents of the attribute database will  
 be erased before loading, unless the options are used to override that behavior.  
   
 =over 4  
   
 =item keyName  
   
 Key of the attribute to load.  
   
 =item fh  
   
 Open file handle for the input file.  
   
 =item idCol  
   
 Index (0-based) of the column containing the ID field. The ID field should  
 contain the ID of an instance of the named entity.  
   
 =item dataCol  
   
 Index (0-based) of the column containing the data value field.  
   
 =item options  
   
 Hash specifying the options for this load.  
   
 =item RETURN  
   
 Returns a statistics object for the load process.  
   
 =back  
   
 The available options are as follows.  
   
 =over 4  
   
 =item keep  
   
 If specified, the existing attribute values will not be erased.  
   
 =item archive  
   
 If specified, the name of a file into which the incoming file should be saved.  
   
 =back  
   
 =cut  
   
 sub LoadAttributeKey {  
     # Get the parameters.  
     my ($self, $keyName, $fh, $idCol, $dataCol, %options) = @_;  
     # Create the return variable.  
     my $retVal = Stats->new("lineIn", "shortLine");  
     # Compute the minimum number of fields required in each input line. The user specifies two  
     # columns, and we need to make sure both columns are in every record.  
     my $minCols = ($idCol < $dataCol ? $dataCol : $idCol) + 1;  
     Trace("Minimum column count is $minCols.") if T(3);  
     #  
     # Insure the attribute key exists.  
     my $found = $self->GetEntity('AttributeKey', $keyName);  
     if (! defined $found) {  
         Confess("Attribute key \"$keyName\" not found in database.");  
     } else {  
         # Erase the key's current values (unless, of course, the caller specified the "keep" option.  
         if (! $options{keep}) {  
             $self->EraseAttribute($keyName);  
         }  
         # Check for a save file. In the main loop, we'll know a save file is needed if $sh is  
         # defined.  
         my $sh;  
         if ($options{archive}) {  
             $sh = Open(undef, ">$options{archive}");  
             Trace("Attribute $keyName upload saved in $options{archive}.") if T(2);  
         }  
         # Save a list of the object IDs we need to add.  
         my %objectIDs = ();  
         # Loop through the input file.  
         while (! eof $fh) {  
             # Get the next line of the file.  
             my @fields = Tracer::GetLine($fh);  
             $retVal->Add(lineIn => 1);  
             my $count = scalar @fields;  
             Trace("Field count is $count. First field is \"$fields[0]\".") if T(4);  
             # Archive it if necessary.  
             if (defined $sh) {  
                 Tracer::PutLine($sh, \@fields);  
             }  
             # Now we need to check for comments and validate the line.  
             if ($fields[0] =~ /^\s*$/) {  
                 # Blank line: skip it.  
                 $retVal->Add(blank => 1);  
             } elsif (substr($fields[0],0,1) eq '#') {  
                 # Comment line: skip it.  
                 $retVal->Add(comment => 1);  
             } elsif ($count < $minCols) {  
                 # Line is too short: we have an error.  
                 $retVal->Add(shortLine => 1);  
             } else {  
                 # It's valid, so get the ID and value.  
                 my ($id, $value) = ($fields[$idCol], $fields[$dataCol]);  
                 # Denote we're using this input line.  
                 $retVal->Add(lineUsed => 1);  
                 # Now we insert the attribute.  
                 $self->InsertObject('HasValueFor', { 'from-link' => $keyName,  
                                                      'to-link' => $id,  
                                                      value => $value });  
                 $retVal->Add(newValue => 1);  
             }  
         }  
         # Log this operation.  
         $self->LogOperation("Load Key", $keyName, $retVal->Display());  
         # If there's an archive, close it.  
         if (defined $sh) {  
             close $sh;  
         }  
     }  
     # Return the statistics.  
     return $retVal;  
 }  
   
246    
247  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
248    
# Line 495  Line 369 
369                             $cgi->td($cgi->checkbox_group(-name=>'groups',                             $cgi->td($cgi->checkbox_group(-name=>'groups',
370                                      -values=> \@groups))                                      -values=> \@groups))
371                            );                            );
372      # If the user wants to upload new values for the field, then we have      # Now the four buttons: STORE, SHOW, ERASE, and DELETE.
     # an upload file name and column indicators.  
     push @retVal, $cgi->Tr($cgi->th("Upload Values"),  
                            $cgi->td($cgi->filefield(-name => 'newValueFile',  
                                                     -size => 20) .  
                                     " Key&nbsp;" .  
                                     $cgi->textfield(-name => 'keyCol',  
                                                     -size => 3,  
                                                     -default => 0) .  
                                     " Value&nbsp;" .  
                                     $cgi->textfield(-name => 'valueCol',  
                                                     -size => 3,  
                                                     -default => 1)  
                                    ),  
                           );  
     # Now the three buttons: STORE, SHOW, and DELETE.  
373      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),      push @retVal, $cgi->Tr($cgi->th("&nbsp;"),
374                             $cgi->td({align => 'center'},                             $cgi->td({align => 'center'}, join(" ",
375                                      $cgi->submit(-name => 'Delete', -value => 'DELETE') . " " .                                      $cgi->submit(-name => 'Delete', -value => 'DELETE'),
376                                      $cgi->submit(-name => 'Store',  -value => 'STORE') . " " .                                      $cgi->submit(-name => 'Store',  -value => 'STORE'),
377                                        $cgi->submit(-name => 'Erase',  -value => 'ERASE'),
378                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')                                      $cgi->submit(-name => 'Show',   -value => 'SHOW')
379                                     )                                     ))
380                            );                            );
381      # Close the table and the form.      # Close the table and the form.
382      push @retVal, $cgi->end_table();      push @retVal, $cgi->end_table();
# Line 531  Line 391 
391  Load attributes from the specified tab-delimited file. Each line of the file must  Load attributes from the specified tab-delimited file. Each line of the file must
392  contain an object ID in the first column, an attribute key name in the second  contain an object ID in the first column, an attribute key name in the second
393  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values will
394  be assembled into a single value using the splitter code.  be assembled into a single value using the splitter code. In addition, the key names may
395    contain a splitter. If this is the case, the portion of the key after the splitter is
396    treated as a subkey.
397    
398  =over 4  =over 4
399    
400  =item fileName  =item fileName
401    
402  Name of the file from which to load the attributes.  Name of the file from which to load the attributes, or an open handle for the file.
403    (This last enables the method to be used in conjunction with the CGI form upload
404    control.)
405    
406  =item options  =item options
407    
# Line 558  Line 422 
422  If TRUE, then the attributes will be appended to existing data; otherwise, the  If TRUE, then the attributes will be appended to existing data; otherwise, the
423  first time a key name is encountered, it will be erased.  first time a key name is encountered, it will be erased.
424    
425    =item archive
426    
427    If specified, the name of a file into which the incoming data file should be saved.
428    
429    =item objectType
430    
431    If specified, the specified object type will be prefixed to each object ID.
432    
433  =back  =back
434    
435  =cut  =cut
# Line 571  Line 443 
443      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
444      # Create a hash of key names found.      # Create a hash of key names found.
445      my %keyHash = ();      my %keyHash = ();
446      # Open the file for input.      # Open the file for input. Note we must anticipate the possibility of an
447      my $fh = Open(undef, "<$fileName");      # open filehandle being passed in.
448        my $fh;
449        if (ref $fileName eq 'GLOB') {
450            Trace("Using file opened by caller.") if T(3);
451            $fh = $fileName;
452        } else {
453            Trace("Attributes will be loaded from $fileName.") if T(3);
454            $fh = Open(undef, "<$fileName");
455        }
456        # Now check to see if we need to archive.
457        my $ah;
458        if ($options{archive}) {
459            $ah = Open(undef, ">$options{archive}");
460            Trace("Load file will be archived to $options{archive}.") if T(3);
461        }
462        # Finally, open a database transaction.
463        $self->BeginTran();
464        # Insure we recover from errors. If an error occurs, we will delete the archive file and
465        # roll back the updates.
466        eval {
467      # Loop through the file.      # Loop through the file.
468      while (! eof $fh) {      while (! eof $fh) {
469                # Read the current line.
470          my ($id, $key, @values) = Tracer::GetLine($fh);          my ($id, $key, @values) = Tracer::GetLine($fh);
471          $retVal->Add(linesIn => 1);          $retVal->Add(linesIn => 1);
472                # Check to see if we need to fix up the object ID.
473                if ($options{objectType}) {
474                    $id = "$options{objectType}:$id";
475                }
476                # Archive the line (if necessary).
477                if (defined $ah) {
478                    Tracer::PutLine($ah, [$id, $key, @values]);
479                }
480          # Do some validation.          # Do some validation.
481          if (! defined($id)) {              if (! $id) {
482              # We ignore blank lines.              # We ignore blank lines.
483              $retVal->Add(blankLines => 1);              $retVal->Add(blankLines => 1);
484                } elsif (substr($id, 0, 1) eq '#') {
485                    # A line beginning with a pound sign is a comment.
486                    $retVal->Add(comments => 1);
487          } elsif (! defined($key)) {          } elsif (! defined($key)) {
488              # An ID without a key is a serious error.              # An ID without a key is a serious error.
489              my $lines = $retVal->Ask('linesIn');              my $lines = $retVal->Ask('linesIn');
490              Confess("Line $lines in $fileName has no attribute key.");              Confess("Line $lines in $fileName has no attribute key.");
491          } else {          } else {
492                    # The key contains a real part and an optional sub-part. We need the real part.
493                    my ($realKey, $subKey) = $self->SplitKey($key);
494              # Now we need to check for a new key.              # Now we need to check for a new key.
495              if (! exists $keyHash{$key}) {                  if (! exists $keyHash{$realKey}) {
496                  # This is a new key. Verify that it exists.                      if (! $self->Exists('AttributeKey', $realKey)) {
                 if (! $self->Exists('AttributeKey', $key)) {  
497                      my $line = $retVal->Ask('linesIn');                      my $line = $retVal->Ask('linesIn');
498                      Confess("Attribute \"$key\" on line $line of $fileName not found in database.");                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
499                  } else {                  } else {
500                      # Make sure we know this is no longer a new key.                      # Make sure we know this is no longer a new key.
501                      $keyHash{$key} = 1;                          $keyHash{$realKey} = 1;
502                      $retVal->Add(keys => 1);                      $retVal->Add(keys => 1);
503                      # If this is NOT append mode, erase the key.                      # If this is NOT append mode, erase the key.
504                      if (! $append) {                      if (! $append) {
505                          $self->EraseAttribute($key);                              $self->EraseAttribute($realKey);
506                      }                      }
507                  }                  }
508                  Trace("Key $key found.") if T(3);                      Trace("Key $realKey found.") if T(3);
509              }              }
510              # Now we know the key is valid. Add this value.                  # Everything is all set up, so add the value.
511              $self->AddAttribute($id, $key, @values);              $self->AddAttribute($id, $key, @values);
512              my $progress = $retVal->Add(values => 1);              my $progress = $retVal->Add(values => 1);
513              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);              Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);
514                }
515            }
516        };
517        # Check for an error.
518        if ($@) {
519            # Here we have an error. Roll back the transaction and delete the archive file.
520            my $message = $@;
521            Trace("Rolling back attribute updates due to error.") if T(1);
522            $self->RollbackTran();
523            if (defined $ah) {
524                Trace("Deleting archive file $options{archive}.") if T(1);
525                close $ah;
526                unlink $options{archive};
527            }
528            Confess("Error during attribute load: $message");
529        } else {
530            # Here the load worked. Commit the transaction and close the archive file.
531            Trace("Committing attribute upload.") if T(2);
532            $self->CommitTran();
533            if (defined $ah) {
534                Trace("Closing archive file $options{archive}.") if T(2);
535                close $ah;
536          }          }
537      }      }
538      # Return the result.      # Return the result.
# Line 748  Line 673 
673      return $retVal;      return $retVal;
674  }  }
675    
676    =head3 ArchiveFileName
677    
678    C<< my $fileName = $ca->ArchiveFileName(); >>
679    
680    Compute a file name for archiving attribute input data. The file will be in the attribute log directory
681    
682    =cut
683    
684    sub ArchiveFileName {
685        # Get the parameters.
686        my ($self) = @_;
687        # Declare the return variable.
688        my $retVal;
689        # We start by turning the timestamp into something usable as a file name.
690        my $now = Tracer::Now();
691        $now =~ tr/ :\//___/;
692        # Next we get the directory name.
693        my $dir = "$FIG_Config::var/attributes";
694        if (! -e $dir) {
695            Trace("Creating attribute file directory $dir.") if T(1);
696            mkdir $dir;
697        }
698        # Put it together with the field name and the time stamp.
699        $retVal = "$dir/upload.$now";
700        # Modify the file name to insure it's unique.
701        my $seq = 0;
702        while (-e "$retVal.$seq.tbl") { $seq++ }
703        # Use the computed sequence number to get the correct file name.
704        $retVal .= ".$seq.tbl";
705        # Return the result.
706        return $retVal;
707    }
708    
709  =head3 BackupAllAttributes  =head3 BackupAllAttributes
710    
# Line 796  Line 753 
753          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
754              $valuesFound++;              $valuesFound++;
755              # Get this row's data.              # Get this row's data.
756              my @row = $line->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',              my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',
757                                                                 'HasValueFor(from-link)',
758                                                                 'HasValueFor(subkey)',
759                                       'HasValueFor(value)']);                                       'HasValueFor(value)']);
760                # Check for a subkey.
761                if ($subKey ne '') {
762                    $key = "$key$self->{splitter}$subKey";
763                }
764              # Write it to the file.              # Write it to the file.
765              Tracer::PutLine($fh, \@row);              Tracer::PutLine($fh, [$id, $key, $value]);
766          }          }
767          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
768          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
# Line 1202  Line 1165 
1165      # Loop through the assignments found.      # Loop through the assignments found.
1166      while (my $row = $query->Fetch()) {      while (my $row = $query->Fetch()) {
1167          # Get the current row's data.          # Get the current row's data.
1168          my ($id, $key, $valueString) = $row->Values(['HasValueFor(to-link)', 'HasValueFor(from-link)',          my ($id, $realKey, $subKey, $valueString) = $row->Values(['HasValueFor(to-link)',
1169                                                        'HasValueFor(value)']);                                                                    'HasValueFor(from-link)',
1170                                                                      'HasValueFor(subkey)',
1171                                                                      'HasValueFor(value)'
1172                                                                    ]);
1173            # Form the key from the real key and the sub key.
1174            my $key = $self->JoinKey($realKey, $subKey);
1175          # Break the value into sections.          # Break the value into sections.
1176          my @sections = split($self->{splitter}, $valueString);          my @sections = split($self->{splitter}, $valueString);
1177          # 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 1216  Line 1184 
1184              if (substr($value, -1, 1) eq '%') {              if (substr($value, -1, 1) eq '%') {
1185                  Trace("Generic match used.") if T(4);                  Trace("Generic match used.") if T(4);
1186                  # Here we have a generic match.                  # Here we have a generic match.
1187                  my $matchLen = length($values[$i] - 1);                  my $matchLen = length($values[$i]) - 1;
1188                  $matching = substr($sections[$i], 0, $matchLen) eq                  $matching = substr($sections[$i], 0, $matchLen) eq
1189                              substr($values[$i], 0, $matchLen);                              substr($values[$i], 0, $matchLen);
1190              } elsif ($value =~ m#^/(.+)/[a-z]*$#) {              } elsif ($value =~ m#^/(.+)/[a-z]*$#) {
# Line 1250  Line 1218 
1218  The idea is that these methods represent attribute manipulation allowed by all users, while  The idea is that these methods represent attribute manipulation allowed by all users, while
1219  the others are only for privileged users with access to the attribute server.  the others are only for privileged users with access to the attribute server.
1220    
1221  In the previous implementation, an attribute had a value and a URL. In the new implementation,  In the previous implementation, an attribute had a value and a URL. In this implementation,
1222  there is only a value. In this implementation, each attribute has only a value. These  each attribute has only a value. These methods will treat the value as a list with the individual
1223  methods will treat the value as a list with the individual elements separated by the  elements separated by the value of the splitter parameter on the constructor (L</new>). The default
1224  value of the splitter parameter on the constructor (L</new>). The default is double  is double colons C<::>.
 colons C<::>.  
1225    
1226  So, for example, an old-style keyword with a value of C<essential> and a URL of  So, for example, an old-style keyword with a value of C<essential> and a URL of
1227  C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default  C<http://www.sciencemag.org/cgi/content/abstract/293/5538/2266> using the default
# Line 1306  Line 1273 
1273  which has no wildcard in the key or the object ID, may return multiple tuples.  which has no wildcard in the key or the object ID, may return multiple tuples.
1274    
1275  Value matching in this system works very poorly, because of the way multiple values are  Value matching in this system works very poorly, because of the way multiple values are
1276  stored. For the object ID and key name, we create queries that filter for the desired  stored. For the object ID, key name, and first value, we create queries that filter for the
1277  results. For the values, we do a comparison after the attributes are retrieved from the  desired results. On any filtering by value, we must do a comparison after the attributes are
1278  database. As a result, queries in which filter only on value end up reading the entire  retrieved from the database, since the database has no notion of the multiple values, which
1279  attribute table to find the desired results.  are stored in a single string. As a result, queries in which filter only on value end up
1280    reading a lot more than they need to.
1281    
1282  =over 4  =over 4
1283    
# Line 1351  Line 1319 
1319  sub GetAttributes {  sub GetAttributes {
1320      # Get the parameters.      # Get the parameters.
1321      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1322      # We will create one big honking query. The following hash will build the filter      # This hash will map "HasValueFor" fields to patterns. We use it to build the
1323      # clause and a parameter list.      # SQL statement.
1324      my %data = ('HasValueFor(from-link)' => $key, 'HasValueFor(to-link)' => $objectID);      my %data;
1325        # Before we do anything else, we must parse the key. The key is treated by the
1326        # user as a single field, but to us it's actually a real key and a subkey.
1327        # If the key has no splitter and is exact, the real key is the original key
1328        # and the subkey is an empty string. If the key has a splitter, it is
1329        # split into two pieces and each piece is processed separately. If the key has
1330        # no splitter and is generic, the real key is the incoming key and the subkey
1331        # is allowed to be wild. Of course, this only matters if an actual key has
1332        # been specified.
1333        if (defined $key) {
1334            if ($key =~ /$self->{splitter}/) {
1335                # Here we have a two-part key, so we split it normally.
1336                my ($realKey, $subKey) = $self->SplitKey($key);
1337                $data{'HasValueFor(from-link)'} = $realKey;
1338                $data{'HasValueFor(subkey)'} = $subKey;
1339            } elsif (substr($key, -1, 1) eq '%') {
1340                $data{'HasValueFor(from-link)'} = $key;
1341            } else {
1342                $data{'HasValueFor(from-link)'} = $key;
1343                $data{'HasValueFor(subkey)'} = '';
1344            }
1345        }
1346        # Add the object ID to the key information.
1347        $data{'HasValueFor(to-link)'} = $objectID;
1348        # The first value represents a problem, because we can search it using SQL, but not
1349        # in the normal way. If the user specifies a generic search or exact match for
1350        # every alternative value (remember, the values may be specified as a list),
1351        # then we can create SQL filtering for it. If any of the values are specified
1352        # as a regular expression, however, that's a problem, because we need to read
1353        # every value to verify a match.
1354        if (@values > 0) {
1355            # Get the first value and put its alternatives in an array.
1356            my $valueParm = $values[0];
1357            my @valueList;
1358            if (ref $valueParm eq 'ARRAY') {
1359                @valueList = @{$valueParm};
1360            } else {
1361                @valueList = ($valueParm);
1362            }
1363            # Okay, now we have all the possible criteria for the first value in the list
1364            # @valueList. We'll copy the values to a new array in which they have been
1365            # converted to generic requests. If we find a regular-expression match
1366            # anywhere in the list, we toss the whole thing.
1367            my @valuePatterns = ();
1368            my $okValues = 1;
1369            for my $valuePattern (@valueList) {
1370                # Check the pattern type.
1371                if (substr($valuePattern, 0, 1) eq '/') {
1372                    # Regular expressions invalidate the entire process.
1373                    $okValues = 0;
1374                } elsif (substr($valuePattern, -1, 1) eq '%') {
1375                    # A Generic pattern is passed in unmodified.
1376                    push @valuePatterns, $valuePattern;
1377                } else {
1378                    # An exact match is converted to generic.
1379                    push @valuePatterns, "$valuePattern%";
1380                }
1381            }
1382            # If everything works, add the value data to the filtering hash.
1383            if ($okValues) {
1384                $data{'HasValueFor(value)'} = \@valuePatterns;
1385            }
1386        }
1387        # Create some lists to contain the filter fragments and parameter values.
1388      my @filter = ();      my @filter = ();
1389      my @parms = ();      my @parms = ();
1390      # 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
1391      # parameter list and generates filters for each.      # parameter list and generates filters for each. The %data hash that we built above
1392        # contains all the necessary information to do this.
1393      for my $field (keys %data) {      for my $field (keys %data) {
1394          # Accumulate filter information for this field. We will OR together all the          # Accumulate filter information for this field. We will OR together all the
1395          # elements accumulated to create the final result.          # elements accumulated to create the final result.
# Line 1385  Line 1417 
1417                          push @fieldFilter, "$field = ?";                          push @fieldFilter, "$field = ?";
1418                          push @parms, $pattern;                          push @parms, $pattern;
1419                      } else {                      } else {
1420                          # Here we have a generate request, so we will use the LIKE operator to                          # Here we have a generic request, so we will use the LIKE operator to
1421                          # filter the field to this value pattern.                          # filter the field to this value pattern.
1422                          push @fieldFilter, "$field LIKE ?";                          push @fieldFilter, "$field LIKE ?";
1423                          # We must convert the pattern value to an SQL match pattern. First                          # We must convert the pattern value to an SQL match pattern. First
# Line 1456  Line 1488 
1488          # Okay, now we have some reason to believe we can do this. Form the values          # Okay, now we have some reason to believe we can do this. Form the values
1489          # into a scalar.          # into a scalar.
1490          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1491            # Split up the key.
1492            my ($realKey, $subKey) = $self->SplitKey($key);
1493          # Connect the object to the key.          # Connect the object to the key.
1494          $self->InsertObject('HasValueFor', { 'from-link' => $key,          $self->InsertObject('HasValueFor', { 'from-link' => $realKey,
1495                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1496                                                 'subkey'    => $subKey,
1497                                               'value'     => $valueString,                                               'value'     => $valueString,
1498                                         });                                         });
1499      }      }
# Line 1499  Line 1534 
1534          Confess("No object ID specified for DeleteAttribute call.");          Confess("No object ID specified for DeleteAttribute call.");
1535      } elsif (! defined($key)) {      } elsif (! defined($key)) {
1536          Confess("No attribute key specified for DeleteAttribute call.");          Confess("No attribute key specified for DeleteAttribute call.");
1537      } elsif (scalar(@values) == 0) {      } else {
1538            # Split the key into the real key and the subkey.
1539            my ($realKey, $subKey) = $self->SplitKey($key);
1540            if ($subKey eq '' && scalar(@values) == 0) {
1541          # Here we erase the entire key for this object.          # Here we erase the entire key for this object.
1542          $self->DeleteRow('HasValueFor', $key, $objectID);          $self->DeleteRow('HasValueFor', $key, $objectID);
1543      } else {      } else {
1544          # Here we erase the matching values.          # Here we erase the matching values.
1545          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1546          $self->DeleteRow('HasValueFor', $key, $objectID, { value => $valueString });              $self->DeleteRow('HasValueFor', $realKey, $objectID,
1547                                 { subkey => $subKey, value => $valueString });
1548            }
1549      }      }
1550      # Return a one. This is for backward compatability.      # Return a one. This is for backward compatability.
1551      return 1;      return 1;
# Line 1634  Line 1674 
1674    
1675  =item key  =item key
1676    
1677  Key to erase.  Key to erase. This must be a real key; that is, it cannot have a subkey
1678    component.
1679    
1680  =back  =back
1681    
# Line 1681  Line 1722 
1722      return sort @groups;      return sort @groups;
1723  }  }
1724    
1725    =head2 Key and ID Manipulation Methods
1726    
1727  =head3 ParseID  =head3 ParseID
1728    
1729  C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>  C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>
# Line 1816  Line 1859 
1859      return $retVal;      return $retVal;
1860  }  }
1861    
1862    =head3 SplitKey
1863    
1864    C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>
1865    
1866    Split an external key (that is, one passed in by a caller) into the real key and the sub key.
1867    The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,
1868    then the sub key is presumed to be an empty string.
1869    
1870    =over 4
1871    
1872    =item key
1873    
1874    Incoming key to be split.
1875    
1876    =item RETURN
1877    
1878    Returns a two-element list, the first element of which is the real key and the second element of
1879    which is the sub key.
1880    
1881    =back
1882    
1883    =cut
1884    
1885    sub SplitKey {
1886        # Get the parameters.
1887        my ($self, $key) = @_;
1888        # Do the split.
1889        my ($realKey, $subKey) = split($self->{splitter}, $key, 2);
1890        # Insure the subkey has a value.
1891        if (! defined $subKey) {
1892            $subKey = '';
1893        }
1894        # Return the results.
1895        return ($realKey, $subKey);
1896    }
1897    
1898    =head3 JoinKey
1899    
1900    C<< my $key = $ca->JoinKey($realKey, $subKey); >>
1901    
1902    Join a real key and a subkey together to make an external key. The external key is the attribute key
1903    used by the caller. The real key and the subkey are how the keys are represented in the database. The
1904    real key is the key to the B<AttributeKey> entity. The subkey is an attribute of the B<HasValueFor>
1905    relationship.
1906    
1907    =over 4
1908    
1909    =item realKey
1910    
1911    The real attribute key.
1912    
1913    =item subKey
1914    
1915    The subordinate portion of the attribute key.
1916    
1917    =item RETURN
1918    
1919    Returns a single string representing both keys.
1920    
1921    =back
1922    
1923    =cut
1924    
1925    sub JoinKey {
1926        # Get the parameters.
1927        my ($self, $realKey, $subKey) = @_;
1928        # Declare the return variable.
1929        my $retVal;
1930        # Check for a subkey.
1931        if ($subKey eq '') {
1932            # No subkey, so the real key is the key.
1933            $retVal = $realKey;
1934        } else {
1935            # Subkey found, so the two pieces must be joined by a splitter.
1936            $retVal = "$realKey$self->{splitter}$subKey";
1937        }
1938        # Return the result.
1939        return $retVal;
1940    }
1941    
1942  1;  1;
Legend:
Removed from v.1.19  
changed lines
  Added in v.1.20
MCS Webmaster
 ViewVC Help
Powered by ViewVC 1.0.3