[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.21, Sun Feb 18 22:13:53 2007 UTC revision 1.38, Sat Oct 18 09:52:21 2008 UTC
# Line 9  Line 9 
9      use Tracer;      use Tracer;
10      use ERDBLoad;      use ERDBLoad;
11      use Stats;      use Stats;
12        use Time::HiRes qw(time);
13        use FIGRules;
14    
15  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
16    
# Line 124  Line 126 
126  functions as data to the attribute management process, so if the data is  functions as data to the attribute management process, so if the data is
127  moved, this file must go with it.  moved, this file must go with it.
128    
129    =item attr_default_table
130    
131    Name of the default relationship for attribute values. If not present,
132    C<HasValueFor> is used.
133    
134  =back  =back
135    
136  =head2 Public Methods  =head2 Public Methods
137    
138  =head3 new  =head3 new
139    
140  C<< my $attrDB = CustomAttributes->new(%options); >>      my $attrDB = CustomAttributes->new(%options);
141    
142  Construct a new CustomAttributes object. The following options are  Construct a new CustomAttributes object. The following options are
143  supported.  supported.
# Line 154  Line 161 
161  sub new {  sub new {
162      # Get the parameters.      # Get the parameters.
163      my ($class, %options) = @_;      my ($class, %options) = @_;
164        # Get the name ofthe default table.
165      # Connect to the database.      # Connect to the database.
166      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
167                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
# Line 167  Line 175 
175      # Store the user name.      # Store the user name.
176      $retVal->{user} = $options{user} || '<unknown>';      $retVal->{user} = $options{user} || '<unknown>';
177      Trace("User $retVal->{user} selected for attribute object.") if T(3);      Trace("User $retVal->{user} selected for attribute object.") if T(3);
178        # Compute the default value table name. If it's not overridden, the
179        # default is HasValueFor.
180        $retVal->{defaultRel} = $FIG_Config::attr_default_table || 'HasValueFor';
181      # Return the result.      # Return the result.
182      return $retVal;      return $retVal;
183  }  }
184    
185  =head3 StoreAttributeKey  =head3 StoreAttributeKey
186    
187  C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>      $attrDB->StoreAttributeKey($attributeName, $notes, \@groups, $table);
188    
189  Create or update an attribute for the database.  Create or update an attribute for the database.
190    
# Line 183  Line 194 
194    
195  Name of the attribute (the real key). If it does not exist already, it will be created.  Name of the attribute (the real key). If it does not exist already, it will be created.
196    
 =item type  
   
 Data type of the attribute. This must be a valid ERDB data type name.  
   
197  =item notes  =item notes
198    
199  Descriptive notes about the attribute. It is presumed to be raw text, not HTML.  Descriptive notes about the attribute. It is presumed to be raw text, not HTML.
# Line 196  Line 203 
203  Reference to a list of the groups to which the attribute should be associated.  Reference to a list of the groups to which the attribute should be associated.
204  This will replace any groups to which the attribute is currently attached.  This will replace any groups to which the attribute is currently attached.
205    
206    =item table
207    
208    The name of the relationship in which the attribute's values are to be stored.
209    If empty or undefined, the default relationship (usually C<HasValueFor>) will be
210    assumed.
211    
212  =back  =back
213    
214  =cut  =cut
215    
216  sub StoreAttributeKey {  sub StoreAttributeKey {
217      # Get the parameters.      # Get the parameters.
218      my ($self, $attributeName, $type, $notes, $groups) = @_;      my ($self, $attributeName, $notes, $groups, $table) = @_;
219      # Declare the return variable.      # Declare the return variable.
220      my $retVal;      my $retVal;
221        # Default the table name.
222        if (! $table) {
223            $table = $self->{defaultRel};
224        }
225      # Get the data type hash.      # Get the data type hash.
226      my %types = ERDB::GetDataTypes();      my %types = ERDB::GetDataTypes();
227      # Validate the initial input values.      # Validate the initial input values.
228      if ($attributeName =~ /$self->{splitter}/) {      if ($attributeName =~ /$self->{splitter}/) {
229          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
230      } elsif (! $notes || length($notes) < 25) {      } elsif (! $notes) {
231          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing description for $attributeName.");
232      } elsif (! exists $types{$type}) {      } elsif (! grep { $_ eq $table } $self->GetConnectingRelationships('AttributeKey')) {
233          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid relationship name \"$table\" specified as a custom attribute table.");
234      } else {      } else {
235          # Create a variable to hold the action to be displayed for the log (Add or Update).          # Create a variable to hold the action to be displayed for the log (Add or Update).
236          my $action;          my $action;
# Line 223  Line 240 
240              # It does, so we do an update.              # It does, so we do an update.
241              $action = "Update Key";              $action = "Update Key";
242              $self->UpdateEntity('AttributeKey', $attributeName,              $self->UpdateEntity('AttributeKey', $attributeName,
243                                  { description => $notes, 'data-type' => $type });                                  { description => $notes,
244                                      'relationship-name' => $table});
245              # Detach the key from its current groups.              # Detach the key from its current groups.
246              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
247          } else {          } else {
248              # It doesn't, so we do an insert.              # It doesn't, so we do an insert.
249              $action = "Insert Key";              $action = "Insert Key";
250              $self->InsertObject('AttributeKey', { id => $attributeName,              $self->InsertObject('AttributeKey', { id => $attributeName,
251                                  description => $notes, 'data-type' => $type });                                  description => $notes,
252                                    'relationship-name' => $table});
253          }          }
254          # Attach the key to the specified groups. (We presume the groups already          # Attach the key to the specified groups. (We presume the groups already
255          # exist.)          # exist.)
# Line 246  Line 265 
265    
266  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
267    
268  C<< my $stats = $attrDB->DeleteAttributeKey($attributeName); >>      my $stats = $attrDB->DeleteAttributeKey($attributeName);
269    
270  Delete an attribute from the custom attributes database.  Delete an attribute from the custom attributes database.
271    
# Line 278  Line 297 
297    
298  =head3 NewName  =head3 NewName
299    
300  C<< my $text = CustomAttributes::NewName(); >>      my $text = CustomAttributes::NewName();
301    
302  Return the string used to indicate the user wants to add a new attribute.  Return the string used to indicate the user wants to add a new attribute.
303    
# Line 288  Line 307 
307      return "(new)";      return "(new)";
308  }  }
309    
 =head3 ControlForm  
   
 C<< my $formHtml = $attrDB->ControlForm($cgi, $name, \%keys); >>  
   
 Return a form that can be used to control the creation and modification of  
 attributes. Only a subset of the attribute keys will be displayed, as  
 determined by the incoming list.  
   
 =over 4  
   
 =item cgi  
   
 CGI query object used to create HTML.  
   
 =item name  
   
 Name to give to the form. This should be unique for the web page.  
   
 =item keys  
   
 Reference to a hash mapping attribute keys to n-tuples. Each tuple will contain the  
 attribute's data type, its description, and a list of the groups in which it participates.  
   
 =item RETURN  
   
 Returns the HTML for a form that can be used to  submit instructions to the C<Attributes.cgi> script  
 for loading, creating, displaying, changing, or deleting an attribute. Note that only the form  
 controls are generated. The form tags are left to the caller.  
   
 =back  
   
 =cut  
   
 sub ControlForm {  
     # Get the parameters.  
     my ($self, $cgi, $name, $keys) = @_;  
     # Declare the return list.  
     my @retVal = ();  
     # We'll put the controls in a table. Nothing else ever seems to look nice.  
     push @retVal, $cgi->start_table({ border => 2, cellpadding => 2 });  
     # The first row is for selecting the field name.  
     push @retVal, $cgi->Tr($cgi->th("Select a Field"),  
                            $cgi->td($self->FieldMenu($cgi, 10, 'fieldName', $keys,  
                                                      new => 1,  
                                                      notes => "document.$name.notes.value",  
                                                      type => "document.$name.dataType.value",  
                                                      groups => "document.$name.groups")));  
     # Now we set up a dropdown for the data types. The values will be the  
     # data type names, and the labels will be the descriptions.  
     my %types = ERDB::GetDataTypes();  
     my %labelMap = map { $_ => $types{$_}->{notes} } keys %types;  
     my $typeMenu = $cgi->popup_menu(-name   => 'dataType',  
                                     -values => [sort keys %types],  
                                     -labels => \%labelMap,  
                                     -default => 'string');  
     # Allow the user to specify a new field name. This is required if the  
     # user has selected the "(new)" marker. We put a little scriptlet in here that  
     # selects the (new) marker when the user enters the field.  
     push @retVal, "<script language=\"javaScript\">";  
     my $fieldField = "document.$name.fieldName";  
     my $newName = "\"" . NewName() . "\"";  
     push @retVal, $cgi->Tr($cgi->th("New Field Name"),  
                            $cgi->td($cgi->textfield(-name => 'newName',  
                                                     -size => 30,  
                                                     -value => "",  
                                                     -onFocus => "setIfEmpty($fieldField, $newName);")),  
                                     );  
     push @retVal, $cgi->Tr($cgi->th("Data type"),  
                            $cgi->td($typeMenu));  
     # The next row is for the notes.  
     push @retVal, $cgi->Tr($cgi->th("Description"),  
                            $cgi->td($cgi->textarea(-name => 'notes',  
                                                    -rows => 6,  
                                                    -columns => 80))  
                           );  
     # Now we have the groups, which are implemented as a checkbox group.  
     my @groups = $self->GetGroups();  
     push @retVal, $cgi->Tr($cgi->th("Groups"),  
                            $cgi->td($cgi->checkbox_group(-name=>'groups',  
                                     -values=> \@groups))  
                           );  
     # Now the four buttons: STORE, SHOW, ERASE, and DELETE.  
     push @retVal, $cgi->Tr($cgi->th("&nbsp;"),  
                            $cgi->td({align => 'center'}, join(" ",  
                                     $cgi->submit(-name => 'Delete', -value => 'DELETE'),  
                                     $cgi->submit(-name => 'Store',  -value => 'STORE'),  
                                     $cgi->submit(-name => 'Erase',  -value => 'ERASE'),  
                                     $cgi->submit(-name => 'Show',   -value => 'SHOW')  
                                    ))  
                           );  
     # Close the table and the form.  
     push @retVal, $cgi->end_table();  
     # Return the assembled HTML.  
     return join("\n", @retVal, "");  
 }  
   
310  =head3 LoadAttributesFrom  =head3 LoadAttributesFrom
311    
312  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
313    
314  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
315  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
316  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values must
317  be assembled into a single value using the splitter code. In addition, the key names may  be assembled into a single value using the splitter code. In addition, the key names may
318  contain a splitter. If this is the case, the portion of the key after the splitter is  contain a splitter. If this is the case, the portion of the key after the splitter is
319  treated as a subkey.  treated as a subkey.
# Line 417  Line 340 
340    
341  =over 4  =over 4
342    
343    =item mode
344    
345    Loading mode. Legal values are C<low_priority> (which reduces the task priority
346    of the load) and C<concurrent> (which reduces the locking cost of the load). The
347    default is a normal load.
348    
349  =item append  =item append
350    
351  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
# Line 424  Line 353 
353    
354  =item archive  =item archive
355    
356  If specified, the name of a file into which the incoming data file should be saved.  If specified, the name of a file into which the incoming data should be saved.
357    If I<resume> is also specified, only the lines actually loaded will be put
358    into this file.
359    
360  =item objectType  =item objectType
361    
362  If specified, the specified object type will be prefixed to each object ID.  If specified, the specified object type will be prefixed to each object ID.
363    
364    =item resume
365    
366    If specified, key-value pairs already in the database will not be reinserted.
367    Specify a number to start checking after the specified number of lines and
368    then admit everything after the first line not yet loaded. Specify C<careful>
369    to check every single line. Specify C<none> to ignore this option. The default
370    is C<none>. So, if you believe that a previous load failed somewhere after 50000
371    lines, a resume value of C<50000> would skip 50000 lines in the file, then
372    check each line after that until it finds one not already in the database. The
373    first such line found and all lines after that will be loaded. On the other
374    hand, if you have a file of 100000 records, and some have been loaded and some
375    not, you would use the word C<careful>, so that every line would be checked before
376    it is inserted. A resume of C<0> will start checking the first line of the
377    input file and then begin loading once it finds a line not in the database.
378    
379    =item chunkSize
380    
381    Number of lines to load in each burst. The default is 10,000.
382    
383  =back  =back
384    
385  =cut  =cut
# Line 438  Line 388 
388      # Get the parameters.      # Get the parameters.
389      my ($self, $fileName, %options) = @_;      my ($self, $fileName, %options) = @_;
390      # Declare the return variable.      # Declare the return variable.
391      my $retVal = Stats->new('keys', 'values');      my $retVal = Stats->new('keys', 'values', 'linesOut');
392        # Initialize the timers.
393        my ($eraseTime, $archiveTime, $checkTime) = (0, 0, 0);
394      # Check for append mode.      # Check for append mode.
395      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
396        # Check for resume mode.
397        my $resume = (defined($options{resume}) ? $options{resume} : 'none');
398      # Create a hash of key names found.      # Create a hash of key names found.
399      my %keyHash = ();      my %keyHash = ();
400        # Create a hash of table names to files. Most attributes go into the HasValueFor
401        # table, but some are put into other tables. Each table name will be mapped
402        # to a sub-hash with keys "fileName" (output file for the table) and "count"
403        # (number of lines in the file).
404        my %tableHash = ();
405        # Compute the chunk size.
406        my $chunkSize = ($options{chunkSize} ? $options{chunkSize} : 10000);
407      # Open the file for input. Note we must anticipate the possibility of an      # Open the file for input. Note we must anticipate the possibility of an
408      # open filehandle being passed in.      # open filehandle being passed in. This occurs when the user is submitting
409        # the load file over the web.
410      my $fh;      my $fh;
411      if (ref $fileName) {      if (ref $fileName) {
412          Trace("Using file opened by caller.") if T(3);          Trace("Using file opened by caller.") if T(3);
# Line 453  Line 415 
415          Trace("Attributes will be loaded from $fileName.") if T(3);          Trace("Attributes will be loaded from $fileName.") if T(3);
416          $fh = Open(undef, "<$fileName");          $fh = Open(undef, "<$fileName");
417      }      }
418        # Trace the mode.
419        if (T(3)) {
420            if ($options{mode}) {
421                Trace("Mode is $options{mode}.")
422            } else {
423                Trace("No mode specified.")
424            }
425        }
426      # Now check to see if we need to archive.      # Now check to see if we need to archive.
427      my $ah;      my $ah;
428      if ($options{archive}) {      if (exists $options{archive}) {
429          $ah = Open(undef, ">$options{archive}");          my $ah = Open(undef, ">$options{archive}");
430          Trace("Load file will be archived to $options{archive}.") if T(3);          Trace("Load file will be archived to $options{archive}.") if T(3);
431      }      }
432      # Finally, open a database transaction.      # Insure we recover from errors.
     $self->BeginTran();  
     # Insure we recover from errors. If an error occurs, we will delete the archive file and  
     # roll back the updates.  
433      eval {      eval {
434            # If we have a resume number, process it here.
435            if ($resume =~ /\d+/) {
436                Trace("Skipping $resume lines.") if T(2);
437                my $startTime = time();
438                # Skip the specified number of lines.
439                for (my $skipped = 0; ! eof($fh) && $skipped < $resume; $skipped++) {
440                    my $line = <$fh>;
441                    $retVal->Add(skipped => 1);
442                }
443                $checkTime += time() - $startTime;
444            }
445          # Loop through the file.          # Loop through the file.
446            Trace("Starting load.") if T(2);
447          while (! eof $fh) {          while (! eof $fh) {
448              # Read the current line.              # Read the current line.
449              my ($id, $key, @values) = Tracer::GetLine($fh);              my ($id, $key, @values) = Tracer::GetLine($fh);
450              $retVal->Add(linesIn => 1);              $retVal->Add(linesIn => 1);
             # Check to see if we need to fix up the object ID.  
             if ($options{objectType}) {  
                 $id = "$options{objectType}:$id";  
             }  
             # Archive the line (if necessary).  
             if (defined $ah) {  
                 Tracer::PutLine($ah, [$id, $key, @values]);  
             }  
451              # Do some validation.              # Do some validation.
452              if (! $id) {              if (! $id) {
453                  # We ignore blank lines.                  # We ignore blank lines.
# Line 488  Line 459 
459                  # An ID without a key is a serious error.                  # An ID without a key is a serious error.
460                  my $lines = $retVal->Ask('linesIn');                  my $lines = $retVal->Ask('linesIn');
461                  Confess("Line $lines in $fileName has no attribute key.");                  Confess("Line $lines in $fileName has no attribute key.");
462                } elsif (! @values) {
463                    # A line with no values is not allowed.
464                    my $lines = $retVal->Ask('linesIn');
465                    Trace("Line $lines for key $key has no attribute values.") if T(1);
466                    $retVal->Add(skipped => 1);
467              } else {              } else {
468                    # Check to see if we need to fix up the object ID.
469                    if ($options{objectType}) {
470                        $id = "$options{objectType}:$id";
471                    }
472                  # The key contains a real part and an optional sub-part. We need the real part.                  # The key contains a real part and an optional sub-part. We need the real part.
473                  my ($realKey, $subKey) = $self->SplitKey($key);                  my ($realKey, $subKey) = $self->SplitKey($key);
474                  # Now we need to check for a new key.                  # Now we need to check for a new key.
475                  if (! exists $keyHash{$realKey}) {                  if (! exists $keyHash{$realKey}) {
476                      if (! $self->Exists('AttributeKey', $realKey)) {                      my $keyObject = $self->GetEntity(AttributeKey => $realKey);
477                        if (! defined($keyObject)) {
478                            # Here the specified key does not exist, which is an error.
479                          my $line = $retVal->Ask('linesIn');                          my $line = $retVal->Ask('linesIn');
480                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
481                      } else {                      } else {
482                          # Make sure we know this is no longer a new key.                          # Make sure we know this is no longer a new key. We do this by putting
483                          $keyHash{$realKey} = 1;                          # its table name in the key hash.
484                            $keyHash{$realKey} = $keyObject->PrimaryValue('AttributeKey(relationship-name)');
485                          $retVal->Add(keys => 1);                          $retVal->Add(keys => 1);
486                          # If this is NOT append mode, erase the key.                          # If this is NOT append mode, erase the key. This does not delete the key
487                            # itself; it just clears out all the values.
488                          if (! $append) {                          if (! $append) {
489                                my $startTime = time();
490                              $self->EraseAttribute($realKey);                              $self->EraseAttribute($realKey);
491                                $eraseTime += time() - $startTime;
492                                Trace("Attribute $realKey erased.") if T(3);
493                          }                          }
494                      }                      }
495                      Trace("Key $realKey found.") if T(3);                      Trace("Key $realKey found.") if T(3);
496                  }                  }
497                  # Everything is all set up, so add the value.                  # If we're in resume mode, check to see if this insert is redundant.
498                  $self->AddAttribute($id, $key, @values);                  my $ok = 1;
499                  my $progress = $retVal->Add(values => 1);                  if ($resume ne 'none') {
500                  Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);                      my $startTime = time();
501                        my $count = $self->GetAttributes($id, $key, @values);
502                        if ($count) {
503                            # Here the record is found, so we skip it.
504                            $ok = 0;
505                            $retVal->Add(skipped => 1);
506                        } else {
507                            # Here the record is not found. If we're in non-careful mode, we
508                            # stop resume checking at this point.
509                            if ($resume ne 'careful') {
510                                $resume = 'none';
511              }              }
512          }          }
513                        $checkTime += time() - $startTime;
514                    }
515                    if ($ok) {
516                        # We're in business. First, archive this row.
517                        if (defined $ah) {
518                            my $startTime = time();
519                            Tracer::PutLine($ah, [$id, $key, @values]);
520                            $archiveTime += time() - $startTime;
521                        }
522                        # We need to format the attribute data so it will work
523                        # as if it were a load file. This means we join the
524                        # values.
525                        my $valueString = join('::', @values);
526                        # Now we need to get access to the key's load file. Check for it in the
527                        # table hash.
528                        my $keyTable = $keyHash{$realKey};
529                        if (! exists $tableHash{$keyTable}) {
530                            # This is a new table, so we need to set it up. First, we get
531                            # a temporary file for it.
532                            my $tempFileName = FIGRules::GetTempFileName(sessionID => $$ . $keyTable,
533                                                                         extension => 'dtx');
534                            my $oh = Open(undef, ">$tempFileName");
535                            # Now we create its descriptor in the table hash.
536                            $tableHash{$keyTable} = {fileName => $tempFileName, handle => $oh, count => 0};
537                        }
538                        # Everything is all set up, so we put the value in the temporary file and
539                        # count it.
540                        my $tableData = $tableHash{$keyTable};
541                        my $startTime = time();
542                        Tracer::PutLine($tableData->{handle}, [$realKey, $id, $subKey, $valueString]);
543                        $archiveTime += time() - $startTime;
544                        $retVal->Add(linesOut => 1);
545                        $tableData->{count}++;
546                        # See if it's time to load a chunk.
547                        if ($tableData->{count} >= $chunkSize) {
548                            # We've filled a chunk, so it's time.
549                            close $tableData->{handle};
550                            $self->_LoadAttributeTable($keyTable, $tableData->{fileName}, $retVal);
551                            # Reset for the next chunk.
552                            $tableData->{count} = 0;
553                            $tableData->{handle} = Open(undef, ">$tableData->{fileName}");
554                        }
555                    } else {
556                        # Here we skipped because of resume mode.
557                        $retVal->Add(resumeSkip => 1);
558                    }
559                    Trace($retVal->Ask('values') . " values processed.") if $retVal->Check(values => 1000) && T(3);
560                }
561            }
562            # Now we close the archive file. Note we undefine the handle so the error methods know
563            # not to worry.
564            if (defined $ah) {
565                close $ah;
566                undef $ah;
567            }
568            # Now we load the residual from the temporary files (if any). This time we'll do an
569            # analyze as well.
570            for my $tableName (keys %tableHash) {
571                # Get the data for this table.
572                my $tableData = $tableHash{$tableName};
573                # Close the handle. ERDB will re-open it for input later.
574                close $tableData->{handle};
575                # Check to see if there's anything left to load.
576                if ($tableData->{count} > 0) {
577                    # Yes, load the data.
578                    $self->_LoadAttributeTable($tableName, $tableData->{fileName}, $retVal);
579                }
580                # Regardless of whether additional loading was required, we need to
581                # analyze the table for performance.
582                my $startTime = time();
583                $self->Analyze($tableName);
584                $retVal->Add(analyzeTime => time() - $startTime);
585            }
586            Trace("Attribute load successful.") if T(2);
587      };      };
588      # Check for an error.      # Check for an error.
589      if ($@) {      if ($@) {
590          # Here we have an error. Roll back the transaction and delete the archive file.          # Here we have an error. Display the error message.
591          my $message = $@;          my $message = $@;
592          Trace("Rolling back attribute updates due to error.") if T(1);          Trace("Error during attribute load: $message") if T(0);
593          $self->RollbackTran();          $retVal->AddMessage($message);
594          if (defined $ah) {          # Close the archive file if it's open. The archive file can sometimes provide
595              Trace("Deleting archive file $options{archive}.") if T(1);          # clues as to what happened.
             close $ah;  
             unlink $options{archive};  
         }  
         Confess("Error during attribute load: $message");  
     } else {  
         # Here the load worked. Commit the transaction and close the archive file.  
         Trace("Committing attribute upload.") if T(2);  
         $self->CommitTran();  
596          if (defined $ah) {          if (defined $ah) {
             Trace("Closing archive file $options{archive}.") if T(2);  
597              close $ah;              close $ah;
598          }          }
599      }      }
600        # Store the timers.
601        $retVal->Add(eraseTime   => $eraseTime);
602        $retVal->Add(archiveTime => $archiveTime);
603        $retVal->Add(checkTime   => $checkTime);
604      # Return the result.      # Return the result.
605      return $retVal;      return $retVal;
606  }  }
607    
608  =head3 BackupKeys  =head3 BackupKeys
609    
610  C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>      my $stats = $attrDB->BackupKeys($fileName, %options);
611    
612  Backup the attribute key information from the attribute database.  Backup the attribute key information from the attribute database.
613    
# Line 581  Line 647 
647      while (my $keyData = $keyQuery->Fetch()) {      while (my $keyData = $keyQuery->Fetch()) {
648          $retVal->Add(key => 1);          $retVal->Add(key => 1);
649          # Get the fields.          # Get the fields.
650          my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',          my ($id, $type, $tableName, $description) =
651                $keyData->Values(['AttributeKey(id)', 'AttributeKey(relationship-name)',
652                                                            'AttributeKey(description)']);                                                            'AttributeKey(description)']);
653          # Escape any tabs or new-lines in the description.          # Escape any tabs or new-lines in the description.
654          my $escapedDescription = Tracer::Escape($description);          my $escapedDescription = Tracer::Escape($description);
655          # Write the key data to the output.          # Write the key data to the output.
656          Tracer::PutLine($fh, [$id, $type, $escapedDescription]);          Tracer::PutLine($fh, [$id, $type, $tableName, $escapedDescription]);
657          # Get the key's groups.          # Get the key's groups.
658          my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],          my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
659                                      'IsInGroup(to-link)');                                      'IsInGroup(to-link)');
# Line 603  Line 670 
670    
671  =head3 RestoreKeys  =head3 RestoreKeys
672    
673  C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>      my $stats = $attrDB->RestoreKeys($fileName, %options);
674    
675  Restore the attribute keys and groups from a backup file.  Restore the attribute keys and groups from a backup file.
676    
# Line 630  Line 697 
697      # Loop until we're done.      # Loop until we're done.
698      while (! eof $fh) {      while (! eof $fh) {
699          # Get a key record.          # Get a key record.
700          my ($id, $dataType, $description) = Tracer::GetLine($fh);          my ($id, $tableName, $description) = Tracer::GetLine($fh);
701          if ($id eq '#GROUPS') {          if ($id eq '#GROUPS') {
702              Confess("Group record found when key record expected.");              Confess("Group record found when key record expected.");
703          } elsif (! defined($description)) {          } elsif (! defined($description)) {
# Line 638  Line 705 
705          } else {          } else {
706              $retVal->Add("keyIn" => 1);              $retVal->Add("keyIn" => 1);
707              # Add this key to the database.              # Add this key to the database.
708              $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,              $self->InsertObject('AttributeKey', { id => $id,
709                                                    description => Tracer::UnEscape($description) });                                                    description => Tracer::UnEscape($description),
710                                                      'relationship-name' => $tableName});
711              Trace("Attribute $id stored.") if T(3);              Trace("Attribute $id stored.") if T(3);
712              # Get the group line.              # Get the group line.
713              my ($marker, @groups) = Tracer::GetLine($fh);              my ($marker, @groups) = Tracer::GetLine($fh);
# Line 675  Line 743 
743    
744  =head3 ArchiveFileName  =head3 ArchiveFileName
745    
746  C<< my $fileName = $ca->ArchiveFileName(); >>      my $fileName = $ca->ArchiveFileName();
747    
748  Compute a file name for archiving attribute input data. The file will be in the attribute log directory  Compute a file name for archiving attribute input data. The file will be in the attribute log directory
749    
# Line 708  Line 776 
776    
777  =head3 BackupAllAttributes  =head3 BackupAllAttributes
778    
779  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>      my $stats = $attrDB->BackupAllAttributes($fileName, %options);
780    
781  Backup all of the attributes to a file. The attributes will be stored in a  Backup all of the attributes to a file. The attributes will be stored in a
782  tab-delimited file suitable for reloading via L</LoadAttributesFrom>.  tab-delimited file suitable for reloading via L</LoadAttributesFrom>.
# Line 739  Line 807 
807      # Declare the return variable.      # Declare the return variable.
808      my $retVal = Stats->new();      my $retVal = Stats->new();
809      # Get a list of the keys.      # Get a list of the keys.
810      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');      my %keys = map { $_->[0] => $_->[1] } $self->GetAll(['AttributeKey'],
811      Trace(scalar(@keys) . " keys found during backup.") if T(2);                                                          "", [], ['AttributeKey(id)',
812                                                                      'AttributeKey(relationship-name)']);
813        Trace(scalar(keys %keys) . " keys found during backup.") if T(2);
814      # Open the file for output.      # Open the file for output.
815      my $fh = Open(undef, ">$fileName");      my $fh = Open(undef, ">$fileName");
816      # Loop through the keys.      # Loop through the keys.
817      for my $key (@keys) {      for my $key (sort keys %keys) {
818          Trace("Backing up attribute $key.") if T(3);          Trace("Backing up attribute $key.") if T(3);
819          $retVal->Add(keys => 1);          $retVal->Add(keys => 1);
820            # Get the key's relevant relationship name.
821            my $relName = $keys{$key};
822          # Loop through this key's values.          # Loop through this key's values.
823          my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);          my $query = $self->Get([$relName], "$relName(from-link) = ?", [$key]);
824          my $valuesFound = 0;          my $valuesFound = 0;
825          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
826              $valuesFound++;              $valuesFound++;
827              # Get this row's data.              # Get this row's data.
828              my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',              my ($id, $key, $subKey, $value) = $line->Values(["$relName(to-link)",
829                                                               'HasValueFor(from-link)',                                                               "$relName(from-link)",
830                                                               'HasValueFor(subkey)',                                                               "$relName(subkey)",
831                                                               'HasValueFor(value)']);                                                               "$relName(value)"]);
832              # Check for a subkey.              # Check for a subkey.
833              if ($subKey ne '') {              if ($subKey ne '') {
834                  $key = "$key$self->{splitter}$subKey";                  $key = "$key$self->{splitter}$subKey";
835              }              }
836              # Write it to the file.              # Write it to the file.
837              Tracer::PutLine($fh, [$id, $key, $value]);              Tracer::PutLine($fh, [$id, $key, Escape($value)]);
838          }          }
839          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
840          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
# Line 773  Line 845 
845      return $retVal;      return $retVal;
846  }  }
847    
 =head3 FieldMenu  
   
 C<< my $menuHtml = $attrDB->FieldMenu($cgi, $height, $name, $keys, %options); >>  
   
 Return the HTML for a menu to select an attribute field. The menu will  
 be a standard SELECT/OPTION thing which is called "popup menu" in the  
 CGI package, but actually looks like a list. The list will contain  
 one selectable row per field.  
   
 =over 4  
   
 =item cgi  
   
 CGI query object used to generate HTML.  
   
 =item height  
   
 Number of lines to display in the list.  
   
 =item name  
   
 Name to give to the menu. This is the name under which the value will  
 appear when the form is submitted.  
   
 =item keys  
   
 Reference to a hash mapping each attribute key name to a list reference,  
 the list itself consisting of the attribute data type, its description,  
 and a list of its groups.  
   
 =item options  
   
 Hash containing options that modify the generation of the menu.  
   
 =item RETURN  
   
 Returns the HTML to create a form field that can be used to select an  
 attribute from the custom attributes system.  
   
 =back  
   
 The permissible options are as follows.  
   
 =over 4  
   
 =item new  
   
 If TRUE, then extra rows will be provided to allow the user to select  
 a new attribute. In other words, the user can select an existing  
 attribute, or can choose a C<(new)> marker to indicate a field to  
 be created in the parent entity.  
   
 =item notes  
   
 If specified, the name of a variable for displaying the notes attached  
 to the field. This must be in Javascript form ready for assignment.  
 So, for example, if you have a variable called C<notes> that  
 represents a paragraph element, you should code C<notes.innerHTML>.  
 If it actually represents a form field you should code C<notes.value>.  
 If an C<innerHTML> coding is used, the text will be HTML-escaped before  
 it is copied in. Specifying this parameter generates Javascript for  
 displaying the field description when a field is selected.  
   
 =item type  
   
 If specified, the name of a variable for displaying the field's  
 data type. Data types are a much more controlled vocabulary than  
 notes, so there is no worry about HTML translation. Instead, the  
 raw value is put into the specified variable. Otherwise, the same  
 rules apply to this value that apply to I<$noteControl>.  
   
 =item groups  
   
 If specified, the name of a multiple-selection list control (also called  
 a popup menu) which shall be used to display the selected groups.  
   
 =back  
   
 =cut  
   
 sub FieldMenu {  
     # Get the parameters.  
     my ($self, $cgi, $height, $name, $keys, %options) = @_;  
     # Reformat the list of keys.  
     my %keys = %{$keys};  
     # Add the (new) key, if needed.  
     if ($options{new}) {  
         $keys{NewName()} = ["string", ""];  
     }  
     # Get a sorted list of key.  
     my @keys = sort keys %keys;  
     # We need to create the name for the onChange function. This function  
     # may not do anything, but we need to know the name to generate the HTML  
     # for the menu.  
     my $changeName = "${name}_setNotes";  
     my $retVal = $cgi->popup_menu({name => $name,  
                                    size => $height,  
                                    onChange => "$changeName(this.value)",  
                                    values => \@keys,  
                                   });  
     # Create the change function.  
     $retVal .= "\n<script language=\"javascript\">\n";  
     $retVal .= "    function $changeName(fieldValue) {\n";  
     # The function only has a body if we have a control to store data about the  
     # attribute.  
     if ($options{notes} || $options{type} || $options{groups}) {  
         # Check to see if we're storing HTML or text into the note control.  
         my $noteControl = $options{notes};  
         my $htmlMode = ($noteControl && $noteControl =~ /innerHTML$/);  
         # We use a CASE statement based on the newly-selected field value. The  
         # field description will be stored in the JavaScript variable "myText"  
         # and the data type in "myType". Note the default data type is a normal  
         # string, but the default notes is an empty string.  
         $retVal .= "        var myText = \"\";\n";  
         $retVal .= "        var myType = \"string\";\n";  
         $retVal .= "        switch (fieldValue) {\n";  
         # Loop through the keys.  
         for my $key (@keys) {  
             # Generate this case.  
             $retVal .= "        case \"$key\" :\n";  
             # Here we either want to update the note display, the  
             # type display, the group list, or a combination of them.  
             my ($type, $notes, @groups) = @{$keys{$key}};  
             if ($noteControl) {  
                 # Insure it's in the proper form.  
                 if ($htmlMode) {  
                     $notes = ERDB::HTMLNote($notes);  
                 }  
                 # Escape it for use as a string literal.  
                 $notes =~ s/\n/\\n/g;  
                 $notes =~ s/"/\\"/g;  
                 $retVal .= "           myText = \"$notes\";\n";  
             }  
             if ($options{type}) {  
                 # Here we want the type updated.  
                 $retVal .= "           myType = \"$type\";\n";  
             }  
             if ($options{groups}) {  
                 # Here we want the groups shown. Get a list of this attribute's groups.  
                 # We'll search through this list for each group to see if it belongs with  
                 # our attribute.  
                 my $groupLiteral = "=" . join("=", @groups) . "=";  
                 # Now we need some variables containing useful code for the javascript. It's  
                 # worth knowing we go through a bit of pain to insure $groupField[i] isn't  
                 # parsed as an array element.  
                 my $groupField = $options{groups};  
                 my $currentField = $groupField . "[i]";  
                 # Do the javascript.  
                 $retVal .= "           var groupList = \"$groupLiteral\";\n";  
                 $retVal .= "           for (var i = 0; i < $groupField.length; i++) {\n";  
                 $retVal .= "              var srchString = \"=\" + $currentField.value + \"=\";\n";  
                 $retVal .= "              var srchLoc = groupList.indexOf(srchString);\n";  
                 $retVal .= "              $currentField.checked = (srchLoc >= 0);\n";  
                 $retVal .= "           }\n";  
             }  
             # Close this case.  
             $retVal .= "           break;\n";  
         }  
         # Close the CASE statement and make the appropriate assignments.  
         $retVal .= "        }\n";  
         if ($noteControl) {  
             $retVal .= "        $noteControl = myText;\n";  
         }  
         if ($options{type}) {  
             $retVal .= "        $options{type} = myType;\n";  
         }  
     }  
     # Terminate the change function.  
     $retVal .= "    }\n";  
     $retVal .= "</script>\n";  
     # Return the result.  
     return $retVal;  
 }  
848    
849  =head3 GetGroups  =head3 GetGroups
850    
851  C<< my @groups = $attrDB->GetGroups(); >>      my @groups = $attrDB->GetGroups();
852    
853  Return a list of the available groups.  Return a list of the available groups.
854    
# Line 966  Line 865 
865    
866  =head3 GetAttributeData  =head3 GetAttributeData
867    
868  C<< my %keys = $attrDB->GetAttributeData($type, @list); >>      my %keys = $attrDB->GetAttributeData($type, @list);
869    
870  Return attribute data for the selected attributes. The attribute  Return attribute data for the selected attributes. The attribute
871  data is a hash mapping each attribute key name to a n-tuple containing the  data is a hash mapping each attribute key name to a n-tuple containing the
872  data type, the description, and the groups. This is the same format expected in  data type, the description, the table name, and the groups.
 the L</FieldMenu> and L</ControlForm> methods for the list of attributes to display.  
873    
874  =over 4  =over 4
875    
# Line 986  Line 884 
884    
885  =item RETURN  =item RETURN
886    
887  Returns a hash mapping each attribute key name to its data type, description, and  Returns a hash mapping each attribute key name to its description,
888  parent groups.  table name, and parent groups.
889    
890  =back  =back
891    
# Line 1019  Line 917 
917          }          }
918          while (my $row = $query->Fetch()) {          while (my $row = $query->Fetch()) {
919              # Get this attribute's data.              # Get this attribute's data.
920              my ($key, $type, $notes) = $row->Values(['AttributeKey(id)', 'AttributeKey(data-type)',              my ($key, $relName, $notes) = $row->Values(['AttributeKey(id)',
921                                                         'AttributeKey(relationship-name)',
922                                                       'AttributeKey(description)']);                                                       'AttributeKey(description)']);
923              # If it's new, get its groups and add it to the return hash.              # If it's new, get its groups and add it to the return hash.
924              if (! exists $retVal{$key}) {              if (! exists $retVal{$key}) {
925                  my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",                  my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",
926                                              [$key], 'IsInGroup(to-link)');                                              [$key], 'IsInGroup(to-link)');
927                  $retVal{$key} = [$type, $notes, @groups];                  $retVal{$key} = [$relName, $notes, @groups];
928              }              }
929          }          }
930      }      }
# Line 1035  Line 934 
934    
935  =head3 LogOperation  =head3 LogOperation
936    
937  C<< $ca->LogOperation($action, $target, $description); >>      $ca->LogOperation($action, $target, $description);
938    
939  Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).  Write an operation description to the attribute activity log (C<$FIG_Config::var/attributes.log>).
940    
# Line 1072  Line 971 
971      close $oh;      close $oh;
972  }  }
973    
 =head2 Internal Utility Methods  
   
 =head3 _KeywordString  
   
 C<< my $keywordString = $ca->_KeywordString($key, $value); >>  
   
 Compute the keyword string for a specified key/value pair. This consists of the  
 key name and value converted to lower case with underscores translated to spaces.  
   
 This method is for internal use only. It is called whenever we need to update or  
 insert a B<HasValueFor> record.  
   
 =over 4  
   
 =item key  
   
 Name of the relevant attribute key.  
   
 =item target  
   
 ID of the target object to which this key/value pair will be associated.  
   
 =item value  
   
 The value to store for this key/object combination.  
   
 =item RETURN  
   
 Returns the value that should be stored as the keyword string for the specified  
 key/value pair.  
   
 =back  
   
 =cut  
   
 sub _KeywordString {  
     # Get the parameters.  
     my ($self, $key, $value) = @_;  
     # Get a copy of the key name and convert underscores to spaces.  
     my $keywordString = $key;  
     $keywordString =~ s/_/ /g;  
     # Add the value convert it all to lower case.  
     my $retVal = lc "$keywordString $value";  
     # Return the result.  
     return $retVal;  
 }  
   
 =head3 _QueryResults  
   
 C<< my @attributeList = $attrDB->_QueryResults($query, @values); >>  
   
 Match the results of a B<HasValueFor> query against value criteria and return  
 the results. This is an internal method that splits the values coming back  
 and matches the sections against the specified section patterns. It serves  
 as the back end to L</GetAttributes> and L</FindAttributes>.  
   
 =over 4  
   
 =item query  
   
 A query object that will return the desired B<HasValueFor> records.  
   
 =item values  
   
 List of the desired attribute values, section by section. If C<undef>  
 or an empty string is specified, all values in that section will match. A  
 generic match can be requested by placing a percent sign (C<%>) at the end.  
 In that case, all values that match up to and not including the percent sign  
 will match. You may also specify a regular expression enclosed  
 in slashes. All values that match the regular expression will be returned. For  
 performance reasons, only values have this extra capability.  
   
 =item RETURN  
   
 Returns a list of tuples. The first element in the tuple is an object ID, the  
 second is an attribute key, and the remaining elements are the sections of  
 the attribute value. All of the tuples will match the criteria set forth in  
 the parameter list.  
   
 =back  
   
 =cut  
   
 sub _QueryResults {  
     # Get the parameters.  
     my ($self, $query, @values) = @_;  
     # Declare the return value.  
     my @retVal = ();  
     # Get the number of value sections we have to match.  
     my $sectionCount = scalar(@values);  
     # Loop through the assignments found.  
     while (my $row = $query->Fetch()) {  
         # Get the current row's data.  
         my ($id, $realKey, $subKey, $valueString) = $row->Values(['HasValueFor(to-link)',  
                                                                   'HasValueFor(from-link)',  
                                                                   'HasValueFor(subkey)',  
                                                                   'HasValueFor(value)'  
                                                                 ]);  
         # Form the key from the real key and the sub key.  
         my $key = $self->JoinKey($realKey, $subKey);  
         # 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.  
             my $value = $values[$i];  
             Trace("Current value pattern is \"$value\".") if T(4);  
             if (substr($value, -1, 1) eq '%') {  
                 Trace("Generic match used.") if T(4);  
                 # Here we have a generic match.  
                 my $matchLen = length($values[$i]) - 1;  
                 $matching = substr($sections[$i], 0, $matchLen) eq  
                             substr($values[$i], 0, $matchLen);  
             } elsif ($value =~ m#^/(.+)/[a-z]*$#) {  
                 Trace("Regular expression detected.") if T(4);  
                 # Here we have a regular expression match.  
                 my $section = $sections[$i];  
                 $matching = eval("\$section =~ $value");  
             } else {  
                 # Here we have a strict match.  
                 Trace("Strict match used.") if T(4);  
                 $matching = ($sections[$i] eq $values[$i]);  
             }  
         }  
         # If we match, output this row to the return list.  
         if ($matching) {  
             push @retVal, [$id, $key, @sections];  
         }  
     }  
     # Return the rows found.  
     return @retVal;  
 }  
   
974  =head2 FIG Method Replacements  =head2 FIG Method Replacements
975    
976  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 1234  Line 998 
998    
999  =head3 GetAttributes  =head3 GetAttributes
1000    
1001  C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @values); >>      my @attributeList = $attrDB->GetAttributes($objectID, $key, @values);
1002    
1003  In the database, attribute values are sectioned into pieces using a splitter  In the database, attribute values are sectioned into pieces using a splitter
1004  value specified in the constructor (L</new>). This is not a requirement of  value specified in the constructor (L</new>). This is not a requirement of
# Line 1319  Line 1083 
1083  sub GetAttributes {  sub GetAttributes {
1084      # Get the parameters.      # Get the parameters.
1085      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1086      # This hash will map "HasValueFor" fields to patterns. We use it to build the      # Declare the return variable.
1087        my @retVal = ();
1088        # Insure we have at least some sort of filtering going on.
1089        if (! grep { defined $_ } $objectID, $key, @values) {
1090            Confess("No filters specified in GetAttributes call.");
1091        } else {
1092            # This hash will map value-table fields to patterns. We use it to build the
1093      # SQL statement.      # SQL statement.
1094      my %data;      my %data;
     # Before we do anything else, we must parse the key. The key is treated by the  
     # user as a single field, but to us it's actually a real key and a subkey.  
     # If the key has no splitter and is exact, the real key is the original key  
     # and the subkey is an empty string. If the key has a splitter, it is  
     # split into two pieces and each piece is processed separately. If the key has  
     # no splitter and is generic, the real key is the incoming key and the subkey  
     # is allowed to be wild. Of course, this only matters if an actual key has  
     # been specified.  
     if (defined $key) {  
         if ($key =~ /$self->{splitter}/) {  
             # Here we have a two-part key, so we split it normally.  
             my ($realKey, $subKey) = $self->SplitKey($key);  
             $data{'HasValueFor(from-link)'} = $realKey;  
             $data{'HasValueFor(subkey)'} = $subKey;  
         } elsif (substr($key, -1, 1) eq '%') {  
             $data{'HasValueFor(from-link)'} = $key;  
         } else {  
             $data{'HasValueFor(from-link)'} = $key;  
             $data{'HasValueFor(subkey)'} = '';  
         }  
     }  
1095      # Add the object ID to the key information.      # Add the object ID to the key information.
1096      $data{'HasValueFor(to-link)'} = $objectID;          $data{'to-link'} = $objectID;
1097      # The first value represents a problem, because we can search it using SQL, but not      # The first value represents a problem, because we can search it using SQL, but not
1098      # in the normal way. If the user specifies a generic search or exact match for      # in the normal way. If the user specifies a generic search or exact match for
1099      # every alternative value (remember, the values may be specified as a list),      # every alternative value (remember, the values may be specified as a list),
1100      # then we can create SQL filtering for it. If any of the values are specified      # then we can create SQL filtering for it. If any of the values are specified
1101      # as a regular expression, however, that's a problem, because we need to read          # as a regular expression, however, that's more complicated, because
1102      # every value to verify a match.          # we need to read every value to verify a match.
1103      if (@values > 0) {      if (@values > 0) {
1104          # Get the first value and put its alternatives in an array.          # Get the first value and put its alternatives in an array.
1105          my $valueParm = $values[0];          my $valueParm = $values[0];
# Line 1381  Line 1130 
1130          }          }
1131          # If everything works, add the value data to the filtering hash.          # If everything works, add the value data to the filtering hash.
1132          if ($okValues) {          if ($okValues) {
1133              $data{'HasValueFor(value)'} = \@valuePatterns;                  $data{value} = \@valuePatterns;
1134                }
1135          }          }
1136            # Now comes the really tricky part, which is key handling. The key is
1137            # actually split in two parts: the real key and a sub-key. The real key
1138            # determines which value table contains the relevant values. The information
1139            # we need is kept in here.
1140            my %tables = map { $_ => [] } $self->_GetAllTables();
1141            # See if we have any key filtering to worry about.
1142            if ($key) {
1143                # Here we have either a single key or a list. We convert both cases to a list.
1144                my $keyList = (ref $key ne 'ARRAY' ? [$key] : $key);
1145                # Get easy access to the key/table hash.
1146                my $keyTableHash = $self->_KeyTable();
1147                # Loop through the keys, discovering tables.
1148                for my $keyChoice (@$keyList) {
1149                    # Now we have to start thinking about the real key and the subkeys.
1150                    my ($realKey, $subKey) = $self->_SplitKeyPattern($keyChoice);
1151                    # Find the matches for the real key in the key hash. For each of
1152                    # these, we memorize the table name in the hash below.
1153                    my %tableNames = ();
1154                    for my $keyInTable (keys %{$keyTableHash}) {
1155                        if ($self->_CheckSQLPattern($realKey, $keyInTable)) {
1156                            $tableNames{$keyTableHash->{$key}} = 1;
1157                        }
1158                    }
1159                    # If the key is generic, or didn't match anything, add
1160                    # the default table to the mix.
1161                    if (keys %tableNames == 0 || $keyChoice =~ /%/) {
1162                        $tableNames{$self->{defaultRel}} = 1;
1163                    }
1164                    # Now we add this key combination to the key list for each relevant table.
1165                    for my $tableName (keys %tableNames) {
1166                        push @{$tables{$tableName}}, [$realKey, $subKey];
1167      }      }
1168                }
1169            }
1170            # Now we loop through the tables of interest, performing queries.
1171            # Loop through the tables.
1172            for my $table (keys %tables) {
1173                # Get the key pairs for this table.
1174                my $pairs = $tables{$table};
1175                # Does this table have data? It does if there is no key specified or
1176                # it has at least one key pair.
1177                my $pairCount = scalar @{$pairs};
1178                Trace("Pair count for table $table is $pairCount.") if T(3);
1179                if ($pairCount || ! $key) {
1180      # Create some lists to contain the filter fragments and parameter values.      # Create some lists to contain the filter fragments and parameter values.
1181      my @filter = ();      my @filter = ();
1182      my @parms = ();      my @parms = ();
1183      # 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
1184      # parameter list and generates filters for each. The %data hash that we built above      # parameter list and generates filters for each. The %data hash that we built above
1185      # contains all the necessary information to do this.                  # contains most of the necessary information to do this. When we're done, we'll
1186                    # paste on stuff for the key pairs.
1187      for my $field (keys %data) {      for my $field (keys %data) {
1188          # Accumulate filter information for this field. We will OR together all the          # Accumulate filter information for this field. We will OR together all the
1189          # elements accumulated to create the final result.          # elements accumulated to create the final result.
1190          my @fieldFilter = ();          my @fieldFilter = ();
1191          # Get the specified data from the caller.                      # Get the specified filter for this field.
1192          my $fieldPattern = $data{$field};          my $fieldPattern = $data{$field};
1193          # Only proceed if the pattern is one that won't match everything.          # Only proceed if the pattern is one that won't match everything.
1194          if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {          if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {
# Line 1411  Line 1205 
1205              if (@patterns) {              if (@patterns) {
1206                  # Loop through the individual patterns.                  # Loop through the individual patterns.
1207                  for my $pattern (@patterns) {                  for my $pattern (@patterns) {
1208                      # Check for a generic request.                                  my ($clause, $value) = _WherePart($table, $field, $pattern);
1209                      if (substr($pattern, -1, 1) ne '%') {                                  push @fieldFilter, $clause;
1210                          # Here we have a normal request.                                  push @parms, $value;
                         push @fieldFilter, "$field = ?";  
                         push @parms, $pattern;  
                     } else {  
                         # Here we have a generic request, so we will use the LIKE operator to  
                         # filter the field to this value pattern.  
                         push @fieldFilter, "$field LIKE ?";  
                         # We must convert the pattern value to an SQL match pattern. First  
                         # we get a copy of it.  
                         my $actualPattern = $pattern;  
                         # Now we escape the underscores. Underscores are an SQL wild card  
                         # character, but they are used frequently in key names and object IDs.  
                         $actualPattern =~ s/_/\\_/g;  
                         # Add the escaped pattern to the bound parameter list.  
                         push @parms, $actualPattern;  
                     }  
1211                  }                  }
1212                  # Form the filter for this field.                  # Form the filter for this field.
1213                  my $fieldFilterString = join(" OR ", @fieldFilter);                  my $fieldFilterString = join(" OR ", @fieldFilter);
# Line 1436  Line 1215 
1215              }              }
1216          }          }
1217      }      }
1218      # Now @filter contains one or more filter strings and @parms contains the parameter                  # The final filter is for the key pairs. Only proceed if we have some.
1219      # values to bind to them.                  if ($pairCount) {
1220                        # We'll accumulate pair filter clauses in here.
1221                        my @pairFilters = ();
1222                        # Loop through the key pairs.
1223                        for my $pair (@$pairs) {
1224                            my ($realKey, $subKey) = @{$pair};
1225                            my ($realClause, $realValue) = _WherePart($table, 'from-link', $realKey);
1226                            if (! $subKey) {
1227                                # Here the subkey is wild, so only the real key matters.
1228                                push @pairFilters, $realClause;
1229                                push @parms, $realValue;
1230                            } else {
1231                                # Here we have to select on both keys.
1232                                my ($subClause, $subValue) = _WherePart($table, 'subkey', $subKey);
1233                                push @pairFilters, "($realClause AND $subClause)";
1234                                push @parms, $realValue, $subValue;
1235                            }
1236                        }
1237                        # Join the pair filters together to make a giant key filter.
1238                        my $pairFilter = "(" . join(" OR ", @pairFilters) . ")";
1239                        push @filter, $pairFilter;
1240                    }
1241                    # At this point, @filter contains one or more filter strings and @parms
1242                    # contains the parameter values to bind to them.
1243      my $actualFilter = join(" AND ", @filter);      my $actualFilter = join(" AND ", @filter);
1244      # Now we're ready to make our query.      # Now we're ready to make our query.
1245      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);                  my $query = $self->Get([$table], $actualFilter, \@parms);
1246      # Format the results.      # Format the results.
1247      my @retVal = $self->_QueryResults($query, @values);                  push @retVal, $self->_QueryResults($query, $table, @values);
1248      # Return the rows found.              }
1249            }
1250        }
1251        # The above loop ran the query for each necessary value table and merged the
1252        # results into @retVal. Now we return the rows found.
1253      return @retVal;      return @retVal;
1254  }  }
1255    
1256  =head3 AddAttribute  =head3 AddAttribute
1257    
1258  C<< $attrDB->AddAttribute($objectID, $key, @values); >>      $attrDB->AddAttribute($objectID, $key, @values);
1259    
1260  Add an attribute key/value pair to an object. This method cannot add a new key, merely  Add an attribute key/value pair to an object. This method cannot add a new key, merely
1261  add a value to an existing key. Use L</StoreAttributeKey> to create a new key.  add a value to an existing key. Use L</StoreAttributeKey> to create a new key.
# Line 1490  Line 1296 
1296          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1297          # Split up the key.          # Split up the key.
1298          my ($realKey, $subKey) = $self->SplitKey($key);          my ($realKey, $subKey) = $self->SplitKey($key);
1299            # Find the table containing the key.
1300            my $table = $self->_KeyTable($realKey);
1301          # Connect the object to the key.          # Connect the object to the key.
1302          $self->InsertObject('HasValueFor', { 'from-link' => $realKey,          $self->InsertObject($table, { 'from-link' => $realKey,
1303                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1304                                               'subkey'    => $subKey,                                               'subkey'    => $subKey,
1305                                               'value'     => $valueString,                                               'value'     => $valueString,
# Line 1503  Line 1311 
1311    
1312  =head3 DeleteAttribute  =head3 DeleteAttribute
1313    
1314  C<< $attrDB->DeleteAttribute($objectID, $key, @values); >>      $attrDB->DeleteAttribute($objectID, $key, @values);
1315    
1316  Delete the specified attribute key/value combination from the database.  Delete the specified attribute key/value combination from the database.
1317    
# Line 1537  Line 1345 
1345      } else {      } else {
1346          # Split the key into the real key and the subkey.          # Split the key into the real key and the subkey.
1347          my ($realKey, $subKey) = $self->SplitKey($key);          my ($realKey, $subKey) = $self->SplitKey($key);
1348            # Find the table containing the key's values.
1349            my $table = $self->_KeyTable($realKey);
1350          if ($subKey eq '' && scalar(@values) == 0) {          if ($subKey eq '' && scalar(@values) == 0) {
1351              # Here we erase the entire key for this object.              # Here we erase the entire key for this object.
1352              $self->DeleteRow('HasValueFor', $key, $objectID);              $self->DeleteRow('HasValueFor', $key, $objectID);
# Line 1553  Line 1363 
1363    
1364  =head3 DeleteMatchingAttributes  =head3 DeleteMatchingAttributes
1365    
1366  C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>      my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values);
1367    
1368  Delete all attributes that match the specified criteria. This is equivalent to  Delete all attributes that match the specified criteria. This is equivalent to
1369  calling L</GetAttributes> and then invoking L</DeleteAttribute> for each  calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
# Line 1613  Line 1423 
1423    
1424  =head3 ChangeAttribute  =head3 ChangeAttribute
1425    
1426  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>      $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues);
1427    
1428  Change the value of an attribute key/value pair for an object.  Change the value of an attribute key/value pair for an object.
1429    
# Line 1665  Line 1475 
1475    
1476  =head3 EraseAttribute  =head3 EraseAttribute
1477    
1478  C<< $attrDB->EraseAttribute($key); >>      $attrDB->EraseAttribute($key);
1479    
1480  Erase all values for the specified attribute key. This does not remove the  Erase all values for the specified attribute key. This does not remove the
1481  key from the database; it merely removes all the values.  key from the database; it merely removes all the values.
# Line 1684  Line 1494 
1494  sub EraseAttribute {  sub EraseAttribute {
1495      # Get the parameters.      # Get the parameters.
1496      my ($self, $key) = @_;      my ($self, $key) = @_;
1497      # Delete everything connected to the key.      # Find the table containing the key.
1498        my $table = $self->_KeyTable($key);
1499        # Is it the default table?
1500        if ($table eq $self->{defaultRel}) {
1501            # Yes, so the key is mixed in with other keys.
1502            # Delete everything connected to it.
1503      $self->Disconnect('HasValueFor', 'AttributeKey', $key);      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1504        } else {
1505            # No. Drop and re-create the table.
1506            $self->TruncateTable($table);
1507        }
1508      # Log the operation.      # Log the operation.
1509      $self->LogOperation("Erase Data", $key);      $self->LogOperation("Erase Data", $key);
1510      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
# Line 1694  Line 1513 
1513    
1514  =head3 GetAttributeKeys  =head3 GetAttributeKeys
1515    
1516  C<< my @keyList = $attrDB->GetAttributeKeys($groupName); >>      my @keyList = $attrDB->GetAttributeKeys($groupName);
1517    
1518  Return a list of the attribute keys for a particular group.  Return a list of the attribute keys for a particular group.
1519    
# Line 1722  Line 1541 
1541      return sort @groups;      return sort @groups;
1542  }  }
1543    
1544    =head3 QueryAttributes
1545    
1546        my @attributeData = $ca->QueryAttributes($filter, $filterParms);
1547    
1548    Return the attribute data based on an SQL filter clause. In the filter clause,
1549    the name C<$object> should be used for the object ID, C<$key> should be used for
1550    the key name, C<$subkey> for the subkey value, and C<$value> for the value field.
1551    
1552    =over 4
1553    
1554    =item filter
1555    
1556    Filter clause in the standard ERDB format, except that the field names are C<$object> for
1557    the object ID field, C<$key> for the key name field, C<$subkey> for the subkey field,
1558    and C<$value> for the value field. This abstraction enables us to hide the details of
1559    the database construction from the user.
1560    
1561    =item filterParms
1562    
1563    Parameters for the filter clause.
1564    
1565    =item RETURN
1566    
1567    Returns a list of tuples. Each tuple consists of an object ID, a key (with optional subkey), and
1568    one or more attribute values.
1569    
1570    =back
1571    
1572    =cut
1573    
1574    # This hash is used to drive the substitution process.
1575    my %AttributeParms = (object => 'to-link',
1576                          key    => 'from-link',
1577                          subkey => 'subkey',
1578                          value  => 'value');
1579    
1580    sub QueryAttributes {
1581        # Get the parameters.
1582        my ($self, $filter, $filterParms) = @_;
1583        # Declare the return variable.
1584        my @retVal = ();
1585        # Make sue we have filter parameters.
1586        my $realParms = (defined($filterParms) ? $filterParms : []);
1587        # Loop through all the value tables.
1588        for my $table ($self->_GetAllTables()) {
1589            # Create the query for this table by converting the filter.
1590            my $realFilter = $filter;
1591            for my $name (keys %AttributeParms) {
1592                $realFilter =~ s/\$$name/$table($AttributeParms{$name})/g;
1593            }
1594            my $query = $self->Get([$table], $realFilter, $realParms);
1595            # Loop through the results, forming the output attribute tuples.
1596            while (my $result = $query->Fetch()) {
1597                # Get the four values from this query result row.
1598                my ($objectID, $key, $subkey, $value) = $result->Values(["$table($AttributeParms{object})",
1599                                                                        "$table($AttributeParms{key})",
1600                                                                        "$table($AttributeParms{subkey})",
1601                                                                        "$table($AttributeParms{value})"]);
1602                # Combine the key and the subkey.
1603                my $realKey = ($subkey ? $key . $self->{splitter} . $subkey : $key);
1604                # Split the value.
1605                my @values = split $self->{splitter}, $value;
1606                # Output the result.
1607                push @retVal, [$objectID, $realKey, @values];
1608            }
1609        }
1610        # Return the result.
1611        return @retVal;
1612    }
1613    
1614  =head2 Key and ID Manipulation Methods  =head2 Key and ID Manipulation Methods
1615    
1616  =head3 ParseID  =head3 ParseID
1617    
1618  C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>      my ($type, $id) = CustomAttributes::ParseID($idValue);
1619    
1620  Determine the type and object ID corresponding to an ID value from the attribute database.  Determine the type and object ID corresponding to an ID value from the attribute database.
1621  Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);  Most ID values consist of a type name and an ID, separated by a colon (e.g. C<Family:aclame|cluster10>);
# Line 1765  Line 1654 
1654      if ($idValue =~ /^([A-Za-z]+):(.+)/) {      if ($idValue =~ /^([A-Za-z]+):(.+)/) {
1655          # Here we have a typed ID.          # Here we have a typed ID.
1656          ($type, $id) = ($1, $2);          ($type, $id) = ($1, $2);
1657            # Fix the case sensitivity on PDB IDs.
1658            if ($type eq 'PDB') { $id = lc $id; }
1659      } elsif ($idValue =~ /fig\|/) {      } elsif ($idValue =~ /fig\|/) {
1660          # Here we have a feature ID.          # Here we have a feature ID.
1661          ($type, $id) = (Feature => $idValue);          ($type, $id) = (Feature => $idValue);
# Line 1781  Line 1672 
1672    
1673  =head3 FormID  =head3 FormID
1674    
1675  C<< my $idValue = CustomAttributes::FormID($type, $id); >>      my $idValue = CustomAttributes::FormID($type, $id);
1676    
1677  Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,  Convert an object type and ID pair into an object ID string for the attribute system. Subsystems,
1678  genomes, and features are stored in the database without type information, but all other object IDs  genomes, and features are stored in the database without type information, but all other object IDs
# Line 1822  Line 1713 
1713    
1714  =head3 GetTargetObject  =head3 GetTargetObject
1715    
1716  C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>      my $object = CustomAttributes::GetTargetObject($erdb, $idValue);
1717    
1718  Return the database object corresponding to the specified attribute object ID. The  Return the database object corresponding to the specified attribute object ID. The
1719  object type associated with the ID value must correspond to an entity name in the  object type associated with the ID value must correspond to an entity name in the
# Line 1840  Line 1731 
1731    
1732  =item RETURN  =item RETURN
1733    
1734  Returns a B<DBObject> for the attribute value's target object.  Returns a B<ERDBObject> for the attribute value's target object.
1735    
1736  =back  =back
1737    
# Line 1861  Line 1752 
1752    
1753  =head3 SplitKey  =head3 SplitKey
1754    
1755  C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>      my ($realKey, $subKey) = $ca->SplitKey($key);
1756    
1757  Split an external key (that is, one passed in by a caller) into the real key and the sub key.  Split an external key (that is, one passed in by a caller) into the real key and the sub key.
1758  The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,  The real and sub keys are separated by a splitter value (usually C<::>). If there is no splitter,
# Line 1895  Line 1786 
1786      return ($realKey, $subKey);      return ($realKey, $subKey);
1787  }  }
1788    
1789    
1790  =head3 JoinKey  =head3 JoinKey
1791    
1792  C<< my $key = $ca->JoinKey($realKey, $subKey); >>      my $key = $ca->JoinKey($realKey, $subKey);
1793    
1794  Join a real key and a subkey together to make an external key. The external key is the attribute key  Join a real key and a subkey together to make an external key. The external key is the attribute key
1795  used by the caller. The real key and the subkey are how the keys are represented in the database. The  used by the caller. The real key and the subkey are how the keys are represented in the database. The
# Line 1939  Line 1831 
1831      return $retVal;      return $retVal;
1832  }  }
1833    
1834    
1835    =head3 AttributeTable
1836    
1837        my $tableHtml = CustomAttributes::AttributeTable($cgi, @attrList);
1838    
1839    Format the attribute data into an HTML table.
1840    
1841    =over 4
1842    
1843    =item cgi
1844    
1845    CGI query object used to generate the HTML
1846    
1847    =item attrList
1848    
1849    List of attribute results, in the format returned by the L</GetAttributes> or
1850    L</QueryAttributes> methods.
1851    
1852    =item RETURN
1853    
1854    Returns an HTML table displaying the attribute keys and values.
1855    
1856    =back
1857    
1858    =cut
1859    
1860    sub AttributeTable {
1861        # Get the parameters.
1862        my ($cgi, @attrList) = @_;
1863        # Accumulate the table rows.
1864        my @html = ();
1865        for my $attrData (@attrList) {
1866            # Format the object ID and key.
1867            my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];
1868            # Now we format the values. These remain unchanged unless one of them is a URL.
1869            my $lastValue = scalar(@{$attrData}) - 1;
1870            push @columns, map { $_ =~ /^http:/ ? $cgi->a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];
1871            # Assemble the values into a table row.
1872            push @html, $cgi->Tr($cgi->td(\@columns));
1873        }
1874        # Format the table in the return variable.
1875        my $retVal = $cgi->table({ border => 2 }, $cgi->Tr($cgi->th(['Object', 'Key', 'Values'])), @html);
1876        # Return it.
1877        return $retVal;
1878    }
1879    
1880    
1881    =head2 Internal Utility Methods
1882    
1883    =head3 _KeyTable
1884    
1885        my $tableName = $ca->_KeyTable($keyName);
1886    
1887    Return the name of the table that contains the attribute values for the
1888    specified key.
1889    
1890    Most attribute values are stored in the default table (usually C<HasValueFor>).
1891    Some, however, are placed in private tables by themselves for performance reasons.
1892    
1893    =over 4
1894    
1895    =item keyName (optional)
1896    
1897    Name of the attribute key whose table name is desired. If not specified, the
1898    entire key/table hash is returned.
1899    
1900    =item RETURN
1901    
1902    Returns the name of the table containing the specified attribute key's values,
1903    or a reference to a hash that maps key names to table names.
1904    
1905    =back
1906    
1907    =cut
1908    
1909    sub _KeyTable {
1910        # Get the parameters.
1911        my ($self, $keyName) = @_;
1912        # Declare the return variable.
1913        my $retVal;
1914        # Insure the key table hash is present.
1915        if (! exists $self->{keyTables}) {
1916            $self->{keyTables} = { map { $_->[0] => $_->[1] } $self->GetAll(['AttributeKey'],
1917                                                    "AttributeKey(relationship-name) <> ?",
1918                                                    [$self->{defaultRel}],
1919                                                    ['AttributeKey(id)', 'AttributeKey(relationship-name)']) };
1920        }
1921        # Get the key hash.
1922        my $keyHash = $self->{keyTables};
1923        # Does the user want a specific table or the whole thing?
1924        if ($keyName) {
1925            # Here we want a specific table. Is this key in the hash?
1926            if (exists $keyHash->{$keyName}) {
1927                # It's there, so return the specified table.
1928                $retVal = $keyHash->{$keyName};
1929            } else {
1930                # No, return the default table name.
1931                $retVal = $self->{defaultRel};
1932            }
1933        } else {
1934            # Here we want the whole hash.
1935            $retVal = $keyHash;
1936        }
1937        # Return the result.
1938        return $retVal;
1939    }
1940    
1941    
1942    =head3 _QueryResults
1943    
1944        my @attributeList = $attrDB->_QueryResults($query, $table, @values);
1945    
1946    Match the results of a query against value criteria and return
1947    the results. This is an internal method that splits the values coming back
1948    and matches the sections against the specified section patterns. It serves
1949    as the back end to L</GetAttributes> and L</FindAttributes>.
1950    
1951    =over 4
1952    
1953    =item query
1954    
1955    A query object that will return the desired records.
1956    
1957    =item table
1958    
1959    Name of the value table for the query.
1960    
1961    =item values
1962    
1963    List of the desired attribute values, section by section. If C<undef>
1964    or an empty string is specified, all values in that section will match. A
1965    generic match can be requested by placing a percent sign (C<%>) at the end.
1966    In that case, all values that match up to and not including the percent sign
1967    will match. You may also specify a regular expression enclosed
1968    in slashes. All values that match the regular expression will be returned. For
1969    performance reasons, only values have this extra capability.
1970    
1971    =item RETURN
1972    
1973    Returns a list of tuples. The first element in the tuple is an object ID, the
1974    second is an attribute key, and the remaining elements are the sections of
1975    the attribute value. All of the tuples will match the criteria set forth in
1976    the parameter list.
1977    
1978    =back
1979    
1980    =cut
1981    
1982    sub _QueryResults {
1983        # Get the parameters.
1984        my ($self, $query, $table, @values) = @_;
1985        # Declare the return value.
1986        my @retVal = ();
1987        # We use this hash to check for duplicates.
1988        my %dupHash = ();
1989        # Get the number of value sections we have to match.
1990        my $sectionCount = scalar(@values);
1991        # Loop through the assignments found.
1992        while (my $row = $query->Fetch()) {
1993            # Get the current row's data.
1994            my ($id, $realKey, $subKey, $valueString) = $row->Values(["$table(to-link)",
1995                                                                      "$table(from-link)",
1996                                                                      "$table(subkey)",
1997                                                                      "$table(value)"
1998                                                                    ]);
1999            # Form the key from the real key and the sub key.
2000            my $key = $self->JoinKey($realKey, $subKey);
2001            # Break the value into sections.
2002            my @sections = split($self->{splitter}, $valueString);
2003            # Match each section against the incoming values. We'll assume we're
2004            # okay unless we learn otherwise.
2005            my $matching = 1;
2006            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
2007                # We need to check to see if this section is generic.
2008                my $value = $values[$i];
2009                Trace("Current value pattern is \"$value\".") if T(4);
2010                if ($value =~ m#^/(.+)/[a-z]*$#) {
2011                    Trace("Regular expression detected.") if T(4);
2012                    # Here we have a regular expression match.
2013                    my $section = $sections[$i];
2014                    $matching = eval("\$section =~ $value");
2015                } else {
2016                    # Here we have a normal match.
2017                    Trace("SQL match used.") if T(4);
2018                    $matching = _CheckSQLPattern($values[$i], $sections[$i]);
2019                }
2020            }
2021            # If we match, consider writing this row to the return list.
2022            if ($matching) {
2023                # Check for a duplicate.
2024                my $wholeThing = join($self->{splitter}, $id, $key, $valueString);
2025                if (! $dupHash{$wholeThing}) {
2026                    # It's okay, we're not a duplicate. Insure we don't duplicate this result.
2027                    $dupHash{$wholeThing} = 1;
2028                    push @retVal, [$id, $key, @sections];
2029                }
2030            }
2031        }
2032        # Return the rows found.
2033        return @retVal;
2034    }
2035    
2036    
2037    =head3 _LoadAttributeTable
2038    
2039        $attr->_LoadAttributeTable($tableName, $fileName, $stats, $mode);
2040    
2041    Load a file's data into an attribute table. This is an internal method
2042    provided for the convenience of L</LoadAttributesFrom>. It loads the
2043    specified file into the specified table and updates the statistics
2044    object.
2045    
2046    =over 4
2047    
2048    =item tableName
2049    
2050    Name of the table being loaded. This is usually C<HasValueFor>, but may
2051    be a different table for some specific attribute keys.
2052    
2053    =item fileName
2054    
2055    Name of the file containing a chunk of attribute data to load.
2056    
2057    =item stats
2058    
2059    Statistics object into which counts and times should be placed.
2060    
2061    =item mode
2062    
2063    Load mode for the file, usually C<low_priority>, C<concurrent>, or
2064    an empty string. The mode is used by some applications to control access
2065    to the table while it's being loaded. The default (empty string) is to lock the
2066    table until all the data's in place.
2067    
2068    =back
2069    
2070    =cut
2071    
2072    sub _LoadAttributeTable {
2073        # Get the parameters.
2074        my ($self, $tableName, $fileName, $stats, $mode) = @_;
2075        # Load the table from the file. Note that we don't do an analyze.
2076        # The analyze is done only after everything is complete.
2077        my $startTime = time();
2078        Trace("Loading attributes from $fileName: " . (-s $fileName) .
2079              " characters.") if T(3);
2080        my $loadStats = $self->LoadTable($fileName, $tableName,
2081                                         mode => $mode, partial => 1);
2082        # Record the load time.
2083        $stats->Add(insertTime => time() - $startTime);
2084        # Roll up the other statistics.
2085        $stats->Accumulate($loadStats);
2086    }
2087    
2088    
2089    =head3 _GetAllTables
2090    
2091        my @tables = $ca->_GetAllTables();
2092    
2093    Return a list of the names of all the tables used to store attribute
2094    values.
2095    
2096    =cut
2097    
2098    sub _GetAllTables {
2099        # Get the parameters.
2100        my ($self) = @_;
2101        # Start with the default table.
2102        my @retVal = $self->{defaultRel};
2103        # Add the tables named in the key hash. These tables are automatically
2104        # NOT the default, and each can only occur once, because alternate tables
2105        # are allocated on a per-key basis.
2106        my $keyHash = $self->_KeyTable();
2107        push @retVal, values %$keyHash;
2108        # Return the result.
2109        return @retVal;
2110    }
2111    
2112    
2113    =head3 _SplitKeyPattern
2114    
2115        my ($realKey, $subKey) = $ca->_SplitKeyPattern($keyChoice);
2116    
2117    Split a key pattern into the main part (the I<real key>) and a sub-part
2118    (the I<sub key>). This method differs from L</SplitKey> in that it treats
2119    the key as an SQL pattern instead of a raw string. Also, if there is no
2120    incoming sub-part, the sub-key will be undefined instead of an empty
2121    string.
2122    
2123    =over 4
2124    
2125    =item keyChoice
2126    
2127    SQL key pattern to be examined. This can either be a literal, an SQL pattern,
2128    a literal with an internal splitter code (usually C<::>) or an SQL pattern with
2129    an internal splitter. Note that the only SQL pattern we support is a percent
2130    sign (C<%>) at the end. This is the way we've declared things in the documentation,
2131    so users who try anything else will have problems.
2132    
2133    =item RETURN
2134    
2135    Returns a two-element list. The first element is the SQL pattern for the
2136    real key and the second is the SQL pattern for the sub-key. If the value
2137    for either one does not matter (e.g., the user wants a real key value of
2138    C<iedb> and doesn't care about the sub-key value), it will be undefined.
2139    
2140    =back
2141    
2142    =cut
2143    
2144    sub _SplitKeyPattern {
2145        # Get the parameters.
2146        my ($self, $keyChoice) = @_;
2147        # Declare the return variables.
2148        my ($realKey, $subKey);
2149        # Look for a splitter in the input.
2150        if ($keyChoice =~ /^(.*?)$self->{splitter}(.*)/) {
2151            # We found one. This means we can treat both sides of the
2152            # splitter as known patterns.
2153            ($realKey, $subKey) = ($1, $2);
2154        } elsif ($keyChoice =~ /%$/) {
2155            # Here we have a generic pattern for the whole key. The pattern
2156            # is treated as the correct pattern for the real key, but the
2157            # sub-key is considered to be wild.
2158            $realKey = $keyChoice;
2159        } else {
2160            # Here we have a literal pattern for the whole key. The pattern
2161            # is treated as the correct pattern for the real key, and the
2162            # sub-key is required to be blank.
2163            $realKey = $keyChoice;
2164            $subKey = '';
2165        }
2166        # Return the results.
2167        return ($realKey, $subKey);
2168    }
2169    
2170    
2171    =head3 _WherePart
2172    
2173        my ($sqlClause, $escapedValue) = _WherePart($tableName, $fieldName, $sqlPattern);
2174    
2175    Return the SQL clause and value for checking a field against the
2176    specified SQL pattern value. If the pattern is generic (ends in a C<%>),
2177    then a C<LIKE> expression is returned. Otherwise, an equality expression
2178    is returned. We take in information describing the field being checked,
2179    and the pattern we're checking against it. The output is a WHERE clause
2180    fragment for the comparison and a value to be used as a bound parameter
2181    value for the clause.
2182    
2183    =over 4
2184    
2185    =item tableName
2186    
2187    Name of the table containing the field we want checked by the clause.
2188    
2189    =item fieldName
2190    
2191    Name of the field to check in that table.
2192    
2193    =item sqlPattern
2194    
2195    Pattern to be compared against the field. If the last character is a percent sign
2196    (C<%>), it will be treated as a generic SQL pattern; otherwise, it will be treated
2197    as a literal.
2198    
2199    =item RETURN
2200    
2201    Returns a two-element list. The first element will be an SQL comparison expression
2202    and the second will be the value to be used as a bound parameter for the expression
2203    in order to
2204    
2205    =back
2206    
2207    =cut
2208    
2209    sub _WherePart {
2210        # Get the parameters.
2211        my ($tableName, $fieldName, $sqlPattern) = @_;
2212        # Declare the return variables.
2213        my ($sqlClause, $escapedValue);
2214        # Copy the pattern into the return area.
2215        $escapedValue = $sqlPattern;
2216        # Check the pattern. Is it generic or exact?
2217        if ($sqlPattern =~ /(.+)%$/) {
2218            # Yes, it is. We need a LIKE clause and we must escape the underscores
2219            # and percents in the pattern (except for the last one, of course).
2220            $escapedValue = $1;
2221            $escapedValue =~ s/(%|_)/\\$1/g;
2222            $escapedValue .= "%";
2223            $sqlClause = "$tableName($fieldName) LIKE ?";
2224        } else {
2225            # No, it isn't. We use an equality clause.
2226            $sqlClause = "$tableName($fieldName) = ?";
2227        }
2228        # Return the results.
2229        return ($sqlClause, $escapedValue);
2230    }
2231    
2232    
2233    =head3 _CheckSQLPattern
2234    
2235        my $flag = _CheckSQLPattern($pattern, $value);
2236    
2237    Return TRUE if the specified SQL pattern matches the specified value,
2238    else FALSE. The pattern is not a true full-blown SQL LIKE pattern: the
2239    only wild-carding allowed is a percent sign (C<%>) at the end.
2240    
2241    =over 4
2242    
2243    =item pattern
2244    
2245    SQL pattern to match against a value.
2246    
2247    =item value
2248    
2249    Value to match against an SQL pattern.
2250    
2251    =item RETURN
2252    
2253    Returns TRUE if the pattern matches the value, else FALSE.
2254    
2255    =back
2256    
2257    =cut
2258    
2259    sub _CheckSQLPattern {
2260        # Get the parameters.
2261        my ($pattern, $value) = @_;
2262        # Declare the return variable.
2263        my $retVal;
2264        # Check for a generic pattern.
2265        if ($pattern =~ /(.*)%$/) {
2266            # Here we have one. Do a substring match.
2267            $retVal = (substr($value, 0, length $1) eq $1);
2268        } else {
2269            # Here it's an exact match.
2270            $retVal = ($pattern eq $value);
2271        }
2272        # Return the result.
2273        return $retVal;
2274    }
2275    
2276  1;  1;

Legend:
Removed from v.1.21  
changed lines
  Added in v.1.38

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3