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 = new Test::Harness::Point; 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=cut 74 75sub ok { my $self = shift; $self->{ok} } 76sub set_ok { 77 my $self = shift; 78 my $ok = shift; 79 $self->{ok} = $ok ? 1 : 0; 80} 81sub pass { 82 my $self = shift; 83 84 return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0; 85} 86 87sub number { my $self = shift; $self->{number} } 88sub set_number { my $self = shift; $self->{number} = shift } 89 90sub description { my $self = shift; $self->{description} } 91sub set_description { 92 my $self = shift; 93 $self->{description} = shift; 94 $self->{name} = $self->{description}; # history 95} 96 97sub directive { my $self = shift; $self->{directive} } 98sub 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} 111sub set_directive_type { 112 my $self = shift; 113 $self->{directive_type} = lc shift; 114 $self->{type} = $self->{directive_type}; # History 115} 116sub set_directive_reason { 117 my $self = shift; 118 $self->{directive_reason} = shift; 119} 120sub directive_type { my $self = shift; $self->{directive_type} } 121sub type { my $self = shift; $self->{directive_type} } 122sub directive_reason{ my $self = shift; $self->{directive_reason} } 123sub reason { my $self = shift; $self->{directive_reason} } 124sub is_todo { 125 my $self = shift; 126 my $type = $self->directive_type; 127 return $type && ( $type eq 'todo' ); 128} 129sub is_skip { 130 my $self = shift; 131 my $type = $self->directive_type; 132 return $type && ( $type eq 'skip' ); 133} 134 135sub diagnostics { 136 my $self = shift; 137 return @{$self->{diagnostics}} if wantarray; 138 return join( "\n", @{$self->{diagnostics}} ); 139} 140sub add_diagnostic { my $self = shift; push @{$self->{diagnostics}}, @_ } 141 142 1431; 144