Add files missing in 24314

p4raw-id: //depot/perl@24315

5 files changed, 403 insertions, 0 deletions

diff --git a/lib/Test/Harness/Point.pm b/lib/Test/Harness/Point.pm
new file mode 100644
index 0000000000..9f82fe9fc9
--- /dev/null
+++ b/lib/Test/Harness/Point.pm
@@ -0,0 +1,152 @@
+# -*- Mode: cperl; cperl-indent-level: 4 -*-
+package Test::Harness::Point;
+
+use strict;
+use vars qw($VERSION);
+$VERSION = '0.01';
+
+=head1 NAME
+
+Test::Harness::Point - object for tracking a single test point
+
+=head1 SYNOPSIS
+
+One Test::Harness::Point object represents a single test point.
+
+=head1 CONSTRUCTION
+
+=head2 new()
+
+    my $point = new Test::Harness::Point;
+
+Create a test point object.
+
+=cut
+
+sub new {
+    my $class = shift;
+    my $self  = bless {}, $class;
+
+    return $self;
+}
+
+my $test_line_regex = qr/
+    ^
+    (not\ )?               # failure?
+    ok\b
+    (?:\s+(\d+))?         # optional test number
+    \s*
+    (.*)                  # and the rest
+/ox;
+
+=head1 from_test_line( $line )
+
+Constructor from a TAP test line, or empty return if the test line
+is not a test line.
+
+=cut
+
+sub from_test_line  {
+    my $class = shift;
+    my $line = shift or return;
+
+    # We pulverize the line down into pieces in three parts.
+    my ($not, $number, $extra) = ($line =~ $test_line_regex ) or return;
+
+    my $point = $class->new;
+    $point->set_number( $number );
+    $point->set_ok( !$not );
+
+    if ( $extra ) {
+        my ($description,$directive) = split( /(?:[^\\]|^)#/, $extra, 2 );
+        $description =~ s/^- //; # Test::More puts it in there
+        $point->set_description( $description );
+        if ( $directive ) {
+            $point->set_directive( $directive );
+        }
+    } # if $extra
+
+    return $point;
+} # from_test_line()
+
+=head1 ACCESSORS
+
+Each of the following fields has a getter and setter method.
+
+=over 4
+
+=item * ok
+
+=item * number
+
+=cut
+
+sub ok              { my $self = shift; $self->{ok} }
+sub set_ok          {
+    my $self = shift;
+    my $ok = shift;
+    $self->{ok} = $ok ? 1 : 0;
+}
+sub pass {
+    my $self = shift;
+
+    return ($self->ok || $self->is_todo || $self->is_skip) ? 1 : 0;
+}
+
+sub number          { my $self = shift; $self->{number} }
+sub set_number      { my $self = shift; $self->{number} = shift }
+
+sub description     { my $self = shift; $self->{description} }
+sub set_description {
+    my $self = shift;
+    $self->{description} = shift;
+    $self->{name} = $self->{description}; # history
+}
+
+sub directive       { my $self = shift; $self->{directive} }
+sub set_directive   {
+    my $self = shift;
+    my $directive = shift;
+
+    $directive =~ s/^\s+//;
+    $directive =~ s/\s+$//;
+    $self->{directive} = $directive;
+
+    my ($type,$reason) = ($directive =~ /^\s*(\S+)(?:\s+(.*))?$/);
+    $self->set_directive_type( $type );
+    $reason = "" unless defined $reason;
+    $self->{directive_reason} = $reason;
+}
+sub set_directive_type {
+    my $self = shift;
+    $self->{directive_type} = lc shift;
+    $self->{type} = $self->{directive_type}; # History
+}
+sub set_directive_reason {
+    my $self = shift;
+    $self->{directive_reason} = shift;
+}
+sub directive_type  { my $self = shift; $self->{directive_type} }
+sub type            { my $self = shift; $self->{directive_type} }
+sub directive_reason{ my $self = shift; $self->{directive_reason} }
+sub reason          { my $self = shift; $self->{directive_reason} }
+sub is_todo {
+    my $self = shift;
+    my $type = $self->directive_type;
+    return $type && ( $type eq 'todo' );
+}
+sub is_skip {
+    my $self = shift;
+    my $type = $self->directive_type;
+    return $type && ( $type eq 'skip' );
+}
+
+sub diagnostics     {
+    my $self = shift;
+    return @{$self->{diagnostics}} if wantarray;
+    return join( "\n", @{$self->{diagnostics}} );
+}
+sub add_diagnostic  { my $self = shift; push @{$self->{diagnostics}}, @_ }
+
+
+1;
diff --git a/lib/Test/Harness/t/from_line.t b/lib/Test/Harness/t/from_line.t
new file mode 100644
index 0000000000..b9e726449f
--- /dev/null
+++ b/lib/Test/Harness/t/from_line.t
@@ -0,0 +1,64 @@
+#!perl -Tw
+
+BEGIN {
+    if ( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = '../lib';
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use Test::More tests => 23;
+
+BEGIN {
+    use_ok( 'Test::Harness::Point' );
+}
+
+BASIC_OK: {
+    my $line = "ok 14 - Blah blah";
+    my $point = Test::Harness::Point->from_test_line( $line );
+    isa_ok( $point, 'Test::Harness::Point', 'BASIC_OK' );
+    is( $point->number, 14 );
+    ok( $point->ok );
+    is( $point->description, 'Blah blah' );
+}
+
+BASIC_NOT_OK: {
+    my $line = "not ok 267   Yada";
+    my $point = Test::Harness::Point->from_test_line( $line );
+    isa_ok( $point, 'Test::Harness::Point', 'BASIC_NOT_OK' );
+    is( $point->number, 267 );
+    ok( !$point->ok );
+    is( $point->description, 'Yada' );
+}
+
+CRAP: {
+    my $point = Test::Harness::Point->from_test_line( 'ok14 - Blah' );
+    ok( !defined $point, 'CRAP 1' );
+
+    $point = Test::Harness::Point->from_test_line( 'notok 14' );
+    ok( !defined $point, 'CRAP 2' );
+}
+
+PARSE_TODO: {
+    my $point = Test::Harness::Point->from_test_line( 'not ok 14 - Calculate sqrt(-1) # TODO Still too rational' );
+    isa_ok( $point, 'Test::Harness::Point', 'PARSE_TODO' );
+    is( $point->description, 'Calculate sqrt(-1)' );
+    is( $point->directive_type, 'todo' );
+    is( $point->directive_reason, 'Still too rational' );
+    ok( !$point->is_skip );
+    ok( $point->is_todo );
+}
+
+PARSE_SKIP: {
+    my $point = Test::Harness::Point->from_test_line( 'ok 14 # skip Not on bucket #6' );
+    isa_ok( $point, 'Test::Harness::Point', 'PARSE_SKIP' );
+    is( $point->description, '' );
+    is( $point->directive_type, 'skip' );
+    is( $point->directive_reason, 'Not on bucket #6' );
+    ok( $point->is_skip );
+    ok( !$point->is_todo );
+}
diff --git a/lib/Test/Harness/t/point-parse.t b/lib/Test/Harness/t/point-parse.t
new file mode 100644
index 0000000000..e4de491a77
--- /dev/null
+++ b/lib/Test/Harness/t/point-parse.t
@@ -0,0 +1,106 @@
+#!/usr/bin/perl -w
+
+BEGIN {
+    if ( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+
+use Test::More tests => 52;
+
+BEGIN {
+    use_ok( 'Test::Harness::Point' );
+    use_ok( 'Test::Harness::Straps' );
+}
+
+my $strap = Test::Harness::Straps->new;
+isa_ok( $strap, 'Test::Harness::Straps', 'new()' );
+
+
+my $testlines = {
+    'not ok' => {
+        ok => 0
+    },
+    'not ok # TODO' => {
+        ok => 0,
+        reason => '',
+        type => 'todo'
+    },
+    'not ok 1' => {
+        number => 1,
+        ok => 0
+    },
+    'not ok 11 - this is \\# all the name # skip this is not' => {
+        description => 'this is \\# all the name',
+        number => 11,
+        ok => 0,
+        reason => 'this is not',
+        type => 'skip'
+    },
+    'not ok 23 # TODO world peace' => {
+        number => 23,
+        ok => 0,
+        reason => 'world peace',
+        type => 'todo'
+    },
+    'not ok 42 - universal constant' => {
+        description => 'universal constant',
+        number => 42,
+        ok => 0
+    },
+    ok => {
+        ok => 1
+    },
+    'ok # skip' => {
+        ok => 1,
+        type => 'skip'
+    },
+    'ok 1' => {
+        number => 1,
+        ok => 1
+    },
+    'ok 1066 - and all that' => {
+        description => 'and all that',
+        number => 1066,
+        ok => 1
+    },
+    'ok 11 - have life # TODO get a life' => {
+        description => 'have life',
+        number => 11,
+        ok => 1,
+        reason => 'get a life',
+        type => 'todo'
+    },
+    'ok 2938' => {
+        number => 2938,
+        ok => 1
+    },
+    'ok 42 - _is_header() is a header \'1..192 todo 4 2 13 192 \\# Skip skip skip because' => {
+        description => '_is_header() is a header \'1..192 todo 4 2 13 192 \\# Skip skip skip because',
+        number => 42,
+        ok => 1
+    }
+};
+my @untests = (
+               ' ok',
+               'not',
+               'okay 23',
+              );
+
+for my $line ( sort keys %$testlines ) {
+    my $point = Test::Harness::Point->from_test_line( $line );
+    isa_ok( $point, 'Test::Harness::Point' );
+
+    my $fields = $testlines->{$line};
+    for my $property ( sort keys %$fields ) {
+        my $value = $fields->{$property};
+        is( eval "\$point->$property", $value, "$property on $line" );
+        # Perls pre-5.6 can't handle $point->$property, and must be eval()d
+    }
+}
diff --git a/lib/Test/Harness/t/point.t b/lib/Test/Harness/t/point.t
new file mode 100644
index 0000000000..1c8cf9da73
--- /dev/null
+++ b/lib/Test/Harness/t/point.t
@@ -0,0 +1,58 @@
+#!perl -Tw
+
+BEGIN {
+    if ( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+use Test::More tests => 11;
+
+BEGIN {
+    use_ok( 'Test::Harness::Point' );
+}
+
+my $point = Test::Harness::Point->new;
+isa_ok( $point, 'Test::Harness::Point' );
+ok( !$point->ok, "Should start out not OK" );
+
+$point->set_ok( 1 );
+ok( $point->ok, "should have turned to true" );
+
+$point->set_ok( 0 );
+ok( !$point->ok, "should have turned false" );
+
+$point->set_number( 2112 );
+is( $point->number, 2112, "Number is set" );
+
+$point->set_description( "Blah blah" );
+is( $point->description, "Blah blah", "Description set" );
+
+$point->set_directive( "Go now" );
+is( $point->directive, "Go now", "Directive set" );
+
+$point->add_diagnostic( "# Line 1" );
+$point->add_diagnostic( "# Line two" );
+$point->add_diagnostic( "# Third line" );
+my @diags = $point->diagnostics;
+is( @diags, 3, "Three lines" );
+is_deeply(
+    \@diags,
+    [ "# Line 1", "# Line two", "# Third line" ],
+    "Diagnostics in list context"
+);
+
+my $diagstr = <<EOF;
+# Line 1
+# Line two
+# Third line
+EOF
+
+chomp $diagstr;
+my $string_diagnostics = $point->diagnostics;
+is( $string_diagnostics, $diagstr, "Diagnostics in scalar context" );
diff --git a/lib/Test/Harness/t/version.t b/lib/Test/Harness/t/version.t
new file mode 100644
index 0000000000..c67bcedf27
--- /dev/null
+++ b/lib/Test/Harness/t/version.t
@@ -0,0 +1,23 @@
+#!/usr/bin/perl -Tw
+
+BEGIN {
+    if( $ENV{PERL_CORE} ) {
+        chdir 't';
+        @INC = ('../lib', 'lib');
+    }
+    else {
+        unshift @INC, 't/lib';
+    }
+}
+
+use strict;
+
+use Test::More tests => 3;
+
+BEGIN {
+    use_ok('Test::Harness');
+}
+
+my $ver = $ENV{HARNESS_VERSION} or die "HARNESS_VERSION not set";
+like( $ver, qr/^2.\d\d(_\d\d)?$/, "Version is proper format" );
+is( $ver, $Test::Harness::VERSION );