File Coverage

support/Test/Harness/Point.pm
Criterion Covered Total %
statement 60 76 78.9
branch 10 16 62.5
condition 6 12 50.0
subroutine 17 23 73.9
pod 3 21 14.3
total 96 148 64.9


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; cperl-indent-level: 4 -*-
2             package Test::Harness::Point;
3              
4 1     1   15 use strict;
  1         10  
  1         16  
5 1     1   15 use vars qw($VERSION);
  1         9  
  1         1317  
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 50334     50334 1 1930637     my $class = shift;
28 50334         1601959     my $self = bless {}, $class;
29              
30 50334         1279988     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 87284     87284 0 1988426     my $class = shift;
42 87284 50       1588707     my $line = shift or return;
43              
44             # We pulverize the line down into pieces in three parts.
45 87284 100       3728696     my ($not, $number, $extra) = ($line =~ /^(not )?ok\b(?:\s+(\d+))?\s*(.*)/) or return;
46              
47 50334         1089081     my $point = $class->new;
48 50334         1607673     $point->set_number( $number );
49 50334         1680073     $point->set_ok( !$not );
50              
51 50334 100       1710047     if ( $extra ) {
52 2674         55709         my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
53 2674         37078         $description =~ s/^- //; # Test::More puts it in there
54 2674         31320         $point->set_description( $description );
55 2674 100       31737         if ( $directive ) {
56 556         7691             $point->set_directive( $directive );
57                     }
58                 } # if $extra
59              
60 50334         1573098     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 151002     151002 1 3444406 sub ok { my $self = shift; $self->{ok} }
  151002         7157927  
76             sub set_ok {
77 50334     50334 0 1451292     my $self = shift;
78 50334         1580324     my $ok = shift;
79 50334 50       2627606     $self->{ok} = $ok ? 1 : 0;
80             }
81             sub pass {
82 100668     100668 0 2120892     my $self = shift;
83              
84 100668 50 33     3052083     return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
      33        
85             }
86              
87 251670     251670 1 8191310 sub number { my $self = shift; $self->{number} }
  251670         10427628  
88 50334     50334 0 1305870 sub set_number { my $self = shift; $self->{number} = shift }
  50334         1883799  
89              
90 50334     50334 0 1443474 sub description { my $self = shift; $self->{description} }
  50334         1711251  
91             sub set_description {
92 2674     2674 0 26893     my $self = shift;
93 2674         36284     $self->{description} = shift;
94 2674         54105     $self->{name} = $self->{description}; # history
95             }
96              
97 0     0 0 0 sub directive { my $self = shift; $self->{directive} }
  0         0  
98             sub set_directive {
99 556     556 0 4821     my $self = shift;
100 556         6483     my $directive = shift;
101              
102 556         8302     $directive =~ s/^\s+//;
103 556         8857     $directive =~ s/\s+$//;
104 556         6667     $self->{directive} = $directive;
105              
106 556         9453     my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
107 556         261050     $self->set_directive_type( $type );
108 556 50       7066     $reason = "" unless defined $reason;
109 556         27967     $self->{directive_reason} = $reason;
110             }
111             sub set_directive_type {
112 556     556 0 23611     my $self = shift;
113 556         9517     $self->{directive_type} = lc shift;
114 556         14397     $self->{type} = $self->{directive_type}; # History
115             }
116             sub set_directive_reason {
117 0     0 0 0     my $self = shift;
118 0         0     $self->{directive_reason} = shift;
119             }
120 151002     151002 0 4387763 sub directive_type { my $self = shift; $self->{directive_type} }
  151002         5486604  
121 0     0 0 0 sub type { my $self = shift; $self->{directive_type} }
  0         0  
122 50334     50334 0 1552637 sub directive_reason{ my $self = shift; $self->{directive_reason} }
  50334         1831800  
123 0     0 0 0 sub reason { my $self = shift; $self->{directive_reason} }
  0         0  
124             sub is_todo {
125 50334     50334 0 1134011     my $self = shift;
126 50334         1764611     my $type = $self->directive_type;
127 50334   66     2146047     return $type && ( $type eq 'todo' );
128             }
129             sub is_skip {
130 50334     50334 0 1122313     my $self = shift;
131 50334         1373939     my $type = $self->directive_type;
132 50334   66     1832676     return $type && ( $type eq 'skip' );
133             }
134              
135             sub diagnostics {
136 0     0 0       my $self = shift;
137 0 0             return @{$self->{diagnostics}} if wantarray;
  0            
138 0               return join( "\n", @{$self->{diagnostics}} );
  0            
139             }
140 0     0 0   sub add_diagnostic { my $self = shift; push @{$self->{diagnostics}}, @_ }
  0            
  0            
141              
142              
143             1;
144