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