Commit | Line | Data |
---|---|---|
920dae64 AT |
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 | my $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 | ||
44 | Constructor from a TAP test line, or empty return if the test line | |
45 | is not a test line. | |
46 | ||
47 | =cut | |
48 | ||
49 | sub 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 | ||
74 | Each 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 | ||
84 | sub ok { my $self = shift; $self->{ok} } | |
85 | sub set_ok { | |
86 | my $self = shift; | |
87 | my $ok = shift; | |
88 | $self->{ok} = $ok ? 1 : 0; | |
89 | } | |
90 | sub pass { | |
91 | my $self = shift; | |
92 | ||
93 | return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0; | |
94 | } | |
95 | ||
96 | sub number { my $self = shift; $self->{number} } | |
97 | sub set_number { my $self = shift; $self->{number} = shift } | |
98 | ||
99 | sub description { my $self = shift; $self->{description} } | |
100 | sub set_description { | |
101 | my $self = shift; | |
102 | $self->{description} = shift; | |
103 | $self->{name} = $self->{description}; # history | |
104 | } | |
105 | ||
106 | sub directive { my $self = shift; $self->{directive} } | |
107 | sub 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 | } | |
120 | sub set_directive_type { | |
121 | my $self = shift; | |
122 | $self->{directive_type} = lc shift; | |
123 | $self->{type} = $self->{directive_type}; # History | |
124 | } | |
125 | sub set_directive_reason { | |
126 | my $self = shift; | |
127 | $self->{directive_reason} = shift; | |
128 | } | |
129 | sub directive_type { my $self = shift; $self->{directive_type} } | |
130 | sub type { my $self = shift; $self->{directive_type} } | |
131 | sub directive_reason{ my $self = shift; $self->{directive_reason} } | |
132 | sub reason { my $self = shift; $self->{directive_reason} } | |
133 | sub is_todo { | |
134 | my $self = shift; | |
135 | my $type = $self->directive_type; | |
136 | return $type && ( $type eq 'todo' ); | |
137 | } | |
138 | sub is_skip { | |
139 | my $self = shift; | |
140 | my $type = $self->directive_type; | |
141 | return $type && ( $type eq 'skip' ); | |
142 | } | |
143 | ||
144 | sub diagnostics { | |
145 | my $self = shift; | |
146 | return @{$self->{diagnostics}} if wantarray; | |
147 | return join( "\n", @{$self->{diagnostics}} ); | |
148 | } | |
149 | sub add_diagnostic { my $self = shift; push @{$self->{diagnostics}}, @_ } | |
150 | ||
151 | ||
152 | 1; |