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 => 24);
  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 # tests for _set_from_args()
  83 {
  84         no warnings 'redefine';
  85
  86         # simplest form
  87         local *Bio::Root::Root::new = sub {
  88                 my $class = shift;
  89                 my $self = {};
  90                 bless $self, ref($class) || $class;
  91
  92                 $self->_set_from_args(\@_);
  93
  94                 return $self;
  95         };
  96
  97         $obj = Bio::Root::Root->new(-verbose => 1, t1 => 1, '--Test-2' => 2);
  98         ok ! $obj->can('t1'), 'arg not callable';
  99
 100         # with method creation
 101         local *Bio::Root::Root::new = sub {
 102                 my $class = shift;
 103                 my $self = {};
 104                 bless $self, ref($class) || $class;
 105
 106                 $self->_set_from_args(\@_, -create => 1);
 107
 108                 return $self;
 109         };
 110
 111         $obj = Bio::Root::Root->new(-verbose => 1, t3 => 1, '--Test-4' => 2);
 112         ok $obj->can('t3'), 'arg callable since method was created';
 113         ok $obj->can('test_4'), 'mal-formed arg callable since method was created with good name';
 114
 115         # with method creation, but limited to certain methods
 116         local *Bio::Root::Root::new = sub {
 117                 my $class = shift;
 118                 my $self = {};
 119                 bless $self, ref($class) || $class;
 120
 121                 $self->_set_from_args(\@_, -methods => ['verbose', 't5'], -create => 1);
 122
 123                 return $self;
 124         };
 125
 126         $obj = Bio::Root::Root->new(-verbose => 1, t5 => 1, '--Test-6' => 2);
 127         ok $obj->can('t5'), 'arg callable since method was created';
 128         ok ! $obj->can('test_6'), 'arg not in method list not created';
 129
 130         # with synonyms
 131         local *Bio::Root::Root::new = sub {
 132                 my $class = shift;
 133                 my $self = {};
 134                 bless $self, ref($class) || $class;
 135
 136                 my %args = @_;
 137
 138                 $self->_set_from_args(\%args, -methods => {(verbose => 'v',
 139                                                                                                 test7 => 't7',
 140                                                                                                         test_8 => 't8')},
 141                                                                       -create => 1);
 142
 143                 return $self;
 144         };
 145
 146         $obj = Bio::Root::Root->new(-verbose => 1, t7 => 1, '--Test-8' => 2);
 147         is $obj->verbose, 1, 'verbose was set correctly';
 148         is $obj->t7, 1, 'synonym was set correctly';
 149         is $obj->test7, 1, 'real method of synonym was set correctly';
 150         is $obj->test_8, 2, 'mal-formed arg correctly resolved to created method';
 151         is $obj->t8, 2, 'synonym of set method was set correctly';
 152 }