1# -*-Perl-*- Test Harness script for Bioperl 2# $Id$ 3 4use strict; 5 6BEGIN { 7 use Bio::Root::Test; 8 9 test_begin(-tests => 35); 10 11 use_ok('Bio::Root::Storable'); 12} 13 14foreach my $mode( "BINARY", "ASCII" ){ 15 if( $mode eq "ASCII" ){ 16 no warnings; 17 $Bio::Root::Storable::BINARY = 0; 18 } 19 20 #------------------------------ 21 # Test the easy bits that don't need file IO 22 my $obj = Bio::Root::Storable->new(); 23 ok defined($obj) && $obj->isa('Bio::Root::Storable'); 24 25 eval { $obj->throw('Testing throw') }; 26 ok $@ =~ /Testing throw/; # 'throw failed'; 27 28 $obj->{_test} = "_TEST"; # Provide test attributes 29 $obj->{__test} = "__TEST"; # 30 31 my $state = $obj->serialise; 32 ok length($state) > 0; 33 34 my $clone = $obj->clone; 35 ok defined($clone) and $clone->isa('Bio::Root::Storable'); 36 ok $clone->{_test} eq "_TEST" && $clone->{__test} eq "__TEST"; 37 38 #------------------------------ 39 # Test standard file IO 40 my $file = $obj->store; 41 ok $file && -f $obj->statefile; 42 43 my $retrieved; 44 eval { $retrieved = Bio::Root::Storable->retrieve( $file ) }; 45 ok defined($retrieved) && $retrieved->isa('Bio::Root::Storable'); 46 ok $retrieved->{_test} eq "_TEST" && ! exists $retrieved->{__test}; 47 48 my $skel = $obj->new_retrievable; 49 ok defined($skel) && $skel->isa('Bio::Root::Storable'); 50 ok ! exists $skel->{_test} && ! exists $skel->{__test}; 51 ok $skel->retrievable; 52 53 eval { $skel->retrieve }; 54 ok ! $skel->retrievable; 55 ok $skel->{_test} eq "_TEST" && ! exists $skel->{__test}; 56 57 my $obj2 = Bio::Root::Storable->new(); 58 $obj2->template('TEST_XXXXXX'); 59 $obj2->suffix('.state'); 60 my $file2 = $obj2->store; 61 ok $file2 =~ /TEST_(\w{6})?\.state$/ and -f $file2; 62 63 #------------------------------ 64 # Test recursive file IO 65 $obj->{_test_lazy} = $obj2; 66 $obj->store; 67 my $retrieved2; 68 eval { $retrieved2 = Bio::Root::Storable->retrieve( $obj->token ) }; 69 ok $retrieved2->{_test_lazy} && $retrieved2->{_test_lazy}->retrievable; 70 71 #------------------------------ 72 # Clean up 73 # Should only be 2 object files; all others were clones in one way or another 74 $obj->remove; 75 ok ! -f $obj->statefile; 76 $obj2->remove; 77 ok ! -f $obj2->statefile; 78} 79