← Back to branch summary

~ubuntu-branches/ubuntu/trusty/bioperl/trusty

« back to all changes in this revision

Viewing changes to Bio/Root/Test/Warn.pm

  • Committer: Package Import Robot
  • Author(s): Charles Plessy
  • Date: 2013-09-22 13:39:48 UTC
  • mfrom: (3.1.11 sid)
  • Revision ID: package-import@ubuntu.com-20130922133948-c6z62zegjyp7ztou
Tags: 1.6.922-1
http://bugs.debian.org/722910
* New upstream release.
* Replaces and Breaks grinder (<< 0.5.3-3~) because of overlaping contents.
  Closes: #722910
* Stop Replacing and Breaking bioperl ( << 1.6.9 ): not needed anymore. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
Bio/Root/Test/Warn.pm
1
 
#
2
 
# BioPerl module for Bio::Root::Test::Warn
3
 
#
4
 
# Please direct questions and support issues to <bioperl-l@bioperl.org> 
5
 
#
6
 
# Cared for by Sendu Bala <bix@sendu.me.uk>
7
 
#
8
 
# Copyright Sendu Bala
9
 
#
10
 
# You may distribute this module under the same terms as perl itself
11
 
 
12
 
# POD documentation - main docs before the code
13
 
 
14
 
=head1 NAME
15
 
 
16
 
Bio::Root::Test::Warn - Perl extension to test Bioperl methods for warnings
17
 
 
18
 
=head1 SYNOPSIS
19
 
 
20
 
  use Bio::Root::Test::Warn;
21
 
 
22
 
  warning_is {$bio_object->method()} 'Must supply a parameter', "a missing parameter test";
23
 
  warning_like {$bio_object->method()} qr/Must supply a parameter/i, "a missing parameter test";
24
 
 
25
 
=head1 DESCRIPTION
26
 
 
27
 
This module provides a few convenience methods for testing warning based code.
28
 
 
29
 
See Test::Warn for details.
30
 
 
31
 
You will normally not use this module directly, but have it auto-loaded for you
32
 
by Bio::Root::Test.
33
 
 
34
 
=head1 FEEDBACK
35
 
 
36
 
=head2 Mailing Lists
37
 
 
38
 
User feedback is an integral part of the evolution of this and other
39
 
Bioperl modules. Send your comments and suggestions preferably to
40
 
the Bioperl mailing list.  Your participation is much appreciated.
41
 
 
42
 
  bioperl-l@bioperl.org                  - General discussion
43
 
  http://bioperl.org/wiki/Mailing_lists  - About the mailing lists
44
 
 
45
 
=head2 Support 
46
 
 
47
 
Please direct usage questions or support issues to the mailing list:
48
 
 
49
 
I<bioperl-l@bioperl.org>
50
 
 
51
 
rather than to the module maintainer directly. Many experienced and 
52
 
reponsive experts will be able look at the problem and quickly 
53
 
address it. Please include a thorough description of the problem 
54
 
with code and data examples if at all possible.
55
 
 
56
 
=head2 Reporting Bugs
57
 
 
58
 
Report bugs to the Bioperl bug tracking system to help us keep track
59
 
of the bugs and their resolution. Bug reports can be submitted via
60
 
the web:
61
 
 
62
 
  https://redmine.open-bio.org/projects/bioperl/
63
 
 
64
 
=head1 AUTHOR - Sendu Bala
65
 
 
66
 
Email bix@sendu.me.uk
67
 
 
68
 
=head1 APPENDIX
69
 
 
70
 
The rest of the documentation details each of the object methods.
71
 
Internal methods are usually preceded with a _
72
 
 
73
 
=cut
74
 
 
75
 
package Bio::Root::Test::Warn;
76
 
 
77
 
use strict;
78
 
use warnings;
79
 
use Exporter qw(import);
80
 
 
81
 
use Test::Builder;
82
 
use Test::Warn;
83
 
 
84
 
our @EXPORT = qw(warning_is
85
 
                 warnings_are
86
 
                 warning_like
87
 
                 warnings_like);
88
 
 
89
 
{
90
 
    my $Tester = Test::Builder->new;
91
 
    
92
 
    no warnings 'redefine';
93
 
    sub Test::Warn::_canonical_got_warning {
94
 
        my ($called_from, $msg) = @_;
95
 
        my $warn_kind = $called_from eq 'Carp' ? 'carped' : ($called_from =~ /Bio::/ ? 'Bioperl' : 'warn');
96
 
        
97
 
        my $warning;
98
 
        if ($warn_kind eq 'Bioperl') {
99
 
            ($warning) = $msg =~ /\n--------------------- WARNING ---------------------\nMSG: (.+)\n---------------------------------------------------\n$/m;
100
 
            $warning ||= $msg; # shouldn't ever happen
101
 
        }
102
 
        else {
103
 
            my @warning_stack = split /\n/, $msg;   # some stuff of uplevel is included
104
 
            $warning = $warning_stack[0];
105
 
        }
106
 
        
107
 
        return {$warn_kind => $warning}; # return only the real message
108
 
    }
109
 
    
110
 
    sub Test::Warn::_diag_found_warning {
111
 
        foreach (@_) {
112
 
            if (ref($_) eq 'HASH') {
113
 
                ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
114
 
                              : (${$_}{Bioperl} ? $Tester->diag("found Bioperl warning: ${$_}{Bioperl}")
115
 
                                 : $Tester->diag("found warning: ${$_}{warn}"));
116
 
            } else {
117
 
                $Tester->diag( "found warning: $_" );
118
 
            }
119
 
        }
120
 
        $Tester->diag( "didn't find a warning" ) unless @_;
121
 
    }
122
 
    
123
 
    sub Test::Warn::_cmp_got_to_exp_warning {
124
 
        my ($got_kind, $got_msg) = %{ shift() };
125
 
        my ($exp_kind, $exp_msg) = %{ shift() };
126
 
        return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
127
 
        
128
 
        my $cmp;
129
 
        if ($got_kind eq 'Bioperl') {
130
 
            $cmp = $got_msg =~ /^\Q$exp_msg\E$/;
131
 
        }
132
 
        else {
133
 
            $cmp = $got_msg =~ /^\Q$exp_msg\E at \S+ line \d+\.?$/;
134
 
        }
135
 
        
136
 
        return $cmp;
137
 
    }
138
 
}
139
 
 
140
 
1;