Initial Commit

database/perl/lib/TAP/Parser/Result/Test.pm

@@ -0,0 +1,271 @@
+package TAP::Parser::Result::Test;
+
+use strict;
+use warnings;
+
+use base 'TAP::Parser::Result';
+
+=head1 NAME
+
+TAP::Parser::Result::Test - Test result token.
+
+=head1 VERSION
+
+Version 3.42
+
+=cut
+
+our $VERSION = '3.42';
+
+=head1 DESCRIPTION
+
+This is a subclass of L<TAP::Parser::Result>.  A token of this class will be
+returned if a test line is encountered.
+
+ 1..1
+ ok 1 - woo hooo!
+
+=head1 OVERRIDDEN METHODS
+
+This class is the workhorse of the L<TAP::Parser> system.  Most TAP lines will
+be test lines and if C<< $result->is_test >>, then you have a bunch of methods
+at your disposal.
+
+=head2 Instance Methods
+
+=cut
+
+##############################################################################
+
+=head3 C<ok>
+
+  my $ok = $result->ok;
+
+Returns the literal text of the C<ok> or C<not ok> status.
+
+=cut
+
+sub ok { shift->{ok} }
+
+##############################################################################
+
+=head3 C<number>
+
+  my $test_number = $result->number;
+
+Returns the number of the test, even if the original TAP output did not supply
+that number.
+
+=cut
+
+sub number { shift->{test_num} }
+
+sub _number {
+    my ( $self, $number ) = @_;
+    $self->{test_num} = $number;
+}
+
+##############################################################################
+
+=head3 C<description>
+
+  my $description = $result->description;
+
+Returns the description of the test, if any.  This is the portion after the
+test number but before the directive.
+
+=cut
+
+sub description { shift->{description} }
+
+##############################################################################
+
+=head3 C<directive>
+
+  my $directive = $result->directive;
+
+Returns either C<TODO> or C<SKIP> if either directive was present for a test
+line.
+
+=cut
+
+sub directive { shift->{directive} }
+
+##############################################################################
+
+=head3 C<explanation>
+
+  my $explanation = $result->explanation;
+
+If a test had either a C<TODO> or C<SKIP> directive, this method will return
+the accompanying explanation, if present.
+
+  not ok 17 - 'Pigs can fly' # TODO not enough acid
+
+For the above line, the explanation is I<not enough acid>.
+
+=cut
+
+sub explanation { shift->{explanation} }
+
+##############################################################################
+
+=head3 C<is_ok>
+
+  if ( $result->is_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed.  Remember
+that for TODO tests, the test always passes.
+
+If the test is unplanned, this method will always return false.  See
+C<is_unplanned>.
+
+=cut
+
+sub is_ok {
+    my $self = shift;
+
+    return if $self->is_unplanned;
+
+    # TODO directives reverse the sense of a test.
+    return $self->has_todo ? 1 : $self->ok !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<is_actual_ok>
+
+  if ( $result->is_actual_ok ) { ... }
+
+Returns a boolean value indicating whether or not the test passed, regardless
+of its TODO status.
+
+=cut
+
+sub is_actual_ok {
+    my $self = shift;
+    return $self->{ok} !~ /not/;
+}
+
+##############################################################################
+
+=head3 C<actual_passed>
+
+Deprecated.  Please use C<is_actual_ok> instead.
+
+=cut
+
+sub actual_passed {
+    warn 'actual_passed() is deprecated.  Please use "is_actual_ok()"';
+    goto &is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_passed>
+
+  if ( $test->todo_passed ) {
+     # test unexpectedly succeeded
+  }
+
+If this is a TODO test and an 'ok' line, this method returns true.
+Otherwise, it will always return false (regardless of passing status on
+non-todo tests).
+
+This is used to track which tests unexpectedly succeeded.
+
+=cut
+
+sub todo_passed {
+    my $self = shift;
+    return $self->has_todo && $self->is_actual_ok;
+}
+
+##############################################################################
+
+=head3 C<todo_failed>
+
+  # deprecated in favor of 'todo_passed'.  This method was horribly misnamed.
+
+This was a badly misnamed method.  It indicates which TODO tests unexpectedly
+succeeded.  Will now issue a warning and call C<todo_passed>.
+
+=cut
+
+sub todo_failed {
+    warn 'todo_failed() is deprecated.  Please use "todo_passed()"';
+    goto &todo_passed;
+}
+
+##############################################################################
+
+=head3 C<has_skip>
+
+  if ( $result->has_skip ) { ... }
+
+Returns a boolean value indicating whether or not this test has a SKIP
+directive.
+
+=head3 C<has_todo>
+
+  if ( $result->has_todo ) { ... }
+
+Returns a boolean value indicating whether or not this test has a TODO
+directive.
+
+=head3 C<as_string>
+
+  print $result->as_string;
+
+This method prints the test as a string.  It will probably be similar, but
+not necessarily identical, to the original test line.  Directives are
+capitalized, some whitespace may be trimmed and a test number will be added if
+it was not present in the original line.  If you need the original text of the
+test line, use the C<raw> method.
+
+=cut
+
+sub as_string {
+    my $self   = shift;
+    my $string = $self->ok . " " . $self->number;
+    if ( my $description = $self->description ) {
+        $string .= " $description";
+    }
+    if ( my $directive = $self->directive ) {
+        my $explanation = $self->explanation;
+        $string .= " # $directive $explanation";
+    }
+    return $string;
+}
+
+##############################################################################
+
+=head3 C<is_unplanned>
+
+  if ( $test->is_unplanned ) { ... }
+  $test->is_unplanned(1);
+
+If a test number is greater than the number of planned tests, this method will
+return true.  Unplanned tests will I<always> return false for C<is_ok>,
+regardless of whether or not the test C<has_todo>.
+
+Note that if tests have a trailing plan, it is not possible to set this
+property for unplanned tests as we do not know it's unplanned until the plan
+is reached:
+
+  print <<'END';
+  ok 1
+  ok 2
+  1..1
+  END
+
+=cut
+
+sub is_unplanned {
+    my $self = shift;
+    return ( $self->{unplanned} || '' ) unless @_;
+    $self->{unplanned} = !!shift;
+    return $self;
+}
+
+1;