lib/TAP/Parser/Result.pm

   1 package TAP::Parser::Result;
   2
   3 use strict;
   4 use vars qw($VERSION);
   5
   6 use TAP::Parser::Result::Bailout ();
   7 use TAP::Parser::Result::Comment ();
   8 use TAP::Parser::Result::Plan    ();
   9 use TAP::Parser::Result::Test    ();
  10 use TAP::Parser::Result::Unknown ();
  11 use TAP::Parser::Result::Version ();
  12 use TAP::Parser::Result::YAML    ();
  13
  14 BEGIN {
  15     no strict 'refs';
  16     foreach my $token (qw( plan comment test bailout version unknown yaml )) {
  17         my $method = "is_$token";
  18         *$method = sub { return $token eq shift->type };
  19     }
  20 }
  21
  22 ##############################################################################
  23
  24 =head1 NAME
  25
  26 TAP::Parser::Result - TAP::Parser output
  27
  28 =head1 VERSION
  29
  30 Version 3.06
  31
  32 =cut
  33
  34 $VERSION = '3.06';
  35
  36 =head2 DESCRIPTION
  37
  38 This is merely a factory class which returns an object representing the
  39 current bit of test data from TAP (usually a line).  It's for internal use
  40 only and should not be relied upon.
  41
  42 =cut
  43
  44 # note that this is bad.  Makes it very difficult to subclass, but then, it
  45 # would be a lot of work to subclass this system.
  46 my %class_for = (
  47     plan    => 'TAP::Parser::Result::Plan',
  48     test    => 'TAP::Parser::Result::Test',
  49     comment => 'TAP::Parser::Result::Comment',
  50     bailout => 'TAP::Parser::Result::Bailout',
  51     version => 'TAP::Parser::Result::Version',
  52     unknown => 'TAP::Parser::Result::Unknown',
  53     yaml    => 'TAP::Parser::Result::YAML',
  54 );
  55
  56 ##############################################################################
  57
  58 =head2 METHODS
  59
  60 =head3 C<new>
  61
  62   my $result = TAP::Parser::Result->new($token);
  63
  64 Returns an instance the appropriate class for the test token passed in.
  65
  66 =cut
  67
  68 sub new {
  69     my ( $class, $token ) = @_;
  70     my $type = $token->{type};
  71     return bless $token => $class_for{$type}
  72       if exists $class_for{$type};
  73     require Carp;
  74
  75     # this should never happen!
  76     Carp::croak("Could not determine class for\n$token->{type}");
  77 }
  78
  79 =head2 Boolean methods
  80
  81 The following methods all return a boolean value and are to be overridden in
  82 the appropriate subclass.
  83
  84 =over 4
  85
  86 =item * C<is_plan>
  87
  88 Indicates whether or not this is the test plan line.
  89
  90  1..3
  91
  92 =item * C<is_test>
  93
  94 Indicates whether or not this is a test line.
  95
  96  is $foo, $bar, $description;
  97
  98 =item * C<is_comment>
  99
 100 Indicates whether or not this is a comment.
 101
 102  # this is a comment
 103
 104 =item * C<is_bailout>
 105
 106 Indicates whether or not this is bailout line.
 107
 108  Bail out! We're out of dilithium crystals.
 109
 110 =item * C<is_version>
 111
 112 Indicates whether or not this is a TAP version line.
 113
 114  TAP version 4
 115
 116 =item * C<is_unknown>
 117
 118 Indicates whether or not the current line could be parsed.
 119
 120  ... this line is junk ...
 121
 122 =item * C<is_yaml>
 123
 124 Indicates whether or not this is a YAML chunk.
 125
 126 =back
 127
 128 =cut
 129
 130 ##############################################################################
 131
 132 =head3 C<raw>
 133
 134   print $result->raw;
 135
 136 Returns the original line of text which was parsed.
 137
 138 =cut
 139
 140 sub raw { shift->{raw} }
 141
 142 ##############################################################################
 143
 144 =head3 C<type>
 145
 146   my $type = $result->type;
 147
 148 Returns the "type" of a token, such as C<comment> or C<test>.
 149
 150 =cut
 151
 152 sub type { shift->{type} }
 153
 154 ##############################################################################
 155
 156 =head3 C<as_string>
 157
 158   print $result->as_string;
 159
 160 Prints a string representation of the token.  This might not be the exact
 161 output, however.  Tests will have test numbers added if not present, TODO and
 162 SKIP directives will be capitalized and, in general, things will be cleaned
 163 up.  If you need the original text for the token, see the C<raw> method.
 164
 165 =cut
 166
 167 sub as_string { shift->{raw} }
 168
 169 ##############################################################################
 170
 171 =head3 C<is_ok>
 172
 173   if ( $result->is_ok ) { ... }
 174
 175 Reports whether or not a given result has passed.  Anything which is B<not> a
 176 test result returns true.  This is merely provided as a convenient shortcut.
 177
 178 =cut
 179
 180 sub is_ok {1}
 181
 182 ##############################################################################
 183
 184 =head3 C<passed>
 185
 186 Deprecated.  Please use C<is_ok> instead.
 187
 188 =cut
 189
 190 sub passed {
 191     warn 'passed() is deprecated.  Please use "is_ok()"';
 192     shift->is_ok;
 193 }
 194
 195 ##############################################################################
 196
 197 =head3 C<has_directive>
 198
 199   if ( $result->has_directive ) {
 200      ...
 201   }
 202
 203 Indicates whether or not the given result has a TODO or SKIP directive.
 204
 205 =cut
 206
 207 sub has_directive {
 208     my $self = shift;
 209     return ( $self->has_todo || $self->has_skip );
 210 }
 211
 212 ##############################################################################
 213
 214 =head3 C<has_todo>
 215
 216  if ( $result->has_todo ) {
 217      ...
 218  }
 219
 220 Indicates whether or not the given result has a TODO directive.
 221
 222 =cut
 223
 224 sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
 225
 226 ##############################################################################
 227
 228 =head3 C<has_skip>
 229
 230  if ( $result->has_skip ) {
 231      ...
 232  }
 233
 234 Indicates whether or not the given result has a SKIP directive.
 235
 236 =cut
 237
 238 sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
 239
 240 =head3 C<set_directive>
 241
 242 Set the directive associated with this token. Used internally to fake
 243 TODO tests.
 244
 245 =cut
 246
 247 sub set_directive {
 248     my ( $self, $dir ) = @_;
 249     $self->{directive} = $dir;
 250 }
 251
 252 1;