← Back to branch summary

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

« back to all changes in this revision

Viewing changes to t/lib/Test/Harness/Point.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:
t/lib/Test/Harness/Point.pm
1
 
# -*- Mode: cperl; cperl-indent-level: 4 -*-
2
 
package Test::Harness::Point;
3
 
 
4
 
use strict;
5
 
use vars qw($VERSION);
6
 
$VERSION = '0.01';
7
 
 
8
 
=head1 NAME
9
 
 
10
 
Test::Harness::Point - object for tracking a single test point
11
 
 
12
 
=head1 SYNOPSIS
13
 
 
14
 
One Test::Harness::Point object represents a single test point.
15
 
 
16
 
=head1 CONSTRUCTION
17
 
 
18
 
=head2 new()
19
 
 
20
 
    my $point = new Test::Harness::Point;
21
 
 
22
 
Create a test point object.
23
 
 
24
 
=cut
25
 
 
26
 
sub new {
27
 
    my $class = shift;
28
 
    my $self  = bless {}, $class;
29
 
 
30
 
    return $self;
31
 
}
32
 
 
33
 
=head1 from_test_line( $line )
34
 
 
35
 
Constructor from a TAP test line, or empty return if the test line
36
 
is not a test line.
37
 
 
38
 
=cut
39
 
 
40
 
sub from_test_line  {
41
 
    my $class = shift;
42
 
    my $line = shift or return;
43
 
 
44
 
    # We pulverize the line down into pieces in three parts.
45
 
    my ($not, $number, $extra) = ($line =~ /^(not )?ok\b(?:\s+(\d+))?\s*(.*)/) or return;
46
 
 
47
 
    my $point = $class->new;
48
 
    $point->set_number( $number );
49
 
    $point->set_ok( !$not );
50
 
 
51
 
    if ( $extra ) {
52
 
        my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
53
 
        $description =~ s/^- //; # Test::More puts it in there
54
 
        $point->set_description( $description );
55
 
        if ( $directive ) {
56
 
            $point->set_directive( $directive );
57
 
        }
58
 
    } # if $extra
59
 
 
60
 
    return $point;
61
 
} # from_test_line()
62
 
 
63
 
=head1 ACCESSORS
64
 
 
65
 
Each of the following fields has a getter and setter method.
66
 
 
67
 
=over 4
68
 
 
69
 
=item * ok
70
 
 
71
 
=item * number
72
 
 
73
 
=cut
74
 
 
75
 
sub ok              { my $self = shift; $self->{ok} }
76
 
sub set_ok          {
77
 
    my $self = shift;
78
 
    my $ok = shift;
79
 
    $self->{ok} = $ok ? 1 : 0;
80
 
}
81
 
sub pass {
82
 
    my $self = shift;
83
 
 
84
 
    return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
85
 
}
86
 
 
87
 
sub number          { my $self = shift; $self->{number} }
88
 
sub set_number      { my $self = shift; $self->{number} = shift }
89
 
 
90
 
sub description     { my $self = shift; $self->{description} }
91
 
sub set_description {
92
 
    my $self = shift;
93
 
    $self->{description} = shift;
94
 
    $self->{name} = $self->{description}; # history
95
 
}
96
 
 
97
 
sub directive       { my $self = shift; $self->{directive} }
98
 
sub set_directive   {
99
 
    my $self = shift;
100
 
    my $directive = shift;
101
 
 
102
 
    $directive =~ s/^\s+//;
103
 
    $directive =~ s/\s+$//;
104
 
    $self->{directive} = $directive;
105
 
 
106
 
    my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
107
 
    $self->set_directive_type( $type );
108
 
    $reason = "" unless defined $reason;
109
 
    $self->{directive_reason} = $reason;
110
 
}
111
 
sub set_directive_type {
112
 
    my $self = shift;
113
 
    $self->{directive_type} = lc shift;
114
 
    $self->{type} = $self->{directive_type}; # History
115
 
}
116
 
sub set_directive_reason {
117
 
    my $self = shift;
118
 
    $self->{directive_reason} = shift;
119
 
}
120
 
sub directive_type  { my $self = shift; $self->{directive_type} }
121
 
sub type            { my $self = shift; $self->{directive_type} }
122
 
sub directive_reason{ my $self = shift; $self->{directive_reason} }
123
 
sub reason          { my $self = shift; $self->{directive_reason} }
124
 
sub is_todo {
125
 
    my $self = shift;
126
 
    my $type = $self->directive_type;
127
 
    return $type && ( $type eq 'todo' );
128
 
}
129
 
sub is_skip {
130
 
    my $self = shift;
131
 
    my $type = $self->directive_type;
132
 
    return $type && ( $type eq 'skip' );
133
 
}
134
 
 
135
 
sub diagnostics     {
136
 
    my $self = shift;
137
 
    return @{$self->{diagnostics}} if wantarray;
138
 
    return join( "\n", @{$self->{diagnostics}} );
139
 
}
140
 
sub add_diagnostic  { my $self = shift; push @{$self->{diagnostics}}, @_ }
141
 
 
142
 
 
143
 
1;