t/Root/RootI.t

   1 # -*-Perl-*- Test Harness script for Bioperl
   2 # $Id$
   3
   4 use strict;
   5
   6 BEGIN {
   7     use lib '.';
   8     use Bio::Root::Test;
   9
  10     test_begin(-tests => 61);
  11
  12     use_ok 'Bio::Root::Root';
  13 }
  14
  15 ok my $obj = Bio::Root::Root->new();
  16 isa_ok $obj, 'Bio::Root::RootI';
  17
  18 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'throw failed';
  19
  20 # test throw_not_implemented()
  21 throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION: Bio::Root::NotImplemented/;
  22
  23 {
  24     package Bio::FooI;
  25     use base qw(Bio::Root::RootI);
  26     sub new {
  27             my $class = shift;
  28             my $self = {};
  29             bless $self, ref($class) || $class;
  30             return $self;
  31     };
  32 }
  33 $obj = Bio::FooI->new();
  34 throws_ok { $obj->throw_not_implemented() } qr/EXCEPTION /;
  35 $obj = Bio::Root::Root->new();
  36
  37 # doesn't work in perl 5.00405
  38 #my $val;
  39 #eval {
  40 #    my ($tfh,$tfile) = $obj->tempfile();
  41 #    local * STDERR = $tfh;
  42 #    $obj->warn('Testing warn');
  43 #    close $tfh;
  44 #    open(IN, $tfile) or die("cannot open $tfile");
  45 #    $val = join("", <IN>) ;
  46 #    close IN;
  47 #    unlink $tfile;
  48 #};
  49 #ok $val =~ /Testing warn/;
  50 #'verbose(0) warn did not work properly' . $val;
  51
  52 $obj->verbose(-1);
  53 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(-1) throw did not work properly' . $@;
  54
  55 lives_ok { $obj->warn('Testing warn') };
  56
  57 $obj->verbose(1);
  58 throws_ok { $obj->throw('Testing throw') } qr/Testing throw/;# 'verbose(1) throw did not work properly' . $@;
  59
  60 # doesn't work in perl 5.00405
  61 #undef $val;
  62 #eval {
  63 #    my ($tfh,$tfile) = $obj->tempfile();
  64 #    local * STDERR = $tfh;
  65 #    $obj->warn('Testing warn');
  66 #    close $tfh;
  67 #    open(IN, $tfile) or die("cannot open $tfile");
  68 #    $val = join("", <IN>);
  69 #    close IN;
  70 #    unlink $tfile;
  71 #};
  72 #ok $val =~ /Testing warn/;# 'verbose(1) warn did not work properly' . $val;
  73
  74 my @stack = $obj->stack_trace();
  75 is scalar @stack, 2;
  76
  77 my $verbobj = Bio::Root::Root->new(-verbose=>1,-strict=>1);
  78 is $verbobj->verbose(), 1;
  79
  80 $Bio::Root::Root::DEBUG = 1;
  81 my $seq = Bio::Root::Root->new();
  82 is $seq->verbose, 1;
  83
  84 # test for bug #1343
  85 my @vals = Bio::Root::RootI->_rearrange([qw(apples pears)],
  86                                         -apples => 'up the',
  87                                         -pears  => 'stairs');
  88 is shift @vals, 'up the';
  89 is shift @vals, 'stairs';
  90
  91 # test deprecated()
  92
  93 # class method
  94 {
  95     local $Bio::Root::Root::VERSION = 8.9;
  96     warning_like{ Bio::Root::Root->deprecated('Test1') } qr/Test1/, 'simple';
  97     warning_like{ Bio::Root::Root->deprecated(-message => 'Test2') } qr/Test2/;
  98     warning_like{ Bio::Root::Root->deprecated('Test3', 999.999) } qr/Test3/,
  99         'warns for versions below current version';
 100     warning_like{ Bio::Root::Root->deprecated(-message => 'Test4',
 101                                               -version => 999.999) } qr/Test4/,
 102         'warns for versions below current version';
 103     throws_ok{ Bio::Root::Root->deprecated('Test5', 0.001) } qr/Test5/,
 104         'throws for versions above current version';
 105     throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6',
 106                                        -version => 0.001) } qr/Test6/,
 107         'throws for versions above current version';
 108
 109     throws_ok{ Bio::Root::Root->deprecated(-message => 'Test6',
 110                                            -version => $Bio::Root::Root::VERSION) } qr/Test6/,
 111         'throws for versions equal to current version';
 112
 113     # object method
 114     my $root = Bio::Root::Root->new();
 115     warning_like{ $root->deprecated('Test1') } qr/Test1/, 'simple';
 116     warning_like{ $root->deprecated(-message => 'Test2') } qr/Test2/, 'simple';
 117     warning_like{ $root->deprecated('Test3', 999.999) } qr/Test3/,
 118         'warns for versions below current version';
 119     warning_like{ $root->deprecated(-message => 'Test4',
 120                                     -version => 999.999) } qr/Test4/,
 121                                 'warns for versions below current version';
 122     throws_ok{ $root->deprecated('Test5', 0.001) } qr/Test5/,
 123       'throws for versions above current version';
 124     throws_ok{ $root->deprecated(-message => 'Test6',
 125                                  -version => 0.001) } qr/Test6/,
 126                              'throws for versions above current version';
 127
 128 }
 129
 130 # tests for _set_from_args()
 131 # Let's not pollute Bio::Root::Root namespace if possible
 132 # Create temp classes instead which inherit Bio::Root::Root, then test
 133
 134 {
 135
 136     package Bio::Foo1;
 137     use base qw(Bio::Root::Root);
 138     our $VERSION = '2.00';
 139     sub new {
 140         my $class = shift;
 141         my $self = {};
 142         bless $self, ref($class) || $class;
 143
 144         $self->_set_from_args(\@_);
 145
 146         return $self;
 147     };
 148 }
 149
 150 $obj = Bio::Foo1->new(-verbose => 1, t1 => 1, '--Test-2' => 2);
 151 #ok ! $obj->can('t1'), 'arg not callable';
 152
 153 {
 154
 155     package Bio::Foo2;
 156     use base qw(Bio::Root::Root);
 157     sub new {
 158         my $class = shift;
 159         my $self = {};
 160         bless $self, ref($class) || $class;
 161
 162         $self->_set_from_args(\@_, -create => 1);
 163
 164         return $self;
 165     };
 166
 167 }
 168
 169 $obj = Bio::Foo2->new(-verbose => 1, t3 => 1, '--Test-4' => 2);
 170 ok $obj->can('t3'), 'arg callable since method was created';
 171 ok $obj->can('test_4'), 'mal-formed arg callable since method was created with good name';
 172 for my $m (qw(t3 test_4)) {
 173     can_ok('Bio::Foo2',$m);
 174     ok ! Bio::Root::Root->can($m), "Methods don't pollute original Bio::Root::Root namespace";
 175 }
 176
 177 {
 178     package Bio::Foo3;
 179     use base qw(Bio::Root::Root);
 180     sub new {
 181         my $class = shift;
 182         my $self = {};
 183         bless $self, ref($class) || $class;
 184
 185         $self->_set_from_args(\@_, -methods => ['verbose', 't5'], -create => 1);
 186
 187         return $self;
 188     };
 189 }
 190
 191 $obj = Bio::Foo3->new(-verbose => 1, t5 => 1, '--Test-6' => 2);
 192 can_ok $obj, 't5';
 193 ok ! $obj->can('test_6'), 'arg not in method list not created';
 194
 195 can_ok ('Bio::Foo3','t5');
 196 ok ! UNIVERSAL::can('Bio::Root::Root','t5'), "Methods don't pollute original Bio::Root::Root namespace";
 197
 198 {
 199     package Bio::Foo4;
 200     use base qw(Bio::Root::Root);
 201     sub new {
 202             my $class = shift;
 203             my $self = {};
 204             bless $self, ref($class) || $class;
 205
 206             my %args = @_;
 207
 208             $self->_set_from_args(\%args, -methods => {(verbose => 'v',
 209                                                         test7 => 't7',
 210                                                         test_8 => 't8')},
 211                                           -create => 1);
 212
 213             return $self;
 214     };
 215 }
 216
 217 # with synonyms
 218
 219 $obj = Bio::Foo4->new(-verbose => 1, t7 => 1, '--Test-8' => 2);
 220 is $obj->verbose, 1, 'verbose was set correctly';
 221 is $obj->t7, 1, 'synonym was set correctly';
 222 is $obj->test7, 1, 'real method of synonym was set correctly';
 223 is $obj->test_8, 2, 'mal-formed arg correctly resolved to created method';
 224 is $obj->t8, 2, 'synonym of set method was set correctly';
 225
 226 for my $m (qw(t7 test7 test_8 t8)) {
 227     can_ok 'Bio::Foo4', $m;
 228     ok ! UNIVERSAL::can('Bio::Root::Root','t7'), "Methods don't pollute original Bio::Root::Root namespace";
 229 }
 230
 231 # test basic Root::clone()
 232
 233 my $clone = $obj->clone;
 234
 235 is $clone->t7, $obj->t7, 'clone';
 236 is $clone->test7, $obj->test7, 'clone';
 237 is $clone->test_8, $obj->test_8, 'clone';
 238 $clone->test_8('xyz');
 239 isnt $clone->test_8, $obj->test_8, 'clone changed, original didn\'t';
 240
 241 # test Root::clone() with parameter passing, only works for methods
 242 # (introspection via can())
 243
 244 my $clone2 = $obj->clone(-t7 => 'foo');
 245
 246 is $clone2->t7, 'foo', 'parameters passed to clone() modify object';
 247 is $obj->t7, 1, 'original is not modified';
 248
 249
 250
 251 # test deprecations using start_version
 252 {
 253     package Bio::Foo5;
 254     use base qw(Bio::Root::Root);
 255
 256     our $v = '18.001';
 257     our $VERSION = $v;
 258
 259     sub not_good {
 260         my $self = shift;
 261         $self->deprecated(-message => 'This is not good',
 262                           -warn_version  => $v,
 263                           -throw_version => $v + 0.001);
 264     }
 265
 266     sub not_good2 {
 267         my $self = shift;
 268         # note, due to _rearrange, ordering is throw version, then warn version
 269         $self->deprecated('This is not good',$v + 0.001,$v);
 270     }
 271
 272     sub really_not_good {
 273         my $self = shift;
 274         $self->deprecated(-message => 'This is really not good',
 275                           -warn_version  => $v - 0.001,
 276                           -throw_version => $v,);
 277     }
 278
 279     # version is the same as throw_version (and vice versa)
 280     sub still_very_bad {
 281         my $self = shift;
 282         $self->deprecated(-message => 'This is still very bad',
 283                           -warn_version  => $v - 0.001,
 284                           -version => $v);
 285     }
 286
 287     sub okay_for_now {
 288         my $self = shift;
 289         $self->deprecated(-message => 'This is okay for now',
 290                           -warn_version  => $v + 0.001,
 291                           -throw_version => $v + 0.002);
 292     }
 293 }
 294
 295 my $foo = Bio::Foo5->new();
 296
 297 warning_like{ $foo->not_good } qr/This is not good/,
 298     'warns for versions >= current version';
 299 # this tests the three-arg (non-named) form just to make sure it works, even
 300 # though we probably won't support it
 301 warning_like{ $foo->not_good2 } qr/This is not good/,
 302     'warns for versions >= current version';
 303
 304 throws_ok { $foo->really_not_good } qr/This is really not good/,
 305     'throws for versions >= current version';
 306 throws_ok { $foo->still_very_bad } qr/This is still very bad/,
 307     'throws for versions >= current version';
 308 lives_ok { $foo->okay_for_now } 'No warnings/exceptions below current version';
 309
 310