ext/Test/Harness/lib/TAP/Parser/Result.pm

   1 package TAP::Parser::Result;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA);
   5
   6 use TAP::Object ();
   7
   8 @ISA = 'TAP::Object';
   9
  10 BEGIN {
  11
  12     # make is_* methods
  13     my @attrs = qw( plan pragma test comment bailout version unknown yaml );
  14     no strict 'refs';
  15     for my $token (@attrs) {
  16         my $method = "is_$token";
  17         *$method = sub { return $token eq shift->type };
  18     }
  19 }
  20
  21 ##############################################################################
  22
  23 =head1 NAME
  24
  25 TAP::Parser::Result - Base class for TAP::Parser output objects
  26
  27 =head1 VERSION
  28
  29 Version 3.13
  30
  31 =cut
  32
  33 $VERSION = '3.13';
  34
  35 =head1 SYNOPSIS
  36
  37   # abstract class - not meany to be used directly
  38   # see TAP::Parser::ResultFactory for preferred usage
  39
  40   # directly:
  41   use TAP::Parser::Result;
  42   my $token  = {...};
  43   my $result = TAP::Parser::Result->new( $token );
  44
  45 =head2 DESCRIPTION
  46
  47 This is a simple base class used by L<TAP::Parser> to store objects that
  48 represent the current bit of test output data from TAP (usually a single
  49 line).  Unless you're subclassing, you probably won't need to use this module
  50 directly.
  51
  52 =head2 METHODS
  53
  54 =head3 C<new>
  55
  56   # see TAP::Parser::ResultFactory for preferred usage
  57
  58   # to use directly:
  59   my $result = TAP::Parser::Result->new($token);
  60
  61 Returns an instance the appropriate class for the test token passed in.
  62
  63 =cut
  64
  65 # new() implementation provided by TAP::Object
  66
  67 sub _initialize {
  68     my ( $self, $token ) = @_;
  69     if ($token) {
  70
  71         # make a shallow copy of the token:
  72         $self->{$_} = $token->{$_} for ( keys %$token );
  73     }
  74     return $self;
  75 }
  76
  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_pragma>
  93
  94 Indicates whether or not this is a pragma line.
  95
  96  pragma +strict
  97
  98 =item * C<is_test>
  99
 100 Indicates whether or not this is a test line.
 101
 102  ok 1 Is OK!
 103
 104 =item * C<is_comment>
 105
 106 Indicates whether or not this is a comment.
 107
 108  # this is a comment
 109
 110 =item * C<is_bailout>
 111
 112 Indicates whether or not this is bailout line.
 113
 114  Bail out! We're out of dilithium crystals.
 115
 116 =item * C<is_version>
 117
 118 Indicates whether or not this is a TAP version line.
 119
 120  TAP version 4
 121
 122 =item * C<is_unknown>
 123
 124 Indicates whether or not the current line could be parsed.
 125
 126  ... this line is junk ...
 127
 128 =item * C<is_yaml>
 129
 130 Indicates whether or not this is a YAML chunk.
 131
 132 =back
 133
 134 =cut
 135
 136 ##############################################################################
 137
 138 =head3 C<raw>
 139
 140   print $result->raw;
 141
 142 Returns the original line of text which was parsed.
 143
 144 =cut
 145
 146 sub raw { shift->{raw} }
 147
 148 ##############################################################################
 149
 150 =head3 C<type>
 151
 152   my $type = $result->type;
 153
 154 Returns the "type" of a token, such as C<comment> or C<test>.
 155
 156 =cut
 157
 158 sub type { shift->{type} }
 159
 160 ##############################################################################
 161
 162 =head3 C<as_string>
 163
 164   print $result->as_string;
 165
 166 Prints a string representation of the token.  This might not be the exact
 167 output, however.  Tests will have test numbers added if not present, TODO and
 168 SKIP directives will be capitalized and, in general, things will be cleaned
 169 up.  If you need the original text for the token, see the C<raw> method.
 170
 171 =cut
 172
 173 sub as_string { shift->{raw} }
 174
 175 ##############################################################################
 176
 177 =head3 C<is_ok>
 178
 179   if ( $result->is_ok ) { ... }
 180
 181 Reports whether or not a given result has passed.  Anything which is B<not> a
 182 test result returns true.  This is merely provided as a convenient shortcut.
 183
 184 =cut
 185
 186 sub is_ok {1}
 187
 188 ##############################################################################
 189
 190 =head3 C<passed>
 191
 192 Deprecated.  Please use C<is_ok> instead.
 193
 194 =cut
 195
 196 sub passed {
 197     warn 'passed() is deprecated.  Please use "is_ok()"';
 198     shift->is_ok;
 199 }
 200
 201 ##############################################################################
 202
 203 =head3 C<has_directive>
 204
 205   if ( $result->has_directive ) {
 206      ...
 207   }
 208
 209 Indicates whether or not the given result has a TODO or SKIP directive.
 210
 211 =cut
 212
 213 sub has_directive {
 214     my $self = shift;
 215     return ( $self->has_todo || $self->has_skip );
 216 }
 217
 218 ##############################################################################
 219
 220 =head3 C<has_todo>
 221
 222  if ( $result->has_todo ) {
 223      ...
 224  }
 225
 226 Indicates whether or not the given result has a TODO directive.
 227
 228 =cut
 229
 230 sub has_todo { 'TODO' eq ( shift->{directive} || '' ) }
 231
 232 ##############################################################################
 233
 234 =head3 C<has_skip>
 235
 236  if ( $result->has_skip ) {
 237      ...
 238  }
 239
 240 Indicates whether or not the given result has a SKIP directive.
 241
 242 =cut
 243
 244 sub has_skip { 'SKIP' eq ( shift->{directive} || '' ) }
 245
 246 =head3 C<set_directive>
 247
 248 Set the directive associated with this token. Used internally to fake
 249 TODO tests.
 250
 251 =cut
 252
 253 sub set_directive {
 254     my ( $self, $dir ) = @_;
 255     $self->{directive} = $dir;
 256 }
 257
 258 1;
 259
 260 =head1 SUBCLASSING
 261
 262 Please see L<TAP::Parser/SUBCLASSING> for a subclassing overview.
 263
 264 Remember: if you want your subclass to be automatically used by the parser,
 265 you'll have to register it with L<TAP::Parser::ResultFactory/register_type>.
 266
 267 If you're creating a completely new result I<type>, you'll probably need to
 268 subclass L<TAP::Parser::Grammar> too, or else it'll never get used.
 269
 270 =head2 Example
 271
 272   package MyResult;
 273
 274   use strict;
 275   use vars '@ISA';
 276
 277   @ISA = 'TAP::Parser::Result';
 278
 279   # register with the factory:
 280   TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
 281
 282   sub as_string { 'My results all look the same' }
 283
 284 =head1 SEE ALSO
 285
 286 L<TAP::Object>,
 287 L<TAP::Parser>,
 288 L<TAP::Parser::ResultFactory>,
 289 L<TAP::Parser::Result::Bailout>,
 290 L<TAP::Parser::Result::Comment>,
 291 L<TAP::Parser::Result::Plan>,
 292 L<TAP::Parser::Result::Pragma>,
 293 L<TAP::Parser::Result::Test>,
 294 L<TAP::Parser::Result::Unknown>,
 295 L<TAP::Parser::Result::Version>,
 296 L<TAP::PARSER::RESULT::YAML>,
 297
 298 =cut