dslinux/user/perl/lib/Test/Harness/t 00compile.t assert.t base.t callback.t from_line.t harness.t inc_taint.t nonumbers.t ok.t pod.t point-parse.t point.t prove-globbing.t prove-switches.t strap-analyze.t strap.t test-harness.t version.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:06 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/Test/Harness/t
In directory antilope:/tmp/cvs-serv17422/lib/Test/Harness/t
Added Files:
00compile.t assert.t base.t callback.t from_line.t harness.t
inc_taint.t nonumbers.t ok.t pod.t point-parse.t point.t
prove-globbing.t prove-switches.t strap-analyze.t strap.t
test-harness.t version.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: strap.t ---
#!/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 => 89;
BEGIN { use_ok('Test::Harness::Straps'); }
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps', 'new()' );
### Testing _is_diagnostic()
my $comment;
ok( !$strap->_is_diagnostic("foo", \$comment), '_is_diagnostic(), not a comment' );
ok( !defined $comment, ' no comment set' );
ok( !$strap->_is_diagnostic("f # oo", \$comment), ' not a comment with #' );
ok( !defined $comment, ' no comment set' );
my %comments = (
"# stuff and things # and stuff" =>
' stuff and things # and stuff',
" # more things " => ' more things ',
"#" => '',
);
for my $line ( sort keys %comments ) {
my $line_comment = $comments{$line};
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
my $name = substr($line, 0, 20);
ok( $strap->_is_diagnostic($line, \$comment), " comment '$name'" );
is( $comment, $line_comment, ' right comment set' );
}
### Testing _is_header()
my @not_headers = (' 1..2',
'1..M',
'1..-1',
'2..2',
'1..a',
'',
);
foreach my $unheader (@not_headers) {
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
ok( !$strap->_is_header($unheader),
"_is_header(), not a header '$unheader'" );
ok( (!grep { exists $strap->{$_} } qw(max todo skip_all)),
" max, todo and skip_all are not set" );
}
my @attribs = qw(max skip_all todo);
my %headers = (
'1..2' => { max => 2 },
'1..1' => { max => 1 },
'1..0' => { max => 0,
skip_all => '',
},
'1..0 # Skipped: no leverage found' => { max => 0,
skip_all => 'no leverage found',
},
'1..4 # Skipped: no leverage found' => { max => 4,
skip_all => 'no leverage found',
},
'1..0 # skip skip skip because' => { max => 0,
skip_all => 'skip skip because',
},
'1..10 todo 2 4 10' => { max => 10,
'todo' => { 2 => 1,
4 => 1,
10 => 1,
},
},
'1..10 todo' => { max => 10 },
'1..192 todo 4 2 13 192 # Skip skip skip because' =>
{ max => 192,
'todo' => { 4 => 1,
2 => 1,
13 => 1,
192 => 1,
},
skip_all => 'skip skip because'
}
);
for my $header ( sort keys %headers ) {
my $expect = $headers{$header};
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
ok( $strap->_is_header($header), "_is_header() is a header '$header'" );
is( $strap->{skip_all}, $expect->{skip_all}, ' skip_all set right' )
if defined $expect->{skip_all};
ok( eq_set( [map $strap->{$_}, grep defined $strap->{$_}, @attribs],
[map $expect->{$_}, grep defined $expect->{$_}, @attribs] ),
' the right attributes are there' );
}
### Test _is_bail_out()
my %bails = (
'Bail out!' => undef,
'Bail out! Wing on fire.' => 'Wing on fire.',
'BAIL OUT!' => undef,
'bail out! - Out of coffee' => '- Out of coffee',
);
for my $line ( sort keys %bails ) {
my $expect = $bails{$line};
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
my $reason;
ok( $strap->_is_bail_out($line, \$reason), "_is_bail_out() spots '$line'");
is( $reason, $expect, ' with the right reason' );
}
my @unbails = (
' Bail out!',
'BAIL OUT',
'frobnitz',
'ok 23 - BAIL OUT!',
);
foreach my $line (@unbails) {
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
my $reason;
ok( !$strap->_is_bail_out($line, \$reason),
"_is_bail_out() ignores '$line'" );
is( $reason, undef, ' and gives no reason' );
}
--- NEW FILE: ok.t ---
-f "core" and unlink "core";
print <<END;
1..4
ok 1
ok 2
ok 3
ok 4
END
--- NEW FILE: harness.t ---
#!/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 => 2;
BEGIN {
use_ok( 'Test::Harness' );
}
my $strap = Test::Harness->strap;
isa_ok( $strap, 'Test::Harness::Straps' );
--- NEW FILE: callback.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use Test::More;
use File::Spec;
BEGIN {
use vars qw( %samples );
%samples = (
bailout => [qw( header test test test bailout )],
combined => ['header', ('test') x 10],
descriptive => ['header', ('test') x 5 ],
duplicates => ['header', ('test') x 11 ],
head_end => [qw( other test test test test
other header other other )],
head_fail => [qw( other test test test test
other header other other )],
no_nums => ['header', ('test') x 5 ],
out_of_order=> [('test') x 10, 'header', ('test') x 5],
simple => [qw( header test test test test test )],
simple_fail => [qw( header test test test test test )],
'skip' => [qw( header test test test test test )],
skipall => [qw( header )],
skipall_nomsg => [qw( header )],
skip_nomsg => [qw( header test )],
taint => [qw( header test )],
'todo' => [qw( header test test test test test )],
todo_inline => [qw( header test test test )],
vms_nit => [qw( header other test test )],
with_comments => [qw( other header other test other test test
test other other test other )],
);
plan tests => 2 + scalar keys %samples;
}
BEGIN { use_ok( 'Test::Harness::Straps' ); }
my $Curdir = File::Spec->curdir;
my $SAMPLE_TESTS = $ENV{PERL_CORE}
? File::Spec->catdir($Curdir, 'lib', 'sample-tests')
: File::Spec->catdir($Curdir, 't', 'sample-tests');
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
$strap->{callback} = sub {
my($self, $line, $type, $totals) = @_;
push @out, $type;
};
for my $test ( sort keys %samples ) {
my $expect = $samples{$test};
local @out = ();
$strap->analyze_file(File::Spec->catfile($SAMPLE_TESTS, $test));
is_deeply(\@out, $expect, "$test callback");
}
--- NEW FILE: inc_taint.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use Test::Harness;
use Test::More tests => 1;
use Dev::Null;
push @INC, 'we_added_this_lib';
tie *NULL, 'Dev::Null' or die $!;
select NULL;
my($tot, $failed) = Test::Harness::_run_all_tests(
$ENV{PERL_CORE}
? 'lib/sample-tests/inc_taint'
: 't/sample-tests/inc_taint'
);
select STDOUT;
ok( Test::Harness::_all_ok($tot), 'tests with taint on preserve @INC' );
--- NEW FILE: version.t ---
#!/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 );
--- NEW FILE: strap-analyze.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::More;
use File::Spec;
my $Curdir = File::Spec->curdir;
my $SAMPLE_TESTS = $ENV{PERL_CORE}
? File::Spec->catdir($Curdir, 'lib', 'sample-tests')
: File::Spec->catdir($Curdir, 't', 'sample-tests');
my $IsMacPerl = $^O eq 'MacOS';
my $IsVMS = $^O eq 'VMS';
# VMS uses native, not POSIX, exit codes.
my $die_exit = $IsVMS ? 44 : 1;
# We can only predict that the wait status should be zero or not.
my $wait_non_zero = 1;
my %samples = (
bignum => {
bonus => 0,
details => [
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
ok => 1
}
],
'exit' => 0,
max => 2,
ok => 4,
passing => 0,
seen => 4,
skip => 0,
todo => 0,
'wait' => 0
},
combined => {
bonus => 1,
details => [
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
name => "basset hounds got long ears",
ok => 1
},
{
actual_ok => 0,
name => "all hell broke lose",
ok => 0
},
{
actual_ok => 1,
ok => 1,
type => "todo"
},
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
ok => 1,
reason => "contract negociations",
type => "skip"
},
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 0,
ok => 0
},
{
actual_ok => 0,
ok => 1,
type => "todo"
}
],
'exit' => 0,
max => 10,
ok => 8,
passing => 0,
seen => 10,
skip => 1,
todo => 2,
'wait' => 0
},
descriptive => {
bonus => 0,
details => [
{
actual_ok => 1,
name => "Interlock activated",
ok => 1
},
{
actual_ok => 1,
name => "Megathrusters are go",
ok => 1
},
{
actual_ok => 1,
name => "Head formed",
ok => 1
},
{
actual_ok => 1,
name => "Blazing sword formed",
ok => 1
},
{
actual_ok => 1,
name => "Robeast destroyed",
ok => 1
}
],
'exit' => 0,
max => 5,
ok => 5,
passing => 1,
seen => 5,
skip => 0,
todo => 0,
'wait' => 0
},
'die' => {
bonus => 0,
details => [],
'exit' => $die_exit,
max => 0,
ok => 0,
passing => 0,
seen => 0,
skip => 0,
todo => 0,
'wait' => $wait_non_zero
},
die_head_end => {
bonus => 0,
details => [
({
actual_ok => 1,
ok => 1
}) x 4,
],
'exit' => $die_exit,
max => 0,
ok => 4,
passing => 0,
seen => 4,
skip => 0,
todo => 0,
'wait' => $wait_non_zero
},
die_last_minute => {
bonus => 0,
details => [
({
actual_ok => 1,
ok => 1
}) x 4,
],
'exit' => $die_exit,
max => 4,
ok => 4,
passing => 0,
seen => 4,
skip => 0,
todo => 0,
'wait' => $wait_non_zero
},
duplicates => {
bonus => 0,
details => [
({
actual_ok => 1,
ok => 1
}) x 10,
],
'exit' => 0,
max => 10,
ok => 11,
passing => 0,
seen => 11,
skip => 0,
todo => 0,
'wait' => 0
},
head_end => {
bonus => 0,
details => [
({
actual_ok => 1,
ok => 1
}) x 3,
{
actual_ok => 1,
diagnostics => "comment\nmore ignored stuff\nand yet more\n",
ok => 1
}
],
'exit' => 0,
max => 4,
ok => 4,
passing => 1,
seen => 4,
skip => 0,
todo => 0,
'wait' => 0
},
head_fail => {
bonus => 0,
details => [
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 0,
ok => 0
},
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
diagnostics => "comment\nmore ignored stuff\nand yet more\n",
ok => 1
}
],
'exit' => 0,
max => 4,
ok => 3,
passing => 0,
seen => 4,
skip => 0,
todo => 0,
'wait' => 0
},
lone_not_bug => {
bonus => 0,
details => [
({
actual_ok => 1,
ok => 1
}) x 4,
],
'exit' => 0,
max => 4,
ok => 4,
passing => 1,
seen => 4,
skip => 0,
todo => 0,
'wait' => 0
},
no_output => {
bonus => 0,
details => [],
'exit' => 0,
max => 0,
ok => 0,
passing => 0,
seen => 0,
skip => 0,
todo => 0,
'wait' => 0
},
shbang_misparse => {
bonus => 0,
details => [
({
actual_ok => 1,
ok => 1
}) x 2,
],
'exit' => 0,
max => 2,
ok => 2,
passing => 1,
seen => 2,
skip => 0,
todo => 0,
'wait' => 0
},
simple => {
bonus => 0,
details => [
({
actual_ok => 1,
ok => 1
}) x 5,
],
'exit' => 0,
max => 5,
ok => 5,
passing => 1,
seen => 5,
skip => 0,
todo => 0,
'wait' => 0
},
simple_fail => {
bonus => 0,
details => [
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 0,
ok => 0
},
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 0,
ok => 0
}
],
'exit' => 0,
max => 5,
ok => 3,
passing => 0,
seen => 5,
skip => 0,
todo => 0,
'wait' => 0
},
skip => {
bonus => 0,
details => [
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
ok => 1,
reason => "rain delay",
type => "skip"
},
({
actual_ok => 1,
ok => 1
}) x 3,
],
'exit' => 0,
max => 5,
ok => 5,
passing => 1,
seen => 5,
skip => 1,
todo => 0,
'wait' => 0
},
skip_nomsg => {
bonus => 0,
details => [
{
actual_ok => 1,
ok => 1,
reason => "",
type => "skip"
}
],
'exit' => 0,
max => 1,
ok => 1,
passing => 1,
seen => 1,
skip => 1,
todo => 0,
'wait' => 0
},
skipall => {
bonus => 0,
details => [],
'exit' => 0,
max => 0,
ok => 0,
passing => 1,
seen => 0,
skip => 0,
skip_all => "rope",
todo => 0,
'wait' => 0
},
skipall_nomsg => {
bonus => 0,
details => [],
'exit' => 0,
max => 0,
ok => 0,
passing => 1,
seen => 0,
skip => 0,
skip_all => "",
todo => 0,
'wait' => 0
},
taint => {
bonus => 0,
details => [
{
actual_ok => 1,
name => "-T honored",
ok => 1
}
],
'exit' => 0,
max => 1,
ok => 1,
passing => 1,
seen => 1,
skip => 0,
todo => 0,
'wait' => 0
},
todo => {
bonus => 1,
details => [
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 1,
ok => 1,
type => "todo"
},
{
actual_ok => 0,
ok => 1,
type => "todo"
},
({
actual_ok => 1,
ok => 1
}) x 2,
],
'exit' => 0,
max => 5,
ok => 5,
passing => 1,
seen => 5,
skip => 0,
todo => 2,
'wait' => 0
},
vms_nit => {
bonus => 0,
details => [
{
actual_ok => 0,
ok => 0
},
{
actual_ok => 1,
ok => 1
}
],
'exit' => 0,
max => 2,
ok => 1,
passing => 0,
seen => 2,
skip => 0,
todo => 0,
'wait' => 0
},
with_comments => {
bonus => 2,
details => [
{
actual_ok => 0,
diagnostics => "Failed test 1 in t/todo.t at line 9 *TODO*\n",
ok => 1,
type => "todo"
},
{
actual_ok => 1,
ok => 1,
reason => "at line 10 TODO?!)",
type => "todo"
},
{
actual_ok => 1,
ok => 1
},
{
actual_ok => 0,
diagnostics => "Test 4 got: '0' (t/todo.t at line 12 *TODO*)\n Expected: '1' (need more tuits)\n",
ok => 1,
type => "todo"
},
{
actual_ok => 1,
diagnostics => "woo\n",
ok => 1,
reason => "at line 13 TODO?!)",
type => "todo"
}
],
'exit' => 0,
max => 5,
ok => 5,
passing => 1,
seen => 5,
skip => 0,
todo => 4,
'wait' => 0
},
);
plan tests => (keys(%samples) * 5) + 3;
use Test::Harness::Straps;
my @_INC = map { qq{"-I$_"} } @INC;
$Test::Harness::Switches = "@_INC -Mstrict";
$SIG{__WARN__} = sub {
warn @_ unless $_[0] =~ /^Enormous test number/ ||
$_[0] =~ /^Can't detailize/
};
for my $test ( sort keys %samples ) {
print "# Working on $test\n";
my $expect = $samples{$test};
for my $n ( 0..$#{$expect->{details}} ) {
for my $field ( qw( type name reason ) ) {
$expect->{details}[$n]{$field} = '' unless exists $expect->{details}[$n]{$field};
}
}
my $test_path = File::Spec->catfile($SAMPLE_TESTS, $test);
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
my %results = $strap->analyze_file($test_path);
is_deeply($results{details}, $expect->{details}, qq{details of "$test"} );
delete $expect->{details};
delete $results{details};
SKIP: {
skip '$? unreliable in MacPerl', 2 if $IsMacPerl;
# We can only check if it's zero or non-zero.
is( !!$results{'wait'}, !!$expect->{'wait'}, 'wait status' );
delete $results{'wait'};
delete $expect->{'wait'};
# Have to check the exit status seperately so we can skip it
# in MacPerl.
is( $results{'exit'}, $expect->{'exit'} );
delete $results{'exit'};
delete $expect->{'exit'};
}
is_deeply(\%results, $expect, qq{ the rest of "$test"} );
} # for %samples
NON_EXISTENT_FILE: {
my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps' );
ok( !$strap->analyze_file('I_dont_exist') );
is( $strap->{error}, "I_dont_exist does not exist" );
}
--- NEW FILE: prove-globbing.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use File::Spec;
use Test::More;
plan skip_all => "Not adapted to perl core" if $ENV{PERL_CORE};
plan skip_all => "Not installing prove" if -e "t/SKIP-PROVE";
plan tests => 1;
my $prove = File::Spec->catfile( File::Spec->curdir, "blib", "script", "prove" );
my $tests = File::Spec->catfile( 't', 'prove*.t' );
GLOBBAGE: {
my @actual = sort qx/$prove --dry $tests/;
chomp @actual;
my @expected = (
File::Spec->catfile( "t", "prove-globbing.t" ),
File::Spec->catfile( "t", "prove-switches.t" ),
);
is_deeply( \@actual, \@expected, "Expands the wildcards" );
}
--- NEW FILE: base.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
print "1..1\n";
unless (eval 'require Test::Harness') {
print "not ok 1\n";
} else {
print "ok 1\n";
}
--- NEW FILE: point.t ---
#!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" );
--- NEW FILE: 00compile.t ---
#!/usr/bin/perl -w
BEGIN {
if($ENV{PERL_CORE}) {
chdir 't';
@INC = '../lib';
}
else {
unshift @INC, 't/lib';
}
}
use Test::More tests => 6;
BEGIN { use_ok 'Test::Harness' }
BEGIN { diag( "Testing Test::Harness $Test::Harness::VERSION under Perl $] and Test::More $Test::More::VERSION" ) unless $ENV{PERL_CORE}}
BEGIN { use_ok 'Test::Harness::Straps' }
BEGIN { use_ok 'Test::Harness::Iterator' }
BEGIN { use_ok 'Test::Harness::Assert' }
BEGIN { use_ok 'Test::Harness::Point' }
# If the $VERSION is set improperly, this will spew big warnings.
BEGIN { use_ok 'Test::Harness', 1.1601 }
--- NEW FILE: nonumbers.t ---
if( $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE} ) {
print "1..0 # Skip: t/TEST needs numbers\n";
exit;
}
print <<END;
1..6
ok
ok
ok
ok
ok
ok
END
--- NEW FILE: assert.t ---
#!/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 => 7;
BEGIN { use_ok( 'Test::Harness::Assert' ); }
ok( defined &assert, 'assert() exported' );
ok( !eval { assert( 0 ); 1 }, 'assert( FALSE ) causes death' );
like( $@, '/Assert failed/', ' with the right message' );
ok( eval { assert( 1 ); 1 }, 'assert( TRUE ) does nothing' );
ok( !eval { assert( 0, 'some name' ); 1 }, 'assert( FALSE, NAME )' );
like( $@, '/some name/', ' has the name' );
--- NEW FILE: prove-switches.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use File::Spec;
use Test::More;
plan skip_all => "Not adapted to perl core" if $ENV{PERL_CORE};
plan skip_all => "Not installing prove" if -e "t/SKIP-PROVE";
# Work around a Cygwin bug. Remove this if Perl bug 30952 ever gets fixed.
# http://rt.perl.org/rt3/Ticket/Display.html?id=30952.
plan skip_all => "Skipping because of a Cygwin bug" if ( $^O =~ /cygwin/i );
plan tests => 5;
my $blib = File::Spec->catfile( File::Spec->curdir, "blib" );
my $blib_lib = File::Spec->catfile( $blib, "lib" );
my $blib_arch = File::Spec->catfile( $blib, "arch" );
my $prove = File::Spec->catfile( $blib, "script", "prove" );
CAPITAL_TAINT: {
local $ENV{PROVE_SWITCHES};
local $/ = undef;
my @actual = qx/$prove -Ifirst -D -I second -Ithird -Tvdb/;
my @expected = ( "# \$Test::Harness::Switches: -T -I$blib_arch -I$blib_lib -Ifirst -Isecond -Ithird\n" );
is_deeply( \@actual, \@expected, "Capital taint flags OK" );
}
LOWERCASE_TAINT: {
local $ENV{PROVE_SWITCHES};
local $/ = undef;
my @actual = qx/$prove -dD -Ifirst -I second -t -Ithird -vb/;
my @expected = ( "# \$Test::Harness::Switches: -t -I$blib_arch -I$blib_lib -Ifirst -Isecond -Ithird\n" );
is_deeply( \@actual, \@expected, "Lowercase taint OK" );
}
PROVE_SWITCHES: {
local $ENV{PROVE_SWITCHES} = "-dvb -I fark";
local $/ = undef;
my @actual = qx/$prove -Ibork -Dd/;
my @expected = ( "# \$Test::Harness::Switches: -I$blib_arch -I$blib_lib -Ifark -Ibork\n" );
is_deeply( \@actual, \@expected, "PROVE_SWITCHES OK" );
}
PROVE_SWITCHES_L: {
local $/ = undef;
my @actual = qx/$prove -l -Ibongo -Dd/;
my @expected = ( "# \$Test::Harness::Switches: -Ilib -Ibongo\n" );
is_deeply( \@actual, \@expected, "PROVE_SWITCHES OK" );
}
PROVE_SWITCHES_LB: {
local $/ = undef;
my @actual = qx/$prove -lb -Dd/;
my @expected = ( "# \$Test::Harness::Switches: -Ilib -I$blib_arch -I$blib_lib\n" );
is_deeply( \@actual, \@expected, "PROVE_SWITCHES OK" );
}
--- NEW FILE: test-harness.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use File::Spec;
my $Curdir = File::Spec->curdir;
my $SAMPLE_TESTS = $ENV{PERL_CORE}
? File::Spec->catdir($Curdir, 'lib', 'sample-tests')
: File::Spec->catdir($Curdir, 't', 'sample-tests');
use Test::More;
use Dev::Null;
my $IsMacPerl = $^O eq 'MacOS';
my $IsVMS = $^O eq 'VMS';
# VMS uses native, not POSIX, exit codes.
# MacPerl's exit codes are broken.
my $die_estat = $IsVMS ? 44 :
$IsMacPerl ? 0 :
1;
my %samples = (
simple => {
total => {
bonus => 0,
max => 5,
'ok' => 5,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
simple_fail => {
total => {
bonus => 0,
max => 5,
'ok' => 3,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped => 0,
'todo' => 0,
skipped => 0,
},
failed => {
canon => '2 5',
},
all_ok => 0,
},
descriptive => {
total => {
bonus => 0,
max => 5,
'ok' => 5,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
no_nums => {
total => {
bonus => 0,
max => 5,
'ok' => 4,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
canon => '3',
},
all_ok => 0,
},
'todo' => {
total => {
bonus => 1,
max => 5,
'ok' => 5,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 2,
skipped => 0,
},
failed => { },
all_ok => 1,
},
todo_inline => {
total => {
bonus => 1,
max => 3,
'ok' => 3,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped => 0,
'todo' => 2,
skipped => 0,
},
failed => { },
all_ok => 1,
},
'skip' => {
total => {
bonus => 0,
max => 5,
'ok' => 5,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 1,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
'skip_nomsg' => {
total => {
bonus => 0,
max => 1,
'ok' => 1,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 1,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
bailout => 0,
combined => {
total => {
bonus => 1,
max => 10,
'ok' => 8,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 1,
'todo' => 2,
skipped => 0
},
failed => {
canon => '3 9',
},
all_ok => 0,
},
duplicates => {
total => {
bonus => 0,
max => 10,
'ok' => 11,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
canon => '??',
},
all_ok => 0,
},
head_end => {
total => {
bonus => 0,
max => 4,
'ok' => 4,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
head_fail => {
total => {
bonus => 0,
max => 4,
'ok' => 3,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
canon => '2',
},
all_ok => 0,
},
no_output => {
total => {
bonus => 0,
max => 0,
'ok' => 0,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped => 0,
'todo' => 0,
skipped => 0,
},
failed => {
},
all_ok => 0,
},
skipall => {
total => {
bonus => 0,
max => 0,
'ok' => 0,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 1,
},
failed => { },
all_ok => 1,
},
skipall_nomsg => {
total => {
bonus => 0,
max => 0,
'ok' => 0,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 1,
},
failed => { },
all_ok => 1,
},
with_comments => {
total => {
bonus => 2,
max => 5,
'ok' => 5,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 4,
skipped => 0,
},
failed => { },
all_ok => 1,
},
taint => {
total => {
bonus => 0,
max => 1,
'ok' => 1,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
taint_warn => {
total => {
bonus => 0,
max => 1,
'ok' => 1,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
'die' => {
total => {
bonus => 0,
max => 0,
'ok' => 0,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
estat => $die_estat,
max => '??',
failed => '??',
canon => '??',
},
all_ok => 0,
},
die_head_end => {
total => {
bonus => 0,
max => 0,
'ok' => 4,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
estat => $die_estat,
max => '??',
failed => '??',
canon => '??',
},
all_ok => 0,
},
die_last_minute => {
total => {
bonus => 0,
max => 4,
'ok' => 4,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
estat => $die_estat,
max => 4,
failed => 0,
canon => '??',
},
all_ok => 0,
},
bignum => {
total => {
bonus => 0,
max => 2,
'ok' => 4,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
canon => '??',
},
all_ok => 0,
},
bignum_many => {
total => {
bonus => 0,
max => 2,
'ok' => 11,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => {
canon => '3-100000',
},
all_ok => 0,
},
'shbang_misparse' => {
total => {
bonus => 0,
max => 2,
'ok' => 2,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
too_many => {
total => {
bonus => 0,
max => 3,
'ok' => 7,
files => 1,
bad => 1,
good => 0,
tests => 1,
sub_skipped => 0,
'todo' => 0,
skipped => 0,
},
failed => {
canon => '4-7',
},
all_ok => 0,
},
switches => {
total => {
bonus => 0,
max => 1,
'ok' => 1,
files => 1,
bad => 0,
good => 1,
tests => 1,
sub_skipped=> 0,
'todo' => 0,
skipped => 0,
},
failed => { },
all_ok => 1,
},
);
plan tests => (keys(%samples) * 7);
use Test::Harness;
my @_INC = map { qq{"-I$_"} } @INC;
$Test::Harness::Switches = "@_INC -Mstrict";
tie *NULL, 'Dev::Null' or die $!;
for my $test ( sort keys %samples ) {
SKIP: {
skip "-t introduced in 5.8.0", 7 if $test eq 'taint_warn' and $] < 5.008;
my $expect = $samples{$test};
# _run_all_tests() runs the tests but skips the formatting.
my($totals, $failed);
my $warning = '';
my $test_path = File::Spec->catfile($SAMPLE_TESTS, $test);
print STDERR "# $test\n" if $ENV{TEST_VERBOSE};
eval {
select NULL; # _run_all_tests() isn't as quiet as it should be.
local $SIG{__WARN__} = sub { $warning .= join '', @_; };
($totals, $failed) =
Test::Harness::_run_all_tests($test_path);
};
select STDOUT;
# $? is unreliable in MacPerl, so we'll just fudge it.
$failed->{estat} = $die_estat if $IsMacPerl and $failed;
SKIP: {
skip "special tests for bailout", 1 unless $test eq 'bailout';
like( $@, '/Further testing stopped: GERONI/i' );
}
SKIP: {
skip "don't apply to a bailout", 5 if $test eq 'bailout';
is( $@, '' );
is( Test::Harness::_all_ok($totals), $expect->{all_ok},
"$test - all ok" );
ok( defined $expect->{total}, "$test - has total" );
is_deeply( {map { $_=>$totals->{$_} } keys %{$expect->{total}}},
$expect->{total},
"$test - totals" );
is_deeply( {map { $_=>$failed->{$test_path}{$_} }
keys %{$expect->{failed}}},
$expect->{failed},
"$test - failed" );
}
my $expected_warnings = "";
if ( $test eq "bignum" ) {
$expected_warnings = <<WARN;
Enormous test number seen [test 136211425]
Can't detailize, too big.
WARN
}
elsif ( $test eq 'bignum_many' ) {
$expected_warnings = <<WARN;
Enormous test number seen [test 100001]
Can't detailize, too big.
WARN
}
my $desc = $expected_warnings ? 'Got proper warnings' : 'No warnings';
is( $warning, $expected_warnings, "$test - $desc" );
} # taint SKIP block
} # for tests
--- NEW FILE: from_line.t ---
#!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 );
}
--- NEW FILE: pod.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use Test::More;
eval "use Test::Pod 1.00";
plan skip_all => "Test::Pod 1.00 required for testing POD" if $@;
all_pod_files_ok();
--- NEW FILE: point-parse.t ---
#!/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
}
}
More information about the dslinux-commit
mailing list