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 = Test::Harness::Point->new;
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
33=head1 from_test_line( $line )
34
35Constructor from a TAP test line, or empty return if the test line
36is not a test line.
37
38=cut
39
40sub 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
65Each of the following fields has a getter and setter method.
66
67=over 4
68
69=item * ok
70
71=item * number
72
73=back
74
75=cut
76
77sub ok              { my $self = shift; $self->{ok} }
78sub set_ok          {
79    my $self = shift;
80    my $ok = shift;
81    $self->{ok} = $ok ? 1 : 0;
82}
83sub pass {
84    my $self = shift;
85
86    return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
87}
88
89sub number          { my $self = shift; $self->{number} }
90sub set_number      { my $self = shift; $self->{number} = shift }
91
92sub description     { my $self = shift; $self->{description} }
93sub set_description {
94    my $self = shift;
95    $self->{description} = shift;
96    $self->{name} = $self->{description}; # history
97}
98
99sub directive       { my $self = shift; $self->{directive} }
100sub set_directive   {
101    my $self = shift;
102    my $directive = shift;
103
104    $directive =~ s/^\s+//;
105    $directive =~ s/\s+$//;
106    $self->{directive} = $directive;
107
108    my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
109    $self->set_directive_type( $type );
110    $reason = "" unless defined $reason;
111    $self->{directive_reason} = $reason;
112}
113sub set_directive_type {
114    my $self = shift;
115    $self->{directive_type} = lc shift;
116    $self->{type} = $self->{directive_type}; # History
117}
118sub set_directive_reason {
119    my $self = shift;
120    $self->{directive_reason} = shift;
121}
122sub directive_type  { my $self = shift; $self->{directive_type} }
123sub type            { my $self = shift; $self->{directive_type} }
124sub directive_reason{ my $self = shift; $self->{directive_reason} }
125sub reason          { my $self = shift; $self->{directive_reason} }
126sub is_todo {
127    my $self = shift;
128    my $type = $self->directive_type;
129    return $type && ( $type eq 'todo' );
130}
131sub is_skip {
132    my $self = shift;
133    my $type = $self->directive_type;
134    return $type && ( $type eq 'skip' );
135}
136
137sub diagnostics     {
138    my $self = shift;
139    return @{$self->{diagnostics}} if wantarray;
140    return join( "\n", @{$self->{diagnostics}} );
141}
142sub add_diagnostic  { my $self = shift; push @{$self->{diagnostics}}, @_ }
143
144
1451;
146