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