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