[Summary view] [Print] [Text view]

   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;