t/Root/RootI.t

   1 # -*-Perl-*- Test Harness script for Bioperl
   2 # $Id$
   3
   4 use strict;
   5
   6 BEGIN {
   7     use Bio::Root::Test;
   8
   9     test_begin(-tests => 43);
  10
  11     use_ok 'Bio::Root::Root';
  12 }
  13
  14 ok my $obj = Bio::Root::Root->new();
  15 isa_ok $obj, 'Bio::Root::RootI';
  16
  17 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'throw failed';
  18
  19 # test throw_not_implemented()
  20 throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION: Bio::Root::NotImplemented/;
  21
  22 {
  23     package Bio::FooI;
  24     use base qw(Bio::Root::RootI);
  25     sub new {
  26             my $class = shift;
  27             my $self = {};
  28             bless $self, ref($class) || $class;
  29             return $self;
  30     };
  31 }
  32 $obj = Bio::FooI->new();
  33 throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION /;
  34 $obj = Bio::Root::Root->new();
  35
  36 # doesn't work in perl 5.00405
  37 #my $val;
  38 #eval {
  39 #    my ($tfh,$tfile) = $obj->tempfile();
  40 #    local * STDERR = $tfh;
  41 #    $obj->warn('Testing warn');
  42 #    close $tfh;
  43 #    open(IN, $tfile) or die("cannot open $tfile");
  44 #    $val = join("", <IN>) ;
  45 #    close IN;
  46 #    unlink $tfile;
  47 #};
  48 #ok $val =~ /Testing warn/;
  49 #'verbose(0) warn did not work properly' . $val;
  50
  51 $obj->verbose(-1);
  52 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(-1) throw did not work properly' . $@;
  53
  54 lives_ok { $obj->warn('Testing warn') };
  55
  56 $obj->verbose(1);
  57 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(1) throw did not work properly' . $@;
  58
  59 # doesn't work in perl 5.00405
  60 #undef $val;
  61 #eval {
  62 #    my ($tfh,$tfile) = $obj->tempfile();
  63 #    local * STDERR = $tfh;
  64 #    $obj->warn('Testing warn');
  65 #    close $tfh;
  66 #    open(IN, $tfile) or die("cannot open $tfile");
  67 #    $val = join("", <IN>);
  68 #    close IN;
  69 #    unlink $tfile;
  70 #};
  71 #ok $val =~ /Testing warn/;# 'verbose(1) warn did not work properly' . $val;
  72
  73 my @stack = $obj->stack_trace();
  74 is scalar @stack, 2;
  75
  76 my $verbobj = Bio::Root::Root->new(-verbose=>1,-strict=>1);
  77 is $verbobj->verbose(), 1;
  78
  79 $Bio::Root::Root::DEBUG = 1;
  80 my $seq = Bio::Root::Root->new();
  81 is $seq->verbose, 1;
  82
  83 # test for bug #1343
  84 my @vals = Bio::Root::RootI->_rearrange([qw(apples pears)],
  85                                         -apples => 'up the',
  86                                         -pears  => 'stairs');
  87 is shift @vals, 'up the';
  88 is shift @vals, 'stairs';
  89
  90 # tests for _set_from_args()
  91 # Let's not pollute Bio::Root::Root namespace if possible
  92 # Create temp classes instead which inherit Bio::Root::Root, then test
  93
  94 {
  95
  96     package Bio::Foo1;
  97     use base qw(Bio::Root::Root);
  98     our $VERSION = '2.00';
  99     sub new {
 100         my $class = shift;
 101         my $self = {};
 102         bless $self, ref($class) || $class;
 103
 104         $self->_set_from_args(\@_);
 105
 106         return $self;
 107     };
 108 }
 109
 110 $obj = Bio::Foo1->new(-verbose => 1, t1 => 1, '--Test-2' => 2);
 111 #ok ! $obj->can('t1'), 'arg not callable';
 112
 113 {
 114
 115     package Bio::Foo2;
 116     use base qw(Bio::Root::Root);
 117     sub new {
 118         my $class = shift;
 119         my $self = {};
 120         bless $self, ref($class) || $class;
 121
 122         $self->_set_from_args(\@_, -create => 1);
 123
 124         return $self;
 125     };
 126
 127 }
 128
 129 $obj = Bio::Foo2->new(-verbose => 1, t3 => 1, '--Test-4' => 2);
 130 ok $obj->can('t3'), 'arg callable since method was created';
 131 ok $obj->can('test_4'), 'mal-formed arg callable since method was created with good name';
 132 for my $m (qw(t3 test_4)) {
 133     can_ok('Bio::Foo2',$m);
 134     ok ! Bio::Root::Root->can($m), "Methods don't pollute original Bio::Root::Root namespace";
 135 }
 136
 137 {
 138     package Bio::Foo3;
 139     use base qw(Bio::Root::Root);
 140     sub new {
 141         my $class = shift;
 142         my $self = {};
 143         bless $self, ref($class) || $class;
 144
 145         $self->_set_from_args(\@_, -methods => ['verbose', 't5'], -create => 1);
 146
 147         return $self;
 148     };
 149 }
 150
 151 $obj = Bio::Foo3->new(-verbose => 1, t5 => 1, '--Test-6' => 2);
 152 can_ok $obj, 't5';
 153 ok ! $obj->can('test_6'), 'arg not in method list not created';
 154
 155 can_ok ('Bio::Foo3','t5');
 156 ok ! UNIVERSAL::can('Bio::Root::Root','t5'), "Methods don't pollute original Bio::Root::Root namespace";
 157
 158 {
 159     package Bio::Foo4;
 160     use base qw(Bio::Root::Root);
 161     sub new {
 162             my $class = shift;
 163             my $self = {};
 164             bless $self, ref($class) || $class;
 165
 166             my %args = @_;
 167
 168             $self->_set_from_args(\%args, -methods => {(verbose => 'v',
 169                                                         test7 => 't7',
 170                                                         test_8 => 't8')},
 171                                           -create => 1);
 172
 173             return $self;
 174     };
 175 }
 176
 177 # with synonyms
 178
 179 $obj = Bio::Foo4->new(-verbose => 1, t7 => 1, '--Test-8' => 2);
 180 is $obj->verbose, 1, 'verbose was set correctly';
 181 is $obj->t7, 1, 'synonym was set correctly';
 182 is $obj->test7, 1, 'real method of synonym was set correctly';
 183 is $obj->test_8, 2, 'mal-formed arg correctly resolved to created method';
 184 is $obj->t8, 2, 'synonym of set method was set correctly';
 185
 186 for my $m (qw(t7 test7 test_8 t8)) {
 187     can_ok 'Bio::Foo4', $m;
 188     ok ! UNIVERSAL::can('Bio::Root::Root','t7'), "Methods don't pollute original Bio::Root::Root namespace";
 189 }
 190
 191 # test basic Root::clone()
 192
 193 my $clone = $obj->clone;
 194
 195 is $clone->t7, $obj->t7, 'clone';
 196 is $clone->test7, $obj->test7, 'clone';
 197 is $clone->test_8, $obj->test_8, 'clone';
 198 $clone->test_8('xyz');
 199 isnt $clone->test_8, $obj->test_8, 'clone changed, original didn\'t';
 200
 201 # test Root::clone() with parameter passing, only works for methods
 202 # (introspection via can())
 203
 204 my $clone2 = $obj->clone(-t7 => 'foo');
 205
 206 is $clone2->t7, 'foo', 'parameters passed to clone() modify object';
 207 is $obj->t7, 1, 'original is not modified';