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

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3