[Bio] / Sprout / AttributeTest.pl Repository:
ViewVC logotype

Diff of /Sprout/AttributeTest.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1, Fri Feb 9 22:58:32 2007 UTC revision 1.4, Thu Dec 6 14:58:03 2007 UTC
# Line 53  Line 53 
53  use File::Path;  use File::Path;
54  use FIG;  use FIG;
55  use CustomAttributes;  use CustomAttributes;
56    use Time::HiRes qw ( time alarm sleep );
57    
58  # Get the command-line options and parameters.  # Get the command-line options and parameters.
59  my ($options, @parameters) = StandardSetup([qw(CustomAttributes) ],  my ($options, @parameters) = StandardSetup([qw(CustomAttributes) ],
60                                             {                                             {
61                                                  trace => [2, "trace level"],
62                                                phone => ["", "phone number (international format) to call when load finishes"],                                                phone => ["", "phone number (international format) to call when load finishes"],
63                                             },                                             },
64                                             "",                                             "",
65                                             @ARGV);                                             @ARGV);
66  # Set a variable to contain return type information.  # Set a variable to contain return type information.
67  my $rtype;  my $rtype;
 # Insure we catch errors.  
 eval {  
68      # Get a FIG object.      # Get a FIG object.
69      my $fig = FIG->new();      my $fig = FIG->new();
70      # Get the CustomAttributes object.      # Get the CustomAttributes object.
71      my $ca = $fig->{_ca};      my $ca = $fig->{_ca};
72    # Insure we catch errors.
73    eval {
74      # Insure the attribute server is local.      # Insure the attribute server is local.
75      if (ref $ca ne 'CustomAttributes') {      if (ref $ca ne 'CustomAttributes') {
76          Confess("This test must be run on a local attribute server.");          Confess("This test must be run on a local attribute server.");
# Line 98  Line 100 
100                  # Format the value.                  # Format the value.
101                  my $valueValue = join($ca->{splitter}, @{$value});                  my $valueValue = join($ca->{splitter}, @{$value});
102                  # Write the line.                  # Write the line.
103                  Tracer::PutLine($oh, [$idValue, $valueValue]);                  Tracer::PutLine($oh, [$idValue, 'Frog', $valueValue]);
104              } else {              } else {
105                  # Here we have a comment line.                  # Here we have a comment line.
106                  Tracer::PutLine($oh, [$value]);                  Tracer::PutLine($oh, [$value]);
# Line 131  Line 133 
133          }          }
134          # Load the attribute.          # Load the attribute.
135          Trace("Loading Frog data.") if T(3);          Trace("Loading Frog data.") if T(3);
136          my $ih = Open(undef, "<$loadFileName");          my $stats = $ca->LoadAttributesFrom($loadFileName);
         my $stats = $ca->LoadAttributeKey('Frog', $ih, 0, 1);  
137          # Now we need to test the data against what's in the hash. First we get the data.          # Now we need to test the data against what's in the hash. First we get the data.
138          my @attributes = $fig->get_attributes(undef, 'Frog');          my @attributes = $fig->get_attributes(undef, 'Frog');
139          # Loop through the attributes, checking against the hash. As we find an attribute,          # Loop through the attributes, checking against the hash. As we find an attribute,
# Line 198  Line 199 
199                  if (@nonTuple) {                  if (@nonTuple) {
200                      Confess("Delete failed.");                      Confess("Delete failed.");
201                  } else {                  } else {
202                      # Delete the key.                      # Erase the key. We'll use it again in the subkey test, so we
203                      $ca->DeleteAttributeKey('Frog');                      # don't want to delete it.
204                        $ca->EraseAttribute('Frog');
205                      # Verify that it has no values.                      # Verify that it has no values.
206                      my @values = $fig->get_attributes(undef, 'Frog');                      my @values = $fig->get_attributes(undef, 'Frog');
207                      if (@values) {                      if (@values) {
208                          Confess("Not all Frog attributes were deleted.");                          Confess("Not all Frog attributes were deleted.");
                     } else {  
                         # Insure there is no Frog attribute.  
                         my %keys = $ca->GetAttributeData(name => 'Frog');  
                         if (exists $keys{Frog}) {  
                             Confess("Frog attribute was not deleted.");  
209                          }                          }
210                      }                      }
211                  }                  }
212              }              }
213            Trace("GetAttribute tests.") if T(2);
214            # Now we do a get-attribute test. First, we need two new attributes: Frog1 and Frog2.
215            $ca->StoreAttributeKey('Frog1', 'string',
216                                   'This is another test attribute. It is used for complex get-attribute testing, along with a second attribute called Frog2.',
217                                   []);
218            $ca->StoreAttributeKey('Frog2', 'text',
219                                   'This is the third test attribute. Its name is similar to the second attribute so we can test generic lookups.',
220                                   []);
221            # Clear any existing data.
222            $ca->EraseAttribute('Frog1');
223            $ca->EraseAttribute('Frog2');
224            # Now we create an array of data to insert.
225            Trace("Creating test attributes.") if T(2);
226            my @frogRows = (['fig|100226.1.peg.1', 'Frog1', 123,      456],
227                            ['fig|100226.1.peg.1', 'Frog1', 123,      567],
228                            ['fig|100226.1.peg.2', 'Frog2', 12,       4567],
229                            ['fig|100226.1.peg.2', 'Frog1', 'data1',  'data2',  'data3'],
230                            ['fig|100226.1.peg.3', 'Frog1', '12data', 'data3',  'data4'],
231                            ['fig|100226.1.peg.3', 'Frog1', 'data12', '3data3', '4data4'],
232                            ['fig|83333.1.peg.1',  'Frog1', 'data12', '3data3', '4data4'],
233                            ['fig|83333.1.peg.1',  'Frog2', 'data12', '3data3', '4data4'],
234                            ['fig|83333.1.peg.1',  'Frog1', 'abc123', '123abd', '44data'],
235                            ['fig|83333.1.peg.2',  'Frog2', '12data'],
236                            ['fig|83333.1.peg.3',  'Frog1', '12data']);
237            for my $frogRow (@frogRows) {
238                $ca->AddAttribute(@{$frogRow});
239            }
240            # Get all the frog data.
241            Trace("Get-all test.") if T(2);
242            my @frogData = $ca->GetAttributes(undef, 'Frog%');
243            # Verify that it matches.
244            if (! MatchListsOfLists(\@frogRows, \@frogData)) {
245                Confess("Not all expected frog data returned by generic search on key.");
246            }
247            # Get all the frog 2s for 100226.1.
248            Trace("Generic ID test.") if T(2);
249            my @expected = grep { $_->[0] =~ /^fig\|100226.1/ && $_->[1] eq 'Frog2' } @frogRows;
250            @frogData = $ca->GetAttributes("fig|100226.1%", 'Frog2');
251            if (! MatchListsOfLists(\@expected, \@frogData)) {
252                Confess("Generic search on object ID failed.");
253            }
254            # Get all the frog 1s with "data" in the first value.
255            Trace("Regular expression test.") if T(2);
256            @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /data/ } @frogRows;
257            @frogData = $ca->GetAttributes(undef, 'Frog1', '/data/');
258            if (! MatchListsOfLists(\@expected, \@frogData)) {
259                Confess("Regular expression search on value failed.");
260            }
261            # Get all the frog 1s with values that start with "12".
262            Trace("Generic value test.") if T(2);
263            @expected = grep { $_->[1] eq 'Frog1' && $_->[2] =~ /^12/ } @frogRows;
264            @frogData = $ca->GetAttributes(undef, 'Frog1', '12%');
265            if (! MatchListsOfLists(\@expected, \@frogData)) {
266                Confess("Generic value match failed.");
267            }
268            Trace("Deleting test keys.") if T(2);
269            # Delete the test keys.
270            $ca->DeleteAttributeKey('Frog1');
271            $ca->DeleteAttributeKey('Frog2');
272            # Insure they are gone.
273            my %keys = $ca->GetAttributeData(name => 'Frog');
274            if (exists $keys{Frog1}) {
275                Confess("Frog1 attribute was not deleted.");
276            } elsif (exists $keys{Frog2}) {
277                Confess("Frog2 attribute was not deleted.");
278            } else {
279                # Now we know the keys are gone. Is the data gone?
280                my @frog12Rows = $ca->GetAttributes(undef, ['Frog1','Frog2']);
281                if (@frog12Rows) {
282                    Confess("Not all Frog1 and Frog2 values were deleted.");
283                }
284            }
285            # Now we test the subkey facility. First, we need a load file.
286            my @froggyRows = (['aclame|cluster844','Frog::tadpole','test1'],
287                              ['aclame|cluster845','Frog','test2'],
288                              ['aclame|cluster846','Frog::egg','test3'],
289                              ['aclame|cluster849','Frog','test4'],
290                              ['aclame|cluster852','Frog::adult','test5'],
291                              ['aclame|cluster85','Frog::egg','test6'],
292                              ['aclame|cluster853','Frog::tadpole2','test7'],
293                              ['aclame|cluster854','Frog','test8'],
294                              ['aclame|cluster855','Frog::egg','test8']);
295            $oh = Open(undef, ">$loadFileName");
296            for my $froggyRow (@froggyRows) {
297                Tracer::PutLine($oh, $froggyRow);
298          }          }
299            close $oh;
300            # Load the Frog attribute from the load file. We will take this opportunity to test
301            # the object type and archive modes.
302            my $archiveFile = $ca->ArchiveFileName();
303            my $ih = Open(undef, "<$loadFileName");
304            $stats = $ca->LoadAttributesFrom($ih, archive => $archiveFile, objectType => 'Family');
305            Trace("Statistics from subkey test load.\n" . $stats->Show()) if T(2);
306            # Now do an ID fix on the froggy rows so they match what's in the database.
307            for my $froggyRow (@froggyRows) {
308                $froggyRow->[0] = "Family:$froggyRow->[0]";
309            }
310            # Verify the archive file.
311            $ih = Open(undef, "<$archiveFile");
312            my $rowNum = 0;
313            while (! eof $ih) {
314                # Get the current file line and the current row.
315                my @fileRow = Tracer::GetLine($ih);
316                my @frogRow = @{$froggyRows[$rowNum]};
317                # Insure they match.
318                if (! MatchLists(\@fileRow, \@frogRow)) {
319                    Confess("Archive mismatch for subkey test in line $rowNum of $archiveFile.");
320                } else {
321                    $rowNum++
322                }
323            }
324            close $ih;
325            # Now verify a generic frog retrieval. It's important at this point that Frog1 and Frog2
326            # have already been erased, or this test will fail.
327            Trace("Generic frog retrieval test.") if T(3);
328            @frogData = $ca->GetAttributes(undef, 'Frog%');
329            if (! MatchListsOfLists(\@froggyRows, \@frogData)) {
330                Confess("Generic frog retrieval failed in subkey test.");
331            }
332            # Next we do a generic subkey search.
333            Trace("Generic tadpole retrieval test.") if T(3);
334            @expected = grep { $_->[1] =~ /^Frog::tadpole/ } @froggyRows;
335            @frogData = $ca->GetAttributes(undef, 'Frog::tadpole%');
336            if (! MatchListsOfLists(\@expected, \@frogData)) {
337                Confess("Generic tadpole retrieval failed in subkey test.");
338            }
339            # Now an exact subkey search.
340            Trace("Exact subkey retrieval test.") if T(3);
341            @expected = grep { $_->[1] eq 'Frog::tadpole' } @froggyRows;
342            @frogData = $ca->GetAttributes(undef, 'Frog::tadpole');
343            if (! MatchListsOfLists(\@expected, \@frogData)) {
344                Confess("Exact tadpole retrieval failed in subkey test.");
345      }      }
346            # All done.
347      Trace("Test complete.") if T(2);      Trace("Test complete.") if T(2);
348        }
349  };  };
350    
351  if ($@) {  if ($@) {
# Line 226  Line 355 
355      Trace("Script complete.") if T(2);      Trace("Script complete.") if T(2);
356      $rtype = "no error";      $rtype = "no error";
357  }  }
358    # Delete any leftover frogs.
359    my %frogs = $ca->GetAttributeData(name => 'Frog');
360    for my $frog (keys %frogs) {
361        Trace("Deleting $frog attribute.") if T(3);
362        my $stats = $ca->DeleteAttributeKey($frog);
363        Trace("$frog deleted.\n" . $stats->Show()) if T(2);
364    }
365  if ($options->{phone}) {  if ($options->{phone}) {
366      my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");      my $msgID = Tracer::SendSMS($options->{phone}, "Attribute Test Script terminated with $rtype.");
367      if ($msgID) {      if ($msgID) {
# Line 235  Line 371 
371      }      }
372  }  }
373    
374    =head3 MatchLists
375    
376        my $matchFlag = MatchLists($list1, $list2);
377    
378    Return TRUE if the two lists have the same elements, else FALSE. The matching is done
379    purely stringwise.
380    
381    =over 4
382    
383    =item list1
384    
385    Reference to a list of items.
386    
387    =item list2
388    
389    Reference to another list of items.
390    
391    =item RETURN
392    
393    Returns TRUE if the lists have matching elements.
394    
395    =back
396    
397    =cut
398    
399    sub MatchLists {
400        # Get the parameters.
401        my ($list1, $list2) = @_;
402        # Declare the return variable.
403        my $retVal = 1;
404        # Get the lengths.
405        my $len1 = @{$list1};
406        my $len2 = @{$list2};
407        # We fail if the lengths are different.
408        if ($len1 != $len2) {
409            $retVal = 0;
410        } else {
411            # Compare the elements.
412            for (my $i = 0; $retVal && $i < $len1; $i++) {
413                $retVal = ($list1->[$i] eq $list2->[$i]);
414            }
415        }
416        return $retVal;
417    }
418    
419    =head3 MatchListsOfLists
420    
421        my $matchFlag = MatchListsOfLists($list1, $list2);
422    
423    Compares two lists of lists, ensuring that both of the main lists have matching elements (though not
424    necessarily in the same order.
425    
426    =over 4
427    
428    =item list1
429    
430    Reference to the first list of lists.
431    
432    =item list2
433    
434    Reference to the second list of lists.
435    
436    =item RETURN
437    
438    Returns TRUE if every sublist in the first list is found in the second list and vice versa.
439    
440    =back
441    
442    =cut
443    
444    sub MatchListsOfLists {
445        # Get the parameters.
446        my ($list1, $list2) = @_;
447        # Declare the return variable.
448        my $retVal = 1;
449        # Create a hash of the elements in the first list. When we find an element in the
450        # second list that matches an entry in the hash, we delete it. At the end, we return
451        # TRUE if every element in the second list has been found in the hash and there are
452        # no hash entries left.
453        my %list1Hash = ();
454        my $list1Len = @{$list1};
455        for (my $i = 0; $i < $list1Len; $i++) {
456            $list1Hash{$i} = $list1->[$i];
457        }
458        # Loop through the second list.
459        my $list2Len = @{$list2};
460        for (my $i = 0; $i < $list2Len && $retVal; $i++) {
461            my $list2Element = $list2->[$i];
462            # Find a match in the first list.
463            my $matchKey;
464            for (my $j = 0; $j < $list1Len && ! defined $matchKey; $j++) {
465                if (exists $list1Hash{$j}) {
466                    my $list1Element = $list1Hash{$j};
467                    if (MatchLists($list1Element, $list2Element)) {
468                        $matchKey = $j;
469                    }
470                }
471            }
472            # If we found a match, delete it from the hash. Otherwise, we've failed.
473            if (! defined $matchKey) {
474                $retVal = 0;
475            } else {
476                delete $list1Hash{$matchKey};
477            }
478        }
479        # If anything is left in the first hash, it's a failure. (Of course, it may already be
480        # a failure, but that doesn't change anything.)
481        if (scalar(keys %list1Hash)) {
482            $retVal = 0;
483        }
484        # Return the match indication.
485        return $retVal;
486    }
487    
488  1;  1;

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.4

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3