1 # -*- Mode: cperl; cperl-indent-level: 4 -*-
2 package Test::Harness::Point;
10 Test::Harness::Point - object for tracking a single test point
14 One Test::Harness::Point object represents a single test point.
20 my $point = new Test::Harness::Point;
22 Create a test point object.
28 my $self = bless {}, $class;
33 my $test_line_regex = qr/
37 (?:\s+(\d+))? # optional test number
42 =head1 from_test_line( $line )
44 Constructor from a TAP test line, or empty return if the test line
51 my $line = shift or return;
53 # We pulverize the line down into pieces in three parts.
54 my ($not, $number, $extra) = ($line =~ $test_line_regex ) or return;
56 my $point = $class->new;
57 $point->set_number( $number );
58 $point->set_ok( !$not );
61 my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
62 $description =~ s/^- //; # Test::More puts it in there
63 $point->set_description( $description );
65 $point->set_directive( $directive );
74 Each of the following fields has a getter and setter method.
84 sub ok { my $self = shift; $self->{ok} }
88 $self->{ok} = $ok ? 1 : 0;
93 return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
96 sub number { my $self = shift; $self->{number} }
97 sub set_number { my $self = shift; $self->{number} = shift }
99 sub description { my $self = shift; $self->{description} }
100 sub set_description {
102 $self->{description} = shift;
103 $self->{name} = $self->{description}; # history
106 sub directive { my $self = shift; $self->{directive} }
109 my $directive = shift;
111 $directive =~ s/^\s+//;
112 $directive =~ s/\s+$//;
113 $self->{directive} = $directive;
115 my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
116 $self->set_directive_type( $type );
117 $reason = "" unless defined $reason;
118 $self->{directive_reason} = $reason;
120 sub set_directive_type {
122 $self->{directive_type} = lc shift;
123 $self->{type} = $self->{directive_type}; # History
125 sub set_directive_reason {
127 $self->{directive_reason} = shift;
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} }
135 my $type = $self->directive_type;
136 return $type && ( $type eq 'todo' );
140 my $type = $self->directive_type;
141 return $type && ( $type eq 'skip' );
146 return @{$self->{diagnostics}} if wantarray;
147 return join( "\n", @{$self->{diagnostics}} );
149 sub add_diagnostic { my $self = shift; push @{$self->{diagnostics}}, @_ }