[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.30, Fri Oct 5 01:40:58 2007 UTC revision 1.40, Tue Dec 30 08:58:14 2008 UTC
# Line 2  Line 2 
2    
3  package CustomAttributes;  package CustomAttributes;
4    
     require Exporter;  
     use ERDB;  
     @ISA = qw(ERDB);  
5      use strict;      use strict;
6      use Tracer;      use Tracer;
     use ERDBLoad;  
7      use Stats;      use Stats;
8      use Time::HiRes qw(time);      use Time::HiRes qw(time);
9        use FIGRules;
10        use base qw(ERDB);
11    
12  =head1 Custom SEED Attribute Manager  =head1 Custom SEED Attribute Manager
13    
# Line 125  Line 123 
123  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
124  moved, this file must go with it.  moved, this file must go with it.
125    
126    =item attr_default_table
127    
128    Name of the default relationship for attribute values. If not present,
129    C<HasValueFor> is used.
130    
131  =back  =back
132    
133  =head2 Public Methods  =head2 Public Methods
134    
135  =head3 new  =head3 new
136    
137  C<< my $attrDB = CustomAttributes->new(%options); >>      my $attrDB = CustomAttributes->new(%options);
138    
139  Construct a new CustomAttributes object. The following options are  Construct a new CustomAttributes object. The following options are
140  supported.  supported.
# Line 148  Line 151 
151    
152  Name of the current user. This will appear in the attribute log.  Name of the current user. This will appear in the attribute log.
153    
154    =item dbd
155    
156    Filename for the DBD. If unspecified, the default DBD is used.
157    
158  =back  =back
159    
160  =cut  =cut
# Line 155  Line 162 
162  sub new {  sub new {
163      # Get the parameters.      # Get the parameters.
164      my ($class, %options) = @_;      my ($class, %options) = @_;
165        # Get the name ofthe default table.
166      # Connect to the database.      # Connect to the database.
167      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,      my $dbh = DBKernel->new($FIG_Config::attrDbms, $FIG_Config::attrDbName,
168                              $FIG_Config::attrUser, $FIG_Config::attrPass,                              $FIG_Config::attrUser, $FIG_Config::attrPass,
169                              $FIG_Config::attrPort, $FIG_Config::attrHost,                              $FIG_Config::attrPort, $FIG_Config::attrHost,
170                              $FIG_Config::attrSock);                              $FIG_Config::attrSock);
171      # Create the ERDB object.      # Create the ERDB object.
172      my $xmlFileName = $FIG_Config::attrDBD;      my $xmlFileName = ($options{dbd} ? $options{dbd} : $FIG_Config::attrDBD);
173      my $retVal = ERDB::new($class, $dbh, $xmlFileName);      my $retVal = ERDB::new($class, $dbh, $xmlFileName);
174      # Store the splitter value.      # Store the splitter value.
175      $retVal->{splitter} = $options{splitter} || '::';      $retVal->{splitter} = $options{splitter} || '::';
176      # Store the user name.      # Store the user name.
177      $retVal->{user} = $options{user} || '<unknown>';      $retVal->{user} = $options{user} || '<unknown>';
178      Trace("User $retVal->{user} selected for attribute object.") if T(3);      Trace("User $retVal->{user} selected for attribute object.") if T(3);
179        # Compute the default value table name. If it's not overridden, the
180        # default is HasValueFor.
181        $retVal->{defaultRel} = $FIG_Config::attr_default_table || 'HasValueFor';
182      # Return the result.      # Return the result.
183      return $retVal;      return $retVal;
184  }  }
185    
186  =head3 StoreAttributeKey  =head3 StoreAttributeKey
187    
188  C<< $attrDB->StoreAttributeKey($attributeName, $type, $notes, \@groups); >>      $attrDB->StoreAttributeKey($attributeName, $notes, \@groups, $table);
189    
190  Create or update an attribute for the database.  Create or update an attribute for the database.
191    
# Line 184  Line 195 
195    
196  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.
197    
 =item type  
   
 Data type of the attribute. This must be a valid ERDB data type name.  
   
198  =item notes  =item notes
199    
200  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 197  Line 204 
204  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.
205  This will replace any groups to which the attribute is currently attached.  This will replace any groups to which the attribute is currently attached.
206    
207    =item table
208    
209    The name of the relationship in which the attribute's values are to be stored.
210    If empty or undefined, the default relationship (usually C<HasValueFor>) will be
211    assumed.
212    
213  =back  =back
214    
215  =cut  =cut
216    
217  sub StoreAttributeKey {  sub StoreAttributeKey {
218      # Get the parameters.      # Get the parameters.
219      my ($self, $attributeName, $type, $notes, $groups) = @_;      my ($self, $attributeName, $notes, $groups, $table) = @_;
220      # Declare the return variable.      # Declare the return variable.
221      my $retVal;      my $retVal;
222      # Get the data type hash.      # Default the table name.
223      my %types = ERDB::GetDataTypes();      if (! $table) {
224            $table = $self->{defaultRel};
225        }
226      # Validate the initial input values.      # Validate the initial input values.
227      if ($attributeName =~ /$self->{splitter}/) {      if ($attributeName =~ /$self->{splitter}/) {
228          Confess("Invalid attribute name \"$attributeName\" specified.");          Confess("Invalid attribute name \"$attributeName\" specified.");
229      } elsif (! $notes || length($notes) < 25) {      } elsif (! $notes) {
230          Confess("Missing or incomplete description for $attributeName.");          Confess("Missing description for $attributeName.");
231      } elsif (! exists $types{$type}) {      } elsif (! grep { $_ eq $table } $self->GetConnectingRelationships('AttributeKey')) {
232          Confess("Invalid data type \"$type\" for $attributeName.");          Confess("Invalid relationship name \"$table\" specified as a custom attribute table.");
233      } else {      } else {
234          # 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).
235          my $action;          my $action;
# Line 224  Line 239 
239              # It does, so we do an update.              # It does, so we do an update.
240              $action = "Update Key";              $action = "Update Key";
241              $self->UpdateEntity('AttributeKey', $attributeName,              $self->UpdateEntity('AttributeKey', $attributeName,
242                                  { description => $notes, 'data-type' => $type });                                  { description => $notes,
243                                      'relationship-name' => $table});
244              # Detach the key from its current groups.              # Detach the key from its current groups.
245              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);              $self->Disconnect('IsInGroup', 'AttributeKey', $attributeName);
246          } else {          } else {
247              # It doesn't, so we do an insert.              # It doesn't, so we do an insert.
248              $action = "Insert Key";              $action = "Insert Key";
249              $self->InsertObject('AttributeKey', { id => $attributeName,              $self->InsertObject('AttributeKey', { id => $attributeName,
250                                  description => $notes, 'data-type' => $type });                                  description => $notes,
251                                    'relationship-name' => $table});
252          }          }
253          # Attach the key to the specified groups. (We presume the groups already          # Attach the key to the specified groups. (We presume the groups already
254          # exist.)          # exist.)
# Line 247  Line 264 
264    
265  =head3 DeleteAttributeKey  =head3 DeleteAttributeKey
266    
267  C<< my $stats = $attrDB->DeleteAttributeKey($attributeName); >>      my $stats = $attrDB->DeleteAttributeKey($attributeName);
268    
269  Delete an attribute from the custom attributes database.  Delete an attribute from the custom attributes database.
270    
# Line 279  Line 296 
296    
297  =head3 NewName  =head3 NewName
298    
299  C<< my $text = CustomAttributes::NewName(); >>      my $text = CustomAttributes::NewName();
300    
301  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.
302    
# Line 289  Line 306 
306      return "(new)";      return "(new)";
307  }  }
308    
 =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.  
     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, "");  
 }  
   
309  =head3 LoadAttributesFrom  =head3 LoadAttributesFrom
310    
311  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>  C<< my $stats = $attrDB->LoadAttributesFrom($fileName, %options); >>
312  s  
313  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
314  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
315  column, and attribute values in the remaining columns. The attribute values will  column, and attribute values in the remaining columns. The attribute values must
316  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
317  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
318  treated as a subkey.  treated as a subkey.
# Line 416  Line 339 
339    
340  =over 4  =over 4
341    
342    =item mode
343    
344    Loading mode. Legal values are C<low_priority> (which reduces the task priority
345    of the load) and C<concurrent> (which reduces the locking cost of the load). The
346    default is a normal load.
347    
348  =item append  =item append
349    
350  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 423  Line 352 
352    
353  =item archive  =item archive
354    
355  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.
356    If I<resume> is also specified, only the lines actually loaded will be put
357    into this file.
358    
359  =item objectType  =item objectType
360    
# Line 432  Line 363 
363  =item resume  =item resume
364    
365  If specified, key-value pairs already in the database will not be reinserted.  If specified, key-value pairs already in the database will not be reinserted.
366    Specify a number to start checking after the specified number of lines and
367    then admit everything after the first line not yet loaded. Specify C<careful>
368    to check every single line. Specify C<none> to ignore this option. The default
369    is C<none>. So, if you believe that a previous load failed somewhere after 50000
370    lines, a resume value of C<50000> would skip 50000 lines in the file, then
371    check each line after that until it finds one not already in the database. The
372    first such line found and all lines after that will be loaded. On the other
373    hand, if you have a file of 100000 records, and some have been loaded and some
374    not, you would use the word C<careful>, so that every line would be checked before
375    it is inserted. A resume of C<0> will start checking the first line of the
376    input file and then begin loading once it finds a line not in the database.
377    
378    =item chunkSize
379    
380    Number of lines to load in each burst. The default is 10,000.
381    
382  =back  =back
383    
# Line 441  Line 387 
387      # Get the parameters.      # Get the parameters.
388      my ($self, $fileName, %options) = @_;      my ($self, $fileName, %options) = @_;
389      # Declare the return variable.      # Declare the return variable.
390      my $retVal = Stats->new('keys', 'values');      my $retVal = Stats->new('keys', 'values', 'linesOut');
391      # Initialize the timers.      # Initialize the timers.
392      my ($insertTime, $eraseTime, $archiveTime, $checkTime) = (0, 0, 0, 0);      my ($eraseTime, $archiveTime, $checkTime) = (0, 0, 0);
393      # Check for append mode.      # Check for append mode.
394      my $append = ($options{append} ? 1 : 0);      my $append = ($options{append} ? 1 : 0);
395      # Check for resume mode.      # Check for resume mode.
396      my $resume = ($options{resume} ? 1 : 0);      my $resume = (defined($options{resume}) ? $options{resume} : 'none');
397      # Create a hash of key names found.      # Create a hash of key names found.
398      my %keyHash = ();      my %keyHash = ();
399        # Create a hash of table names to files. Most attributes go into the HasValueFor
400        # table, but some are put into other tables. Each table name will be mapped
401        # to a sub-hash with keys "fileName" (output file for the table) and "count"
402        # (number of lines in the file).
403        my %tableHash = ();
404        # Compute the chunk size.
405        my $chunkSize = ($options{chunkSize} ? $options{chunkSize} : 10000);
406      # 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
407      # open filehandle being passed in.      # open filehandle being passed in. This occurs when the user is submitting
408        # the load file over the web.
409      my $fh;      my $fh;
410      if (ref $fileName) {      if (ref $fileName) {
411          Trace("Using file opened by caller.") if T(3);          Trace("Using file opened by caller.") if T(3);
# Line 460  Line 414 
414          Trace("Attributes will be loaded from $fileName.") if T(3);          Trace("Attributes will be loaded from $fileName.") if T(3);
415          $fh = Open(undef, "<$fileName");          $fh = Open(undef, "<$fileName");
416      }      }
417        # Trace the mode.
418        if (T(3)) {
419            if ($options{mode}) {
420                Trace("Mode is $options{mode}.")
421            } else {
422                Trace("No mode specified.")
423            }
424        }
425      # Now check to see if we need to archive.      # Now check to see if we need to archive.
426      my $ah;      my $ah;
427      if ($options{archive}) {      if (exists $options{archive}) {
428          $ah = Open(undef, ">$options{archive}");          my $ah = Open(undef, ">$options{archive}");
429          Trace("Load file will be archived to $options{archive}.") if T(3);          Trace("Load file will be archived to $options{archive}.") if T(3);
430      }      }
431      # Insure we recover from errors.      # Insure we recover from errors.
432      eval {      eval {
433            # If we have a resume number, process it here.
434            if ($resume =~ /\d+/) {
435                Trace("Skipping $resume lines.") if T(2);
436                my $startTime = time();
437                # Skip the specified number of lines.
438                for (my $skipped = 0; ! eof($fh) && $skipped < $resume; $skipped++) {
439                    my $line = <$fh>;
440                    $retVal->Add(skipped => 1);
441                }
442                $checkTime += time() - $startTime;
443            }
444          # Loop through the file.          # Loop through the file.
445            Trace("Starting load.") if T(2);
446          while (! eof $fh) {          while (! eof $fh) {
447              # Read the current line.              # Read the current line.
448              my ($id, $key, @values) = Tracer::GetLine($fh);              my ($id, $key, @values) = Tracer::GetLine($fh);
449              $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) {  
                 my $startTime = time();  
                 Tracer::PutLine($ah, [$id, $key, @values]);  
                 $archiveTime += time() - $startTime;  
             }  
450              # Do some validation.              # Do some validation.
451              if (! $id) {              if (! $id) {
452                  # We ignore blank lines.                  # We ignore blank lines.
# Line 500  Line 464 
464                  Trace("Line $lines for key $key has no attribute values.") if T(1);                  Trace("Line $lines for key $key has no attribute values.") if T(1);
465                  $retVal->Add(skipped => 1);                  $retVal->Add(skipped => 1);
466              } else {              } else {
467                    # Check to see if we need to fix up the object ID.
468                    if ($options{objectType}) {
469                        $id = "$options{objectType}:$id";
470                    }
471                  # 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.
472                  my ($realKey, $subKey) = $self->SplitKey($key);                  my ($realKey, $subKey) = $self->SplitKey($key);
473                  # Now we need to check for a new key.                  # Now we need to check for a new key.
474                  if (! exists $keyHash{$realKey}) {                  if (! exists $keyHash{$realKey}) {
475                      if (! $self->Exists('AttributeKey', $realKey)) {                      my $keyObject = $self->GetEntity(AttributeKey => $realKey);
476                        if (! defined($keyObject)) {
477                            # Here the specified key does not exist, which is an error.
478                          my $line = $retVal->Ask('linesIn');                          my $line = $retVal->Ask('linesIn');
479                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");                          Confess("Attribute \"$realKey\" on line $line of $fileName not found in database.");
480                      } else {                      } else {
481                          # 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
482                          $keyHash{$realKey} = 1;                          # its table name in the key hash.
483                            $keyHash{$realKey} = $keyObject->PrimaryValue('AttributeKey(relationship-name)');
484                          $retVal->Add(keys => 1);                          $retVal->Add(keys => 1);
485                          # If this is NOT append mode, erase the key.                          # If this is NOT append mode, erase the key. This does not delete the key
486                            # itself; it just clears out all the values.
487                          if (! $append) {                          if (! $append) {
488                              my $startTime = time();                              my $startTime = time();
489                              $self->EraseAttribute($realKey);                              $self->EraseAttribute($realKey);
# Line 523  Line 495 
495                  }                  }
496                  # If we're in resume mode, check to see if this insert is redundant.                  # If we're in resume mode, check to see if this insert is redundant.
497                  my $ok = 1;                  my $ok = 1;
498                  if ($resume) {                  if ($resume ne 'none') {
499                      my $startTime = time();                      my $startTime = time();
500                      my $count = $self->GetAttributes($id, $key, @values);                      my $count = $self->GetAttributes($id, $key, @values);
501                      $ok = ! $count;                      if ($count) {
502                            # Here the record is found, so we skip it.
503                            $ok = 0;
504                            $retVal->Add(skipped => 1);
505                        } else {
506                            # Here the record is not found. If we're in non-careful mode, we
507                            # stop resume checking at this point.
508                            if ($resume ne 'careful') {
509                                $resume = 'none';
510                            }
511                        }
512                      $checkTime += time() - $startTime;                      $checkTime += time() - $startTime;
513                  }                  }
514                  if ($ok) {                  if ($ok) {
515                      # Everything is all set up, so add the value.                      # We're in business. First, archive this row.
516                        if (defined $ah) {
517                      my $startTime = time();                      my $startTime = time();
518                      $self->AddAttribute($id, $key, @values);                          Tracer::PutLine($ah, [$id, $key, @values]);
519                      $insertTime += time() - $startTime;                          $archiveTime += time() - $startTime;
520                      # Turn off resume mode.                      }
521                      $resume = 0;                      # We need to format the attribute data so it will work
522                        # as if it were a load file. This means we join the
523                        # values.
524                        my $valueString = join('::', @values);
525                        # Now we need to get access to the key's load file. Check for it in the
526                        # table hash.
527                        my $keyTable = $keyHash{$realKey};
528                        if (! exists $tableHash{$keyTable}) {
529                            # This is a new table, so we need to set it up. First, we get
530                            # a temporary file for it.
531                            my $tempFileName = FIGRules::GetTempFileName(sessionID => $$ . $keyTable,
532                                                                         extension => 'dtx');
533                            my $oh = Open(undef, ">$tempFileName");
534                            # Now we create its descriptor in the table hash.
535                            $tableHash{$keyTable} = {fileName => $tempFileName, handle => $oh, count => 0};
536                        }
537                        # Everything is all set up, so we put the value in the temporary file and
538                        # count it.
539                        my $tableData = $tableHash{$keyTable};
540                        my $startTime = time();
541                        Tracer::PutLine($tableData->{handle}, [$realKey, $id, $subKey, $valueString]);
542                        $archiveTime += time() - $startTime;
543                        $retVal->Add(linesOut => 1);
544                        $tableData->{count}++;
545                        # See if it's time to load a chunk.
546                        if ($tableData->{count} >= $chunkSize) {
547                            # We've filled a chunk, so it's time.
548                            close $tableData->{handle};
549                            $self->_LoadAttributeTable($keyTable, $tableData->{fileName}, $retVal);
550                            # Reset for the next chunk.
551                            $tableData->{count} = 0;
552                            $tableData->{handle} = Open(undef, ">$tableData->{fileName}");
553                        }
554                  } else {                  } else {
555                      # Here we skipped because of resume mode.                      # Here we skipped because of resume mode.
556                      $retVal->Add(resumeSkip => 1);                      $retVal->Add(resumeSkip => 1);
557                  }                  }
558                    Trace($retVal->Ask('values') . " values processed.") if $retVal->Check(values => 1000) && T(3);
                 my $progress = $retVal->Add(values => 1);  
                 Trace("$progress values loaded.") if T(3) && ($progress % 1000 == 0);  
559              }              }
560          }          }
561          $retVal->Add(eraseTime   => $eraseTime);          # Now we close the archive file. Note we undefine the handle so the error methods know
562          $retVal->Add(insertTime  => $insertTime);          # not to worry.
563          $retVal->Add(archiveTime => $archiveTime);          if (defined $ah) {
564          $retVal->Add(checkTime   => $checkTime);              close $ah;
565                undef $ah;
566            }
567            # Now we load the residual from the temporary files (if any). This time we'll do an
568            # analyze as well.
569            for my $tableName (keys %tableHash) {
570                # Get the data for this table.
571                my $tableData = $tableHash{$tableName};
572                # Close the handle. ERDB will re-open it for input later.
573                close $tableData->{handle};
574                # Check to see if there's anything left to load.
575                if ($tableData->{count} > 0) {
576                    # Yes, load the data.
577                    $self->_LoadAttributeTable($tableName, $tableData->{fileName}, $retVal);
578                }
579                # Regardless of whether additional loading was required, we need to
580                # analyze the table for performance.
581                my $startTime = time();
582                $self->Analyze($tableName);
583                $retVal->Add(analyzeTime => time() - $startTime);
584            }
585            Trace("Attribute load successful.") if T(2);
586      };      };
587      # Check for an error.      # Check for an error.
588      if ($@) {      if ($@) {
# Line 556  Line 590 
590          my $message = $@;          my $message = $@;
591          Trace("Error during attribute load: $message") if T(0);          Trace("Error during attribute load: $message") if T(0);
592          $retVal->AddMessage($message);          $retVal->AddMessage($message);
593      }          # Close the archive file if it's open. The archive file can sometimes provide
594      # Close the archive file, if any.          # clues as to what happened.
595      if (defined $ah) {      if (defined $ah) {
         Trace("Closing archive file $options{archive}.") if T(2);  
596          close $ah;          close $ah;
597      }      }
598        }
599        # Store the timers.
600        $retVal->Add(eraseTime   => $eraseTime);
601        $retVal->Add(archiveTime => $archiveTime);
602        $retVal->Add(checkTime   => $checkTime);
603      # Return the result.      # Return the result.
604      return $retVal;      return $retVal;
605  }  }
606    
607  =head3 BackupKeys  =head3 BackupKeys
608    
609  C<< my $stats = $attrDB->BackupKeys($fileName, %options); >>      my $stats = $attrDB->BackupKeys($fileName, %options);
610    
611  Backup the attribute key information from the attribute database.  Backup the attribute key information from the attribute database.
612    
# Line 608  Line 646 
646      while (my $keyData = $keyQuery->Fetch()) {      while (my $keyData = $keyQuery->Fetch()) {
647          $retVal->Add(key => 1);          $retVal->Add(key => 1);
648          # Get the fields.          # Get the fields.
649          my ($id, $type, $description) = $keyData->Values(['AttributeKey(id)', 'AttributeKey(data-type)',          my ($id, $type, $tableName, $description) =
650                $keyData->Values(['AttributeKey(id)', 'AttributeKey(relationship-name)',
651                                                            'AttributeKey(description)']);                                                            'AttributeKey(description)']);
652          # Escape any tabs or new-lines in the description.          # Escape any tabs or new-lines in the description.
653          my $escapedDescription = Tracer::Escape($description);          my $escapedDescription = Tracer::Escape($description);
654          # Write the key data to the output.          # Write the key data to the output.
655          Tracer::PutLine($fh, [$id, $type, $escapedDescription]);          Tracer::PutLine($fh, [$id, $type, $tableName, $escapedDescription]);
656          # Get the key's groups.          # Get the key's groups.
657          my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],          my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?", [$id],
658                                      'IsInGroup(to-link)');                                      'IsInGroup(to-link)');
# Line 630  Line 669 
669    
670  =head3 RestoreKeys  =head3 RestoreKeys
671    
672  C<< my $stats = $attrDB->RestoreKeys($fileName, %options); >>      my $stats = $attrDB->RestoreKeys($fileName, %options);
673    
674  Restore the attribute keys and groups from a backup file.  Restore the attribute keys and groups from a backup file.
675    
# Line 657  Line 696 
696      # Loop until we're done.      # Loop until we're done.
697      while (! eof $fh) {      while (! eof $fh) {
698          # Get a key record.          # Get a key record.
699          my ($id, $dataType, $description) = Tracer::GetLine($fh);          my ($id, $tableName, $description) = Tracer::GetLine($fh);
700          if ($id eq '#GROUPS') {          if ($id eq '#GROUPS') {
701              Confess("Group record found when key record expected.");              Confess("Group record found when key record expected.");
702          } elsif (! defined($description)) {          } elsif (! defined($description)) {
# Line 665  Line 704 
704          } else {          } else {
705              $retVal->Add("keyIn" => 1);              $retVal->Add("keyIn" => 1);
706              # Add this key to the database.              # Add this key to the database.
707              $self->InsertObject('AttributeKey', { id => $id, 'data-type' => $dataType,              $self->InsertObject('AttributeKey', { id => $id,
708                                                    description => Tracer::UnEscape($description) });                                                    description => Tracer::UnEscape($description),
709                                                      'relationship-name' => $tableName});
710              Trace("Attribute $id stored.") if T(3);              Trace("Attribute $id stored.") if T(3);
711              # Get the group line.              # Get the group line.
712              my ($marker, @groups) = Tracer::GetLine($fh);              my ($marker, @groups) = Tracer::GetLine($fh);
# Line 702  Line 742 
742    
743  =head3 ArchiveFileName  =head3 ArchiveFileName
744    
745  C<< my $fileName = $ca->ArchiveFileName(); >>      my $fileName = $ca->ArchiveFileName();
746    
747  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
748    
# Line 735  Line 775 
775    
776  =head3 BackupAllAttributes  =head3 BackupAllAttributes
777    
778  C<< my $stats = $attrDB->BackupAllAttributes($fileName, %options); >>      my $stats = $attrDB->BackupAllAttributes($fileName, %options);
779    
780  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
781  tab-delimited file suitable for reloading via L</LoadAttributesFrom>.  tab-delimited file suitable for reloading via L</LoadAttributesFrom>.
# Line 766  Line 806 
806      # Declare the return variable.      # Declare the return variable.
807      my $retVal = Stats->new();      my $retVal = Stats->new();
808      # Get a list of the keys.      # Get a list of the keys.
809      my @keys = $self->GetFlat(['AttributeKey'], "", [], 'AttributeKey(id)');      my %keys = map { $_->[0] => $_->[1] } $self->GetAll(['AttributeKey'],
810      Trace(scalar(@keys) . " keys found during backup.") if T(2);                                                          "", [], ['AttributeKey(id)',
811                                                                      'AttributeKey(relationship-name)']);
812        Trace(scalar(keys %keys) . " keys found during backup.") if T(2);
813      # Open the file for output.      # Open the file for output.
814      my $fh = Open(undef, ">$fileName");      my $fh = Open(undef, ">$fileName");
815      # Loop through the keys.      # Loop through the keys.
816      for my $key (@keys) {      for my $key (sort keys %keys) {
817          Trace("Backing up attribute $key.") if T(3);          Trace("Backing up attribute $key.") if T(3);
818          $retVal->Add(keys => 1);          $retVal->Add(keys => 1);
819            # Get the key's relevant relationship name.
820            my $relName = $keys{$key};
821          # Loop through this key's values.          # Loop through this key's values.
822          my $query = $self->Get(['HasValueFor'], "HasValueFor(from-link) = ?", [$key]);          my $query = $self->Get([$relName], "$relName(from-link) = ?", [$key]);
823          my $valuesFound = 0;          my $valuesFound = 0;
824          while (my $line = $query->Fetch()) {          while (my $line = $query->Fetch()) {
825              $valuesFound++;              $valuesFound++;
826              # Get this row's data.              # Get this row's data.
827              my ($id, $key, $subKey, $value) = $line->Values(['HasValueFor(to-link)',              my ($id, $key, $subKey, $value) = $line->Values(["$relName(to-link)",
828                                                               'HasValueFor(from-link)',                                                               "$relName(from-link)",
829                                                               'HasValueFor(subkey)',                                                               "$relName(subkey)",
830                                                               'HasValueFor(value)']);                                                               "$relName(value)"]);
831              # Check for a subkey.              # Check for a subkey.
832              if ($subKey ne '') {              if ($subKey ne '') {
833                  $key = "$key$self->{splitter}$subKey";                  $key = "$key$self->{splitter}$subKey";
834              }              }
835              # Write it to the file.              # Write it to the file.
836              Tracer::PutLine($fh, [$id, $key, $value]);              Tracer::PutLine($fh, [$id, $key, Escape($value)]);
837          }          }
838          Trace("$valuesFound values backed up for key $key.") if T(3);          Trace("$valuesFound values backed up for key $key.") if T(3);
839          $retVal->Add(values => $valuesFound);          $retVal->Add(values => $valuesFound);
# Line 800  Line 844 
844      return $retVal;      return $retVal;
845  }  }
846    
 =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;  
 }  
847    
848  =head3 GetGroups  =head3 GetGroups
849    
850  C<< my @groups = $attrDB->GetGroups(); >>      my @groups = $attrDB->GetGroups();
851    
852  Return a list of the available groups.  Return a list of the available groups.
853    
# Line 993  Line 864 
864    
865  =head3 GetAttributeData  =head3 GetAttributeData
866    
867  C<< my %keys = $attrDB->GetAttributeData($type, @list); >>      my %keys = $attrDB->GetAttributeData($type, @list);
868    
869  Return attribute data for the selected attributes. The attribute  Return attribute data for the selected attributes. The attribute
870  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
871  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.  
872    
873  =over 4  =over 4
874    
# Line 1013  Line 883 
883    
884  =item RETURN  =item RETURN
885    
886  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,
887  parent groups.  table name, and parent groups.
888    
889  =back  =back
890    
# Line 1046  Line 916 
916          }          }
917          while (my $row = $query->Fetch()) {          while (my $row = $query->Fetch()) {
918              # Get this attribute's data.              # Get this attribute's data.
919              my ($key, $type, $notes) = $row->Values(['AttributeKey(id)', 'AttributeKey(data-type)',              my ($key, $relName, $notes) = $row->Values(['AttributeKey(id)',
920                                                         'AttributeKey(relationship-name)',
921                                                       'AttributeKey(description)']);                                                       'AttributeKey(description)']);
922              # 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.
923              if (! exists $retVal{$key}) {              if (! exists $retVal{$key}) {
924                  my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",                  my @groups = $self->GetFlat(['IsInGroup'], "IsInGroup(from-link) = ?",
925                                              [$key], 'IsInGroup(to-link)');                                              [$key], 'IsInGroup(to-link)');
926                  $retVal{$key} = [$type, $notes, @groups];                  $retVal{$key} = [$relName, $notes, @groups];
927              }              }
928          }          }
929      }      }
# Line 1062  Line 933 
933    
934  =head3 LogOperation  =head3 LogOperation
935    
936  C<< $ca->LogOperation($action, $target, $description); >>      $ca->LogOperation($action, $target, $description);
937    
938  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>).
939    
# Line 1099  Line 970 
970      close $oh;      close $oh;
971  }  }
972    
 =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;  
 }  
   
973  =head2 FIG Method Replacements  =head2 FIG Method Replacements
974    
975  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 1261  Line 997 
997    
998  =head3 GetAttributes  =head3 GetAttributes
999    
1000  C<< my @attributeList = $attrDB->GetAttributes($objectID, $key, @values); >>      my @attributeList = $attrDB->GetAttributes($objectID, $key, @values);
1001    
1002  In the database, attribute values are sectioned into pieces using a splitter  In the database, attribute values are sectioned into pieces using a splitter
1003  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 1346  Line 1082 
1082  sub GetAttributes {  sub GetAttributes {
1083      # Get the parameters.      # Get the parameters.
1084      my ($self, $objectID, $key, @values) = @_;      my ($self, $objectID, $key, @values) = @_;
1085      # This hash will map "HasValueFor" fields to patterns. We use it to build the      # Declare the return variable.
1086        my @retVal = ();
1087        # Insure we have at least some sort of filtering going on.
1088        if (! grep { defined $_ } $objectID, $key, @values) {
1089            Confess("No filters specified in GetAttributes call.");
1090        } else {
1091            # This hash will map value-table fields to patterns. We use it to build the
1092      # SQL statement.      # SQL statement.
1093      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)'} = '';  
         }  
     }  
1094      # Add the object ID to the key information.      # Add the object ID to the key information.
1095      $data{'HasValueFor(to-link)'} = $objectID;          $data{'to-link'} = $objectID;
1096      # 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
1097      # 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
1098      # every alternative value (remember, the values may be specified as a list),      # every alternative value (remember, the values may be specified as a list),
1099      # 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
1100      # as a regular expression, however, that's a problem, because we need to read          # as a regular expression, however, that's more complicated, because
1101      # every value to verify a match.          # we need to read every value to verify a match.
1102      if (@values > 0) {          if (@values > 0 && defined $values[0]) {
1103          # Get the first value and put its alternatives in an array.          # Get the first value and put its alternatives in an array.
1104          my $valueParm = $values[0];          my $valueParm = $values[0];
1105          my @valueList;          my @valueList;
# Line 1408  Line 1129 
1129          }          }
1130          # If everything works, add the value data to the filtering hash.          # If everything works, add the value data to the filtering hash.
1131          if ($okValues) {          if ($okValues) {
1132              $data{'HasValueFor(value)'} = \@valuePatterns;                  $data{value} = \@valuePatterns;
1133          }          }
1134      }      }
1135            # Now comes the really tricky part, which is key handling. The key is
1136            # actually split in two parts: the real key and a sub-key. The real key
1137            # determines which value table contains the relevant values. The information
1138            # we need is kept in here.
1139            my %tables = map { $_ => [] } $self->_GetAllTables();
1140            # See if we have any key filtering to worry about.
1141            if ($key) {
1142                # Here we have either a single key or a list. We convert both cases to a list.
1143                my $keyList = (ref $key ne 'ARRAY' ? [$key] : $key);
1144                Trace("Reading key table.") if T(3);
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                    Trace("Checking $realKey against key table.") if T(3);
1152                    # Find the matches for the real key in the key hash. For each of
1153                    # these, we memorize the table name in the hash below.
1154                    my %tableNames = ();
1155                    for my $keyInTable (keys %{$keyTableHash}) {
1156                        if (_CheckSQLPattern($realKey, $keyInTable)) {
1157                            $tableNames{$keyTableHash->{$key}} = 1;
1158                        }
1159                    }
1160                    # If the key is generic, or didn't match anything, add
1161                    # the default table to the mix.
1162                    if (keys %tableNames == 0 || $keyChoice =~ /%/) {
1163                        $tableNames{$self->{defaultRel}} = 1;
1164                    }
1165                    # Now we add this key combination to the key list for each relevant table.
1166                    for my $tableName (keys %tableNames) {
1167                        push @{$tables{$tableName}}, [$realKey, $subKey];
1168                    }
1169                }
1170            }
1171            # Now we loop through the tables of interest, performing queries.
1172            # Loop through the tables.
1173            for my $table (keys %tables) {
1174                # Get the key pairs for this table.
1175                my $pairs = $tables{$table};
1176                # Does this table have data? It does if there is no key specified or
1177                # it has at least one key pair.
1178                my $pairCount = scalar @{$pairs};
1179                Trace("Pair count for table $table is $pairCount.") if T(3);
1180                if ($pairCount || ! $key) {
1181      # Create some lists to contain the filter fragments and parameter values.      # Create some lists to contain the filter fragments and parameter values.
1182      my @filter = ();      my @filter = ();
1183      my @parms = ();      my @parms = ();
1184      # 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
1185      # 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
1186      # contains all the necessary information to do this.                  # contains most of the necessary information to do this. When we're done, we'll
1187                    # paste on stuff for the key pairs.
1188      for my $field (keys %data) {      for my $field (keys %data) {
1189          # Accumulate filter information for this field. We will OR together all the          # Accumulate filter information for this field. We will OR together all the
1190          # elements accumulated to create the final result.          # elements accumulated to create the final result.
1191          my @fieldFilter = ();          my @fieldFilter = ();
1192          # Get the specified data from the caller.                      # Get the specified filter for this field.
1193          my $fieldPattern = $data{$field};          my $fieldPattern = $data{$field};
1194          # Only proceed if the pattern is one that won't match everything.          # Only proceed if the pattern is one that won't match everything.
1195          if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {          if (defined($fieldPattern) && $fieldPattern ne "" && $fieldPattern ne "%") {
# Line 1438  Line 1206 
1206              if (@patterns) {              if (@patterns) {
1207                  # Loop through the individual patterns.                  # Loop through the individual patterns.
1208                  for my $pattern (@patterns) {                  for my $pattern (@patterns) {
1209                      # Check for a generic request.                                  my ($clause, $value) = _WherePart($table, $field, $pattern);
1210                      if (substr($pattern, -1, 1) ne '%') {                                  push @fieldFilter, $clause;
1211                          # 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;  
                     }  
1212                  }                  }
1213                  # Form the filter for this field.                  # Form the filter for this field.
1214                  my $fieldFilterString = join(" OR ", @fieldFilter);                  my $fieldFilterString = join(" OR ", @fieldFilter);
# Line 1463  Line 1216 
1216              }              }
1217          }          }
1218      }      }
1219      # 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.
1220      # values to bind to them.                  if ($pairCount) {
1221      my $actualFilter = join(" AND ", @filter);                      # We'll accumulate pair filter clauses in here.
1222      # Insure we have at least one filter.                      my @pairFilters = ();
1223      if (! $actualFilter) {                      # Loop through the key pairs.
1224          Confess("No filter specified in GetAttributes query.");                      for my $pair (@$pairs) {
1225                            my ($realKey, $subKey) = @{$pair};
1226                            my ($realClause, $realValue) = _WherePart($table, 'from-link', $realKey);
1227                            if (! $subKey) {
1228                                # Here the subkey is wild, so only the real key matters.
1229                                push @pairFilters, $realClause;
1230                                push @parms, $realValue;
1231                            } else {
1232                                # Here we have to select on both keys.
1233                                my ($subClause, $subValue) = _WherePart($table, 'subkey', $subKey);
1234                                push @pairFilters, "($realClause AND $subClause)";
1235                                push @parms, $realValue, $subValue;
1236                            }
1237                        }
1238                        # Join the pair filters together to make a giant key filter.
1239                        my $pairFilter = "(" . join(" OR ", @pairFilters) . ")";
1240                        push @filter, $pairFilter;
1241      }      }
1242                    # At this point, @filter contains one or more filter strings and @parms
1243                    # contains the parameter values to bind to them.
1244                    my $actualFilter = join(" AND ", @filter);
1245      # Now we're ready to make our query.      # Now we're ready to make our query.
1246      my $query = $self->Get(['HasValueFor'], $actualFilter, \@parms);                  my $query = $self->Get([$table], $actualFilter, \@parms);
1247      # Format the results.      # Format the results.
1248      my @retVal = $self->_QueryResults($query, @values);                  push @retVal, $self->_QueryResults($query, $table, @values);
1249      # Return the rows found.              }
1250            }
1251        }
1252        # The above loop ran the query for each necessary value table and merged the
1253        # results into @retVal. Now we return the rows found.
1254      return @retVal;      return @retVal;
1255  }  }
1256    
1257  =head3 AddAttribute  =head3 AddAttribute
1258    
1259  C<< $attrDB->AddAttribute($objectID, $key, @values); >>      $attrDB->AddAttribute($objectID, $key, @values);
1260    
1261  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
1262  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 1521  Line 1297 
1297          my $valueString = join($self->{splitter}, @values);          my $valueString = join($self->{splitter}, @values);
1298          # Split up the key.          # Split up the key.
1299          my ($realKey, $subKey) = $self->SplitKey($key);          my ($realKey, $subKey) = $self->SplitKey($key);
1300            # Find the table containing the key.
1301            my $table = $self->_KeyTable($realKey);
1302          # Connect the object to the key.          # Connect the object to the key.
1303          $self->InsertObject('HasValueFor', { 'from-link' => $realKey,          $self->InsertObject($table, { 'from-link' => $realKey,
1304                                               'to-link'   => $objectID,                                               'to-link'   => $objectID,
1305                                               'subkey'    => $subKey,                                               'subkey'    => $subKey,
1306                                               'value'     => $valueString,                                               'value'     => $valueString,
# Line 1534  Line 1312 
1312    
1313  =head3 DeleteAttribute  =head3 DeleteAttribute
1314    
1315  C<< $attrDB->DeleteAttribute($objectID, $key, @values); >>      $attrDB->DeleteAttribute($objectID, $key, @values);
1316    
1317  Delete the specified attribute key/value combination from the database.  Delete the specified attribute key/value combination from the database.
1318    
# Line 1568  Line 1346 
1346      } else {      } else {
1347          # Split the key into the real key and the subkey.          # Split the key into the real key and the subkey.
1348          my ($realKey, $subKey) = $self->SplitKey($key);          my ($realKey, $subKey) = $self->SplitKey($key);
1349            # Find the table containing the key's values.
1350            my $table = $self->_KeyTable($realKey);
1351          if ($subKey eq '' && scalar(@values) == 0) {          if ($subKey eq '' && scalar(@values) == 0) {
1352              # Here we erase the entire key for this object.              # Here we erase the entire key for this object.
1353              $self->DeleteRow('HasValueFor', $key, $objectID);              $self->DeleteRow('HasValueFor', $key, $objectID);
# Line 1584  Line 1364 
1364    
1365  =head3 DeleteMatchingAttributes  =head3 DeleteMatchingAttributes
1366    
1367  C<< my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values); >>      my @deleted = $attrDB->DeleteMatchingAttributes($objectID, $key, @values);
1368    
1369  Delete all attributes that match the specified criteria. This is equivalent to  Delete all attributes that match the specified criteria. This is equivalent to
1370  calling L</GetAttributes> and then invoking L</DeleteAttribute> for each  calling L</GetAttributes> and then invoking L</DeleteAttribute> for each
# Line 1644  Line 1424 
1424    
1425  =head3 ChangeAttribute  =head3 ChangeAttribute
1426    
1427  C<< $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues); >>      $attrDB->ChangeAttribute($objectID, $key, \@oldValues, \@newValues);
1428    
1429  Change the value of an attribute key/value pair for an object.  Change the value of an attribute key/value pair for an object.
1430    
# Line 1696  Line 1476 
1476    
1477  =head3 EraseAttribute  =head3 EraseAttribute
1478    
1479  C<< $attrDB->EraseAttribute($key); >>      $attrDB->EraseAttribute($key);
1480    
1481  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
1482  key from the database; it merely removes all the values.  key from the database; it merely removes all the values.
# Line 1715  Line 1495 
1495  sub EraseAttribute {  sub EraseAttribute {
1496      # Get the parameters.      # Get the parameters.
1497      my ($self, $key) = @_;      my ($self, $key) = @_;
1498      # Delete everything connected to the key.      # Find the table containing the key.
1499        my $table = $self->_KeyTable($key);
1500        # Is it the default table?
1501        if ($table eq $self->{defaultRel}) {
1502            # Yes, so the key is mixed in with other keys.
1503            # Delete everything connected to it.
1504      $self->Disconnect('HasValueFor', 'AttributeKey', $key);      $self->Disconnect('HasValueFor', 'AttributeKey', $key);
1505        } else {
1506            # No. Drop and re-create the table.
1507            $self->TruncateTable($table);
1508        }
1509      # Log the operation.      # Log the operation.
1510      $self->LogOperation("Erase Data", $key);      $self->LogOperation("Erase Data", $key);
1511      # Return a 1, for backward compatability.      # Return a 1, for backward compatability.
# Line 1725  Line 1514 
1514    
1515  =head3 GetAttributeKeys  =head3 GetAttributeKeys
1516    
1517  C<< my @keyList = $attrDB->GetAttributeKeys($groupName); >>      my @keyList = $attrDB->GetAttributeKeys($groupName);
1518    
1519  Return a list of the attribute keys for a particular group.  Return a list of the attribute keys for a particular group.
1520    
# Line 1755  Line 1544 
1544    
1545  =head3 QueryAttributes  =head3 QueryAttributes
1546    
1547  C<< my @attributeData = $ca->QueryAttributes($filter, $filterParms); >>      my @attributeData = $ca->QueryAttributes($filter, $filterParms);
1548    
1549  Return the attribute data based on an SQL filter clause. In the filter clause,  Return the attribute data based on an SQL filter clause. In the filter clause,
1550  the name C<$object> should be used for the object ID, C<$key> should be used for  the name C<$object> should be used for the object ID, C<$key> should be used for
# Line 1784  Line 1573 
1573  =cut  =cut
1574    
1575  # This hash is used to drive the substitution process.  # This hash is used to drive the substitution process.
1576  my %AttributeParms = (object => 'HasValueFor(to-link)',  my %AttributeParms = (object => 'to-link',
1577                        key    => 'HasValueFor(from-link)',                        key    => 'from-link',
1578                        subkey => 'HasValueFor(subkey)',                        subkey => 'subkey',
1579                        value  => 'HasValueFor(value)');                        value  => 'value');
1580    
1581  sub QueryAttributes {  sub QueryAttributes {
1582      # Get the parameters.      # Get the parameters.
# Line 1796  Line 1585 
1585      my @retVal = ();      my @retVal = ();
1586      # Make sue we have filter parameters.      # Make sue we have filter parameters.
1587      my $realParms = (defined($filterParms) ? $filterParms : []);      my $realParms = (defined($filterParms) ? $filterParms : []);
1588      # Create the query by converting the filter.      # Loop through all the value tables.
1589        for my $table ($self->_GetAllTables()) {
1590            # Create the query for this table by converting the filter.
1591      my $realFilter = $filter;      my $realFilter = $filter;
1592      for my $name (keys %AttributeParms) {      for my $name (keys %AttributeParms) {
1593          $realFilter =~ s/\$$name/$AttributeParms{$name}/g;              $realFilter =~ s/\$$name/$table($AttributeParms{$name})/g;
1594      }      }
1595      my $query = $self->Get(['HasValueFor'], $realFilter, $realParms);          my $query = $self->Get([$table], $realFilter, $realParms);
1596      # Loop through the results, forming the output attribute tuples.      # Loop through the results, forming the output attribute tuples.
1597      while (my $result = $query->Fetch()) {      while (my $result = $query->Fetch()) {
1598          # Get the four values from this query result row.          # Get the four values from this query result row.
1599          my ($objectID, $key, $subkey, $value) = $result->Values([$AttributeParms{object},              my ($objectID, $key, $subkey, $value) = $result->Values(["$table($AttributeParms{object})",
1600                                                                  $AttributeParms{key},                                                                      "$table($AttributeParms{key})",
1601                                                                  $AttributeParms{subkey},                                                                      "$table($AttributeParms{subkey})",
1602                                                                  $AttributeParms{value}]);                                                                      "$table($AttributeParms{value})"]);
1603          # Combine the key and the subkey.          # Combine the key and the subkey.
1604          my $realKey = ($subkey ? $key . $self->{splitter} . $subkey : $key);          my $realKey = ($subkey ? $key . $self->{splitter} . $subkey : $key);
1605          # Split the value.          # Split the value.
# Line 1816  Line 1607 
1607          # Output the result.          # Output the result.
1608          push @retVal, [$objectID, $realKey, @values];          push @retVal, [$objectID, $realKey, @values];
1609      }      }
1610        }
1611      # Return the result.      # Return the result.
1612      return @retVal;      return @retVal;
1613  }  }
# Line 1824  Line 1616 
1616    
1617  =head3 ParseID  =head3 ParseID
1618    
1619  C<< my ($type, $id) = CustomAttributes::ParseID($idValue); >>      my ($type, $id) = CustomAttributes::ParseID($idValue);
1620    
1621  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.
1622  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 1881  Line 1673 
1673    
1674  =head3 FormID  =head3 FormID
1675    
1676  C<< my $idValue = CustomAttributes::FormID($type, $id); >>      my $idValue = CustomAttributes::FormID($type, $id);
1677    
1678  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,
1679  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 1922  Line 1714 
1714    
1715  =head3 GetTargetObject  =head3 GetTargetObject
1716    
1717  C<< my $object = CustomAttributes::GetTargetObject($erdb, $idValue); >>      my $object = CustomAttributes::GetTargetObject($erdb, $idValue);
1718    
1719  Return the database object corresponding to the specified attribute object ID. The  Return the database object corresponding to the specified attribute object ID. The
1720  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 1961  Line 1753 
1753    
1754  =head3 SplitKey  =head3 SplitKey
1755    
1756  C<< my ($realKey, $subKey) = $ca->SplitKey($key); >>      my ($realKey, $subKey) = $ca->SplitKey($key);
1757    
1758  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.
1759  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 1995  Line 1787 
1787      return ($realKey, $subKey);      return ($realKey, $subKey);
1788  }  }
1789    
1790    
1791  =head3 JoinKey  =head3 JoinKey
1792    
1793  C<< my $key = $ca->JoinKey($realKey, $subKey); >>      my $key = $ca->JoinKey($realKey, $subKey);
1794    
1795  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
1796  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 2042  Line 1835 
1835    
1836  =head3 AttributeTable  =head3 AttributeTable
1837    
1838  C<< my $tableHtml = CustomAttributes::AttributeTable($cgi, @attrList); >>      my $tableHtml = CustomAttributes::AttributeTable($cgi, @attrList);
1839    
1840  Format the attribute data into an HTML table.  Format the attribute data into an HTML table.
1841    
# Line 2075  Line 1868 
1868          my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];          my @columns = map { CGI::escapeHTML($_) } @{$attrData}[0,1];
1869          # Now we format the values. These remain unchanged unless one of them is a URL.          # Now we format the values. These remain unchanged unless one of them is a URL.
1870          my $lastValue = scalar(@{$attrData}) - 1;          my $lastValue = scalar(@{$attrData}) - 1;
1871          push @columns, map { $_ =~ /^http:/ ? $cgi->a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];          push @columns, map { $_ =~ /^http:/ ? CGI::a({ href => $_ }, $_) : $_ } @{$attrData}[2 .. $lastValue];
1872          # Assemble the values into a table row.          # Assemble the values into a table row.
1873          push @html, $cgi->Tr($cgi->td(\@columns));          push @html, CGI::Tr(CGI::td(\@columns));
1874      }      }
1875      # Format the table in the return variable.      # Format the table in the return variable.
1876      my $retVal = $cgi->table({ border => 2 }, $cgi->Tr($cgi->th(['Object', 'Key', 'Values'])), @html);      my $retVal = CGI::table({ border => 2 }, CGI::Tr(CGI::th(['Object', 'Key', 'Values'])), @html);
1877      # Return it.      # Return it.
1878      return $retVal;      return $retVal;
1879  }  }
1880    
1881    
1882    =head2 Internal Utility Methods
1883    
1884    =head3 _KeyTable
1885    
1886        my $tableName = $ca->_KeyTable($keyName);
1887    
1888    Return the name of the table that contains the attribute values for the
1889    specified key.
1890    
1891    Most attribute values are stored in the default table (usually C<HasValueFor>).
1892    Some, however, are placed in private tables by themselves for performance reasons.
1893    
1894    =over 4
1895    
1896    =item keyName (optional)
1897    
1898    Name of the attribute key whose table name is desired. If not specified, the
1899    entire key/table hash is returned.
1900    
1901    =item RETURN
1902    
1903    Returns the name of the table containing the specified attribute key's values,
1904    or a reference to a hash that maps key names to table names.
1905    
1906    =back
1907    
1908    =cut
1909    
1910    sub _KeyTable {
1911        # Get the parameters.
1912        my ($self, $keyName) = @_;
1913        # Declare the return variable.
1914        my $retVal;
1915        # Insure the key table hash is present.
1916        if (! exists $self->{keyTables}) {
1917            Trace("Creating key table.") if T(3);
1918            $self->{keyTables} = { map { $_->[0] => $_->[1] } $self->GetAll(['AttributeKey'],
1919                                                    "AttributeKey(relationship-name) <> ?",
1920                                                    [$self->{defaultRel}],
1921                                                    ['AttributeKey(id)', 'AttributeKey(relationship-name)']) };
1922        }
1923        # Get the key hash.
1924        my $keyHash = $self->{keyTables};
1925        # Does the user want a specific table or the whole thing?
1926        if ($keyName) {
1927            # Here we want a specific table. Is this key in the hash?
1928            if (exists $keyHash->{$keyName}) {
1929                # It's there, so return the specified table.
1930                $retVal = $keyHash->{$keyName};
1931            } else {
1932                # No, return the default table name.
1933                $retVal = $self->{defaultRel};
1934            }
1935        } else {
1936            # Here we want the whole hash.
1937            $retVal = $keyHash;
1938        }
1939        # Return the result.
1940        return $retVal;
1941    }
1942    
1943    
1944    =head3 _QueryResults
1945    
1946        my @attributeList = $attrDB->_QueryResults($query, $table, @values);
1947    
1948    Match the results of a query against value criteria and return
1949    the results. This is an internal method that splits the values coming back
1950    and matches the sections against the specified section patterns. It serves
1951    as the back end to L</GetAttributes> and L</FindAttributes>.
1952    
1953    =over 4
1954    
1955    =item query
1956    
1957    A query object that will return the desired records.
1958    
1959    =item table
1960    
1961    Name of the value table for the query.
1962    
1963    =item values
1964    
1965    List of the desired attribute values, section by section. If C<undef>
1966    or an empty string is specified, all values in that section will match. A
1967    generic match can be requested by placing a percent sign (C<%>) at the end.
1968    In that case, all values that match up to and not including the percent sign
1969    will match. You may also specify a regular expression enclosed
1970    in slashes. All values that match the regular expression will be returned. For
1971    performance reasons, only values have this extra capability.
1972    
1973    =item RETURN
1974    
1975    Returns a list of tuples. The first element in the tuple is an object ID, the
1976    second is an attribute key, and the remaining elements are the sections of
1977    the attribute value. All of the tuples will match the criteria set forth in
1978    the parameter list.
1979    
1980    =back
1981    
1982    =cut
1983    
1984    sub _QueryResults {
1985        # Get the parameters.
1986        my ($self, $query, $table, @values) = @_;
1987        # Declare the return value.
1988        my @retVal = ();
1989        # We use this hash to check for duplicates.
1990        my %dupHash = ();
1991        # Get the number of value sections we have to match.
1992        my $sectionCount = scalar(@values);
1993        # Loop through the assignments found.
1994        while (my $row = $query->Fetch()) {
1995            # Get the current row's data.
1996            my ($id, $realKey, $subKey, $valueString) = $row->Values(["$table(to-link)",
1997                                                                      "$table(from-link)",
1998                                                                      "$table(subkey)",
1999                                                                      "$table(value)"
2000                                                                    ]);
2001            # Form the key from the real key and the sub key.
2002            my $key = $self->JoinKey($realKey, $subKey);
2003            # Break the value into sections.
2004            my @sections = split($self->{splitter}, $valueString);
2005            # Match each section against the incoming values. We'll assume we're
2006            # okay unless we learn otherwise.
2007            my $matching = 1;
2008            for (my $i = 0; $i < $sectionCount && $matching; $i++) {
2009                # We need to check to see if this section is generic.
2010                my $value = $values[$i];
2011                Trace("Current value pattern is \"$value\".") if T(4);
2012                if ($value =~ m#^/(.+)/[a-z]*$#) {
2013                    Trace("Regular expression detected.") if T(4);
2014                    # Here we have a regular expression match.
2015                    my $section = $sections[$i];
2016                    $matching = eval("\$section =~ $value");
2017                } elsif (! defined $value) {
2018                    # Wild card. Skip it.
2019                } else {
2020                    # Here we have a normal match.
2021                    Trace("SQL match used.") if T(4);
2022                    $matching = _CheckSQLPattern($values[$i], $sections[$i]);
2023                }
2024            }
2025            # If we match, consider writing this row to the return list.
2026            if ($matching) {
2027                # Check for a duplicate.
2028                my $wholeThing = join($self->{splitter}, $id, $key, $valueString);
2029                if (! $dupHash{$wholeThing}) {
2030                    # It's okay, we're not a duplicate. Insure we don't duplicate this result.
2031                    $dupHash{$wholeThing} = 1;
2032                    push @retVal, [$id, $key, @sections];
2033                }
2034            }
2035        }
2036        # Return the rows found.
2037        return @retVal;
2038    }
2039    
2040    
2041    =head3 _LoadAttributeTable
2042    
2043        $attr->_LoadAttributeTable($tableName, $fileName, $stats, $mode);
2044    
2045    Load a file's data into an attribute table. This is an internal method
2046    provided for the convenience of L</LoadAttributesFrom>. It loads the
2047    specified file into the specified table and updates the statistics
2048    object.
2049    
2050    =over 4
2051    
2052    =item tableName
2053    
2054    Name of the table being loaded. This is usually C<HasValueFor>, but may
2055    be a different table for some specific attribute keys.
2056    
2057    =item fileName
2058    
2059    Name of the file containing a chunk of attribute data to load.
2060    
2061    =item stats
2062    
2063    Statistics object into which counts and times should be placed.
2064    
2065    =item mode
2066    
2067    Load mode for the file, usually C<low_priority>, C<concurrent>, or
2068    an empty string. The mode is used by some applications to control access
2069    to the table while it's being loaded. The default (empty string) is to lock the
2070    table until all the data's in place.
2071    
2072    =back
2073    
2074    =cut
2075    
2076    sub _LoadAttributeTable {
2077        # Get the parameters.
2078        my ($self, $tableName, $fileName, $stats, $mode) = @_;
2079        # Load the table from the file. Note that we don't do an analyze.
2080        # The analyze is done only after everything is complete.
2081        my $startTime = time();
2082        Trace("Loading attributes from $fileName: " . (-s $fileName) .
2083              " characters.") if T(3);
2084        my $loadStats = $self->LoadTable($fileName, $tableName,
2085                                         mode => $mode, partial => 1);
2086        # Record the load time.
2087        $stats->Add(insertTime => time() - $startTime);
2088        # Roll up the other statistics.
2089        $stats->Accumulate($loadStats);
2090    }
2091    
2092    
2093    =head3 _GetAllTables
2094    
2095        my @tables = $ca->_GetAllTables();
2096    
2097    Return a list of the names of all the tables used to store attribute
2098    values.
2099    
2100    =cut
2101    
2102    sub _GetAllTables {
2103        # Get the parameters.
2104        my ($self) = @_;
2105        # Start with the default table.
2106        my @retVal = $self->{defaultRel};
2107        # Add the tables named in the key hash. These tables are automatically
2108        # NOT the default, and each can only occur once, because alternate tables
2109        # are allocated on a per-key basis.
2110        my $keyHash = $self->_KeyTable();
2111        push @retVal, values %$keyHash;
2112        # Return the result.
2113        return @retVal;
2114    }
2115    
2116    
2117    =head3 _SplitKeyPattern
2118    
2119        my ($realKey, $subKey) = $ca->_SplitKeyPattern($keyChoice);
2120    
2121    Split a key pattern into the main part (the I<real key>) and a sub-part
2122    (the I<sub key>). This method differs from L</SplitKey> in that it treats
2123    the key as an SQL pattern instead of a raw string. Also, if there is no
2124    incoming sub-part, the sub-key will be undefined instead of an empty
2125    string.
2126    
2127    =over 4
2128    
2129    =item keyChoice
2130    
2131    SQL key pattern to be examined. This can either be a literal, an SQL pattern,
2132    a literal with an internal splitter code (usually C<::>) or an SQL pattern with
2133    an internal splitter. Note that the only SQL pattern we support is a percent
2134    sign (C<%>) at the end. This is the way we've declared things in the documentation,
2135    so users who try anything else will have problems.
2136    
2137    =item RETURN
2138    
2139    Returns a two-element list. The first element is the SQL pattern for the
2140    real key and the second is the SQL pattern for the sub-key. If the value
2141    for either one does not matter (e.g., the user wants a real key value of
2142    C<iedb> and doesn't care about the sub-key value), it will be undefined.
2143    
2144    =back
2145    
2146    =cut
2147    
2148    sub _SplitKeyPattern {
2149        # Get the parameters.
2150        my ($self, $keyChoice) = @_;
2151        # Declare the return variables.
2152        my ($realKey, $subKey);
2153        # Look for a splitter in the input.
2154        if ($keyChoice =~ /^(.*?)$self->{splitter}(.*)/) {
2155            # We found one. This means we can treat both sides of the
2156            # splitter as known patterns.
2157            ($realKey, $subKey) = ($1, $2);
2158        } elsif ($keyChoice =~ /%$/) {
2159            # Here we have a generic pattern for the whole key. The pattern
2160            # is treated as the correct pattern for the real key, but the
2161            # sub-key is considered to be wild.
2162            $realKey = $keyChoice;
2163        } else {
2164            # Here we have a literal pattern for the whole key. The pattern
2165            # is treated as the correct pattern for the real key, and the
2166            # sub-key is required to be blank.
2167            $realKey = $keyChoice;
2168            $subKey = '';
2169        }
2170        # Return the results.
2171        return ($realKey, $subKey);
2172    }
2173    
2174    
2175    =head3 _WherePart
2176    
2177        my ($sqlClause, $escapedValue) = _WherePart($tableName, $fieldName, $sqlPattern);
2178    
2179    Return the SQL clause and value for checking a field against the
2180    specified SQL pattern value. If the pattern is generic (ends in a C<%>),
2181    then a C<LIKE> expression is returned. Otherwise, an equality expression
2182    is returned. We take in information describing the field being checked,
2183    and the pattern we're checking against it. The output is a WHERE clause
2184    fragment for the comparison and a value to be used as a bound parameter
2185    value for the clause.
2186    
2187    =over 4
2188    
2189    =item tableName
2190    
2191    Name of the table containing the field we want checked by the clause.
2192    
2193    =item fieldName
2194    
2195    Name of the field to check in that table.
2196    
2197    =item sqlPattern
2198    
2199    Pattern to be compared against the field. If the last character is a percent sign
2200    (C<%>), it will be treated as a generic SQL pattern; otherwise, it will be treated
2201    as a literal.
2202    
2203    =item RETURN
2204    
2205    Returns a two-element list. The first element will be an SQL comparison expression
2206    and the second will be the value to be used as a bound parameter for the expression
2207    in order to
2208    
2209    =back
2210    
2211    =cut
2212    
2213    sub _WherePart {
2214        # Get the parameters.
2215        my ($tableName, $fieldName, $sqlPattern) = @_;
2216        # Declare the return variables.
2217        my ($sqlClause, $escapedValue);
2218        # Copy the pattern into the return area.
2219        $escapedValue = $sqlPattern;
2220        # Check the pattern. Is it generic or exact?
2221        if ($sqlPattern =~ /(.+)%$/) {
2222            # Yes, it is. We need a LIKE clause and we must escape the underscores
2223            # and percents in the pattern (except for the last one, of course).
2224            $escapedValue = $1;
2225            $escapedValue =~ s/(%|_)/\\$1/g;
2226            $escapedValue .= "%";
2227            $sqlClause = "$tableName($fieldName) LIKE ?";
2228        } else {
2229            # No, it isn't. We use an equality clause.
2230            $sqlClause = "$tableName($fieldName) = ?";
2231        }
2232        # Return the results.
2233        return ($sqlClause, $escapedValue);
2234    }
2235    
2236    
2237    =head3 _CheckSQLPattern
2238    
2239        my $flag = _CheckSQLPattern($pattern, $value);
2240    
2241    Return TRUE if the specified SQL pattern matches the specified value,
2242    else FALSE. The pattern is not a true full-blown SQL LIKE pattern: the
2243    only wild-carding allowed is a percent sign (C<%>) at the end.
2244    
2245    =over 4
2246    
2247    =item pattern
2248    
2249    SQL pattern to match against a value.
2250    
2251    =item value
2252    
2253    Value to match against an SQL pattern.
2254    
2255    =item RETURN
2256    
2257    Returns TRUE if the pattern matches the value, else FALSE.
2258    
2259    =back
2260    
2261    =cut
2262    
2263    sub _CheckSQLPattern {
2264        # Get the parameters.
2265        my ($pattern, $value) = @_;
2266        # Declare the return variable.
2267        my $retVal;
2268        # Check for a generic pattern.
2269        if ($pattern =~ /(.*)%$/) {
2270            # Here we have one. Do a substring match.
2271            $retVal = (substr($value, 0, length $1) eq $1);
2272        } else {
2273            # Here it's an exact match.
2274            $retVal = ($pattern eq $value);
2275        }
2276        Trace("SQL pattern check: \"$value\" vs \"$pattern\" = $retVal.") if T(3);
2277        # Return the result.
2278        return $retVal;
2279    }
2280    
2281  1;  1;

Legend:
Removed from v.1.30  
changed lines
  Added in v.1.40

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3