lib/Test/Harness/Point.pm

   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;