]>
Commit | Line | Data |
---|---|---|
d8f41ccd A |
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; |