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