dslinux/user/perl/lib/Test/t 05_about_verbose.t fail.t mix.t multiline.t onfail.t qr.t skip.t success.t todo.t

[cayenne]

Update of /cvsroot/dslinux/dslinux/user/perl/lib/Test/t
In directory antilope:/tmp/cvs-serv17422/lib/Test/t

Added Files:
	05_about_verbose.t fail.t mix.t multiline.t onfail.t qr.t 
	skip.t success.t todo.t 
Log Message:
Adding fresh perl source to HEAD to branch from

--- NEW FILE: todo.t ---
# -*-perl-*-
use strict;
use Test qw(:DEFAULT $TESTOUT $TESTERR $ntest);

### This test is crafted in such a way as to prevent Test::Harness from
### seeing the todo tests, otherwise you get people sending in bug reports
### about Test.pm having "UNEXPECTEDLY SUCCEEDED" tests.

open F, ">todo";
$TESTOUT = *F{IO};
$TESTERR = *F{IO};
my $tests = 5; 
plan tests => $tests, todo => [2..$tests]; 


# tests to go to the output file
ok(1);
ok(1);
ok(0,1);
ok(0,1,"need more tuits");
ok(1,1);

close F;
$TESTOUT = *STDOUT{IO};
$TESTERR = *STDERR{IO};
$ntest = 1;

open F, "todo";
my $out = join '', <F>;
close F;
unlink "todo";

my $expect = <<"EXPECT";
1..5 todo 2 3 4 5;
ok 1
ok 2 # ($0 at line 18 TODO?!)
not ok 3
# Test 3 got: '0' ($0 at line 19 *TODO*)
#   Expected: '1'
not ok 4
# Test 4 got: '0' ($0 at line 20 *TODO*)
#   Expected: '1' (need more tuits)
ok 5 # ($0 at line 21 TODO?!)
EXPECT


sub commentless {
  my $in = $_[0];
  $in =~ s/^#[^\n]*\n//mg;
  $in =~ s/\n#[^\n]*$//mg;
  return $in;
}

print "1..1\n";
ok( commentless($out), commentless($expect) );

--- NEW FILE: skip.t ---
# -*-perl-*-
use strict;
use Test qw($TESTOUT $TESTERR $ntest plan ok skip); 
plan tests => 6;

open F, ">skips" or die "open skips: $!";
$TESTOUT = *F{IO};
$TESTERR = *F{IO};

skip(1, 0);  #should skip

my $skipped=1;
skip('hop', sub { $skipped = 0 });
skip(sub {'jump'}, sub { $skipped = 0 });
skip('skipping stones is more fun', sub { $skipped = 0 });

close F;

$TESTOUT = *STDOUT{IO};
$TESTERR = *STDERR{IO};
$ntest = 1;
open F, "skips" or die "open skips: $!";

ok $skipped, 1, 'not skipped?';

my @T = <F>;
chop @T;
my @expect = split /\n+/, join('',<DATA>);
ok @T, 4;
for (my $x=0; $x < @T; $x++) {
    ok $T[$x], $expect[$x];
}

END { close F; unlink "skips" }

__DATA__
ok 1 # skip

ok 2 # skip hop

ok 3 # skip jump

ok 4 # skip skipping stones is more fun

--- NEW FILE: 05_about_verbose.t ---
require 5;
# Time-stamp: "2004-04-24 16:53:03 ADT"

# Summary of, well, things.

use Test;
BEGIN {plan tests => 2};

ok 1;

{
  my @out;
  push @out,
    "\n\nPerl v",
    defined($^V) ? sprintf('%vd', $^V) : $],
    " under $^O ",
    (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
      ? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (),
    (defined $MacPerl::Version)
      ? ("(MacPerl version $MacPerl::Version)") : (),
    "\n"
  ;

  # Ugly code to walk the symbol tables:
  my %v;
  my @stack = ('');  # start out in %::
  my $this;
  my $count = 0;
  my $pref;
  while(@stack) {
    $this = shift @stack;
    die "Too many packages?" if ++$count > 1000;
    next if exists $v{$this};
    next if $this eq 'main'; # %main:: is %::

    #print "Peeking at $this => ${$this . '::VERSION'}\n";
    
    if(defined ${$this . '::VERSION'} ) {
      $v{$this} = ${$this . '::VERSION'}
    } elsif(
       defined *{$this . '::ISA'} or defined &{$this . '::import'}
       or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"})
       # If it has an ISA, an import, or any subs...
    ) {
      # It's a class/module with no version.
      $v{$this} = undef;
    } else {
      # It's probably an unpopulated package.
      ## $v{$this} = '...';
    }
    
    $pref = length($this) ? "$this\::" : '';
    push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'};
    #print "Stack: @stack\n";
  }
  push @out, " Modules in memory:\n";
  delete @v{'', '[none]'};
  foreach my $p (sort {lc($a) cmp lc($b)} keys %v) {
    $indent = ' ' x (2 + ($p =~ tr/:/:/));
    push @out,  '  ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n";
  }
  push @out, sprintf "[at %s (local) / %s (GMT)]\n",
    scalar(gmtime), scalar(localtime);
  my $x = join '', @out;
  $x =~ s/^/#/mg;
  print $x;
}

print "# Running",
  (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n",
  "#\n",
;

print "# \@INC:\n", map("#   [$_]\n", @INC), "#\n#\n";

print "# \%INC:\n";
foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) {
  print "#   [$x] = [", $INC{$x} || '', "]\n";
}

ok 1;


--- NEW FILE: onfail.t ---
# -*-perl-*-

use strict;
use Test qw($ntest plan ok $TESTOUT $TESTERR);
use vars qw($mycnt);

BEGIN { plan test => 6, onfail => \&myfail }

$mycnt = 0;

my $why = "zero != one";
# sneak in a test that Test::Harness wont see
open J, ">junk";
$TESTOUT = *J{IO};
$TESTERR = *J{IO};
ok(0, 1, $why);
$TESTOUT = *STDOUT{IO};
$TESTERR = *STDERR{IO};
close J;
unlink "junk";
$ntest = 1;

sub myfail {
    my ($f) = @_;
    ok(@$f, 1);

    my $t = $$f[0];
    ok($$t{diagnostic}, $why);
    ok($$t{'package'}, 'main');
    ok($$t{repetition}, 1);
    ok($$t{result}, 0);
    ok($$t{expected}, 1);
}

--- NEW FILE: multiline.t ---
#!./perl -w

BEGIN { open(STDERR, ">&STDOUT");  }

use strict;
use Test; plan tests => 2, todo => [1,2]; # actually false failure

# perl -Ilib -It/noinck t/multiline.t

ok(
q{
Jojo was a man who thought he was a loner
But he knew it couldn't last
Jojo left his home in Tucson, Arizona
For some California Grass
Get back, get back
Get back to where you once belonged
Get back, get back
Get back to where you once belonged
Get back Jojo Go home
Get back, get back
Back to where you once belonged
Get back, get back
Back to where you once belonged
Get back Jo
}
,
q{
Sweet Loretta Martin thought she was a woman
But she was another man
All the girls around her say she's got it coming
But she gets it while she can
Get back, get back
Get back to where you once belonged
Get back, get back
Get back to where you once belonged
Get back Loretta Go home
Get back, get back
Get back to where you once belonged
Get back, get back
Get back to where you once belonged
Get home Loretta
});

ok "zik\nzak\n  wazaaaaap\ncha ching!\n", "crunk\n\t zonk\nbjork\nchachacha!\n";



--- NEW FILE: qr.t ---
#!./perl -w

use strict;
BEGIN {
    if ($] < 5.005) {
	print "1..0\n";
	print "ok 1 # skipped; this test requires at least perl 5.005\n";
	exit;
    }
}
use Test; plan tests => 1;

ok 'abc', qr/b/;

--- NEW FILE: mix.t ---
# -*-perl-*-
use strict;
use Test qw(:DEFAULT $TESTOUT $TESTERR $ntest);

### This test is crafted in such a way as to prevent Test::Harness from
### seeing the todo tests, otherwise you get people sending in bug reports
### about Test.pm having "UNEXPECTEDLY SUCCEEDED" tests.

open F, ">mix";
$TESTOUT = *F{IO};
$TESTERR = *F{IO};

plan tests => 4, todo => [2,3];

# line 15
ok(sub { 
       my $r = 0;
       for (my $x=0; $x < 10; $x++) {
	   $r += $x*($r+1);
       }
       $r
   }, 3628799);

ok(0);
ok(1);

skip(1,0);

close F;
$TESTOUT = *STDOUT{IO};
$TESTERR = *STDERR{IO};
$ntest = 1;

open F, "mix";
my $out = join '', <F>;
close F;
unlink "mix";

my $expect = <<"EXPECT";
1..4 todo 2 3;
ok 1
not ok 2
# Failed test 2 in $0 at line 23 *TODO*
ok 3 # ($0 at line 24 TODO?!)
ok 4 # skip
EXPECT


sub commentless {
  my $in = $_[0];
  $in =~ s/^#[^\n]*\n//mg;
  $in =~ s/\n#[^\n]*$//mg;
  return $in;
}


print "1..1\n";
ok( commentless($out), commentless($expect) );

--- NEW FILE: success.t ---
# -*-perl-*-
use strict;
use Test;
BEGIN { plan tests => 11 }

ok(ok(1));
ok(ok('fixed', 'fixed'));
ok(skip("just testing skip()",0));
ok(undef, undef);
ok(ok 'the brown fox jumped over the lazy dog', '/lazy/');
ok(ok 'the brown fox jumped over the lazy dog', 'm,fox,');

--- NEW FILE: fail.t ---
# -*-perl-*-
use strict;
use vars qw($Expect);
use Test qw($TESTOUT $TESTERR $ntest ok skip plan); 
plan tests => 14;

open F, ">fails";
$TESTOUT = *F{IO};
$TESTERR = *F{IO};

my $r=0;
{
    # Shut up deprecated usage warning.
    local $^W = 0;
    $r |= skip(0,0);
}
$r |= ok(0);
$r |= ok(0,1);
$r |= ok(sub { 1+1 }, 3);
$r |= ok(sub { 1+1 }, sub { 2 * 0});

my @list = (0,0);
$r |= ok @list, 1, "\@list=".join(',', at list);
$r |= ok @list, 1, sub { "\@list=".join ',', at list };
$r |= ok 'segmentation fault', '/bongo/';

for (1..2) { $r |= ok(0); }

$r |= ok(1, undef);
$r |= ok(undef, 1);

ok($r); # (failure==success :-)

close F;
$TESTOUT = *STDOUT{IO};
$TESTERR = *STDERR{IO};
$ntest = 1;

open F, "fails";
my $O;
while (<F>) { $O .= $_; }
close F;
unlink "fails";

ok join(' ', map { m/(\d+)/; $1 } grep /^not ok/, split /\n+/, $O),
    join(' ', 1..13);

my @got = split /not ok \d+\n/, $O;
shift @got;

$Expect =~ s/\n+$//;
my @expect = split /\n\n/, $Expect;


sub commentless {
  my $in = $_[0];
  $in =~ s/^#[^\n]*\n//mg;
  $in =~ s/\n#[^\n]*$//mg;
  return $in;
}


for (my $x=0; $x < @got; $x++) {
    ok commentless($got[$x]), commentless($expect[$x]."\n");
}


BEGIN {
    $Expect = <<"EXPECT";
# Failed test 1 in $0 at line 15

# Failed test 2 in $0 at line 17

# Test 3 got: '0' ($0 at line 18)
#   Expected: '1'

# Test 4 got: '2' ($0 at line 19)
#   Expected: '3'

# Test 5 got: '2' ($0 at line 20)
#   Expected: '0'

# Test 6 got: '2' ($0 at line 23)
#   Expected: '1' (\@list=0,0)

# Test 7 got: '2' ($0 at line 24)
#   Expected: '1' (\@list=0,0)

# Test 8 got: 'segmentation fault' ($0 at line 25)
#   Expected: qr{bongo}

# Failed test 9 in $0 at line 27

# Failed test 10 in $0 at line 27 fail #2

# Failed test 11 in $0 at line 29

# Test 12 got: <UNDEF> ($0 at line 30)
#    Expected: '1'

# Failed test 13 in $0 at line 32
EXPECT

}