lib/perl5/5.8.8/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 my $test_line_regex = qr/
  34     ^
  35     (not\ )?               # failure?
  36     ok\b
  37     (?:\s+(\d+))?         # optional test number
  38     \s*
  39     (.*)                  # and the rest
  40 /ox;
  41
  42 =head1 from_test_line( $line )
  43
  44 Constructor from a TAP test line, or empty return if the test line
  45 is not a test line.
  46
  47 =cut
  48
  49 sub from_test_line  {
  50     my $class = shift;
  51     my $line = shift or return;
  52
  53     # We pulverize the line down into pieces in three parts.
  54     my ($not, $number, $extra) = ($line =~ $test_line_regex ) or return;
  55
  56     my $point = $class->new;
  57     $point->set_number( $number );
  58     $point->set_ok( !$not );
  59
  60     if ( $extra ) {
  61         my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
  62         $description =~ s/^- //; # Test::More puts it in there
  63         $point->set_description( $description );
  64         if ( $directive ) {
  65             $point->set_directive( $directive );
  66         }
  67     } # if $extra
  68
  69     return $point;
  70 } # from_test_line()
  71
  72 =head1 ACCESSORS
  73
  74 Each of the following fields has a getter and setter method.
  75
  76 =over 4
  77
  78 =item * ok
  79
  80 =item * number
  81
  82 =cut
  83
  84 sub ok              { my $self = shift; $self->{ok} }
  85 sub set_ok          {
  86     my $self = shift;
  87     my $ok = shift;
  88     $self->{ok} = $ok ? 1 : 0;
  89 }
  90 sub pass {
  91     my $self = shift;
  92
  93     return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
  94 }
  95
  96 sub number          { my $self = shift; $self->{number} }
  97 sub set_number      { my $self = shift; $self->{number} = shift }
  98
  99 sub description     { my $self = shift; $self->{description} }
 100 sub set_description {
 101     my $self = shift;
 102     $self->{description} = shift;
 103     $self->{name} = $self->{description}; # history
 104 }
 105
 106 sub directive       { my $self = shift; $self->{directive} }
 107 sub set_directive   {
 108     my $self = shift;
 109     my $directive = shift;
 110
 111     $directive =~ s/^\s+//;
 112     $directive =~ s/\s+$//;
 113     $self->{directive} = $directive;
 114
 115     my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
 116     $self->set_directive_type( $type );
 117     $reason = "" unless defined $reason;
 118     $self->{directive_reason} = $reason;
 119 }
 120 sub set_directive_type {
 121     my $self = shift;
 122     $self->{directive_type} = lc shift;
 123     $self->{type} = $self->{directive_type}; # History
 124 }
 125 sub set_directive_reason {
 126     my $self = shift;
 127     $self->{directive_reason} = shift;
 128 }
 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} }
 133 sub is_todo {
 134     my $self = shift;
 135     my $type = $self->directive_type;
 136     return $type && ( $type eq 'todo' );
 137 }
 138 sub is_skip {
 139     my $self = shift;
 140     my $type = $self->directive_type;
 141     return $type && ( $type eq 'skip' );
 142 }
 143
 144 sub diagnostics     {
 145     my $self = shift;
 146     return @{$self->{diagnostics}} if wantarray;
 147     return join( "\n", @{$self->{diagnostics}} );
 148 }
 149 sub add_diagnostic  { my $self = shift; push @{$self->{diagnostics}}, @_ }
 150
 151
 152 1;