print "1..0 # Skip: Storable was not built\n";
exit 0;
}
- require 'st-dump.pl';
}
-sub ok;
+use Test::More;
use Storable qw(freeze thaw store retrieve);
my $test = 12;
my $tests = $test + 22 + 2 * 6 * keys %::immortals;
-print "1..$tests\n";
+plan(tests => $tests);
package SHORT_NAME;
\@ISA = ("SHORT_NAME");
EOC
-die $@ if $@;
-ok 1, $@ eq '';
+is($@, '');
eval <<EOC;
package ${name}_WITH_HOOK;
\@ISA = ("SHORT_NAME_WITH_HOOK");
EOC
-ok 2, $@ eq '';
+is($@, '');
# Construct a pool of objects
my @pool;
}
my $x = freeze \@pool;
-ok 3, 1;
+pass("Freeze didn't crash");
my $y = thaw $x;
-ok 4, ref $y eq 'ARRAY';
-ok 5, @{$y} == @pool;
+is(ref $y, 'ARRAY');
+is(scalar @{$y}, @pool);
-ok 6, ref $y->[0] eq 'SHORT_NAME';
-ok 7, ref $y->[1] eq 'SHORT_NAME_WITH_HOOK';
-ok 8, ref $y->[2] eq $name;
-ok 9, ref $y->[3] eq "${name}_WITH_HOOK";
+is(ref $y->[0], 'SHORT_NAME');
+is(ref $y->[1], 'SHORT_NAME_WITH_HOOK');
+is(ref $y->[2], $name);
+is(ref $y->[3], "${name}_WITH_HOOK");
my $good = 1;
for (my $i = 0; $i < 10; $i++) {
do { $good = 0; last } unless ref $y->[4*$i+2] eq $name;
do { $good = 0; last } unless ref $y->[4*$i+3] eq "${name}_WITH_HOOK";
}
-ok 10, $good;
+is($good, 1);
{
my $blessed_ref = bless \\[1,2,3], 'Foobar';
my $x = freeze $blessed_ref;
my $y = thaw $x;
- ok 11, ref $y eq 'Foobar';
- ok 12, $$$y->[0] == 1;
+ is(ref $y, 'Foobar');
+ is($$$y->[0], 1);
}
package RETURNS_IMMORTALS;
my ($x, @refs) = @_;
my ($what, $times) = $x =~ /(.)(\d+)/;
die "'$x' didn't match" unless defined $times;
- main::ok ++$test, @refs == $times;
+ main::is(scalar @refs, $times);
my $expect = $::immortals{$what};
die "'$x' did not give a reference" unless ref $expect;
my $fail;
foreach (@refs) {
$fail++ if $_ != $expect;
}
- main::ok ++$test, !$fail;
+ main::is($fail, undef);
}
package main;
my $i = RETURNS_IMMORTALS->make ($immortal, $count);
my $f = freeze ($i);
- ok ++$test, $f;
+ isnt($f, undef);
my $t = thaw $f;
- ok ++$test, 1;
+ pass("thaw didn't crash");
}
}
my $f = freeze (HAS_HOOK->make);
-ok ++$test, $HAS_HOOK::loaded_count == 0;
-ok ++$test, $HAS_HOOK::thawed_count == 0;
+is($HAS_HOOK::loaded_count, 0);
+is($HAS_HOOK::thawed_count, 0);
my $t = thaw $f;
-ok ++$test, $HAS_HOOK::loaded_count == 1;
-ok ++$test, $HAS_HOOK::thawed_count == 1;
-ok ++$test, $t;
-ok ++$test, ref $t eq 'HAS_HOOK';
+is($HAS_HOOK::loaded_count, 1);
+is($HAS_HOOK::thawed_count, 1);
+isnt($t, undef);
+is(ref $t, 'HAS_HOOK');
delete $INC{"HAS_HOOK.pm"};
delete $HAS_HOOK::{STORABLE_thaw};
$t = thaw $f;
-ok ++$test, $HAS_HOOK::loaded_count == 2;
-ok ++$test, $HAS_HOOK::thawed_count == 2;
-ok ++$test, $t;
-ok ++$test, ref $t eq 'HAS_HOOK';
+is($HAS_HOOK::loaded_count, 2);
+is($HAS_HOOK::thawed_count, 2);
+isnt($t, undef);
+is(ref $t, 'HAS_HOOK');
{
package STRESS_THE_STACK;
$f = freeze (STRESS_THE_STACK->make);
-ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
-ok ++$test, $STRESS_THE_STACK::thaw_count == 0;
+is($STRESS_THE_STACK::freeze_count, 1);
+is($STRESS_THE_STACK::thaw_count, 0);
$t = thaw $f;
-ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
-ok ++$test, $STRESS_THE_STACK::thaw_count == 1;
-ok ++$test, $t;
-ok ++$test, ref $t eq 'STRESS_THE_STACK';
+is($STRESS_THE_STACK::freeze_count, 1);
+is($STRESS_THE_STACK::thaw_count, 1);
+isnt($t, undef);
+is(ref $t, 'STRESS_THE_STACK');
my $file = "storable-testfile.$$";
die "Temporary file '$file' already exists" if -e $file;
store (STRESS_THE_STACK->make, $file);
-ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
-ok ++$test, $STRESS_THE_STACK::thaw_count == 0;
+is($STRESS_THE_STACK::freeze_count, 1);
+is($STRESS_THE_STACK::thaw_count, 0);
$t = retrieve ($file);
-ok ++$test, $STRESS_THE_STACK::freeze_count == 1;
-ok ++$test, $STRESS_THE_STACK::thaw_count == 1;
-ok ++$test, $t;
-ok ++$test, ref $t eq 'STRESS_THE_STACK';
+is($STRESS_THE_STACK::freeze_count, 1);
+is($STRESS_THE_STACK::thaw_count, 1);
+isnt($t, undef);
+is(ref $t, 'STRESS_THE_STACK');
use Storable qw(freeze thaw dclone);
use vars qw($debugging $verbose);
-print "1..8\n";
-
-sub ok {
- my($testno, $ok) = @_;
- print "not " unless $ok;
- print "ok $testno\n";
-}
-
+use Test::More tests => 8;
# Uncomment the folowing line to get a dump of the constructed data structure
# (you may want to reduce the size of the hashes too)
$x2 = freeze(\%a2);
$x3 = freeze($a3);
-ok 1, (length($x1) > $hashsize); # sanity check
-ok 2, length($x1) == length($x2); # idem
-ok 3, $x1 eq $x2;
-ok 4, $x1 eq $x3;
+cmp_ok(length $x1, '>', $hashsize); # sanity check
+is(length $x1, length $x2); # idem
+is($x1, $x2);
+is($x1, $x3);
# In normal mode it is exceedingly unlikely that the frozen
# representaions of all the hashes will be the same (normally the hash
# is much, much more unlikely. Still it could happen, so this test
# may report a false negative.
-ok 5, ($x1 ne $x2) || ($x1 ne $x3);
+ok(($x1 ne $x2) || ($x1 ne $x3));
# Ensure refs to "undef" values are properly shared
my $hash;
push @{$$hash{''}}, \$$hash{a};
-ok 6, $$hash{''}[0] == \$$hash{a};
+is($$hash{''}[0], \$$hash{a});
my $cloned = dclone(dclone($hash));
-ok 7, $$cloned{''}[0] == \$$cloned{a};
+is($$cloned{''}[0], \$$cloned{a});
$$cloned{a} = "blah";
-ok 8, $$cloned{''}[0] == \$$cloned{a};
+is($$cloned{''}[0], \$$cloned{a});
use strict;
use Storable qw(retrieve);
+use Test::More;
my $file = "xx-$$.pst";
my @dumps = (
"perl-store\0\x041234\4\4\4\x94y\22\b\3\1\0\0\0vxz\22\b\b\x81Xk\3\0\0\0oneX", # 0.4@7
);
-print "1.." . @dumps . "\n";
+plan(tests => 3 * @dumps);
my $testno;
for my $dump (@dumps) {
print FH $dump;
close(FH) || die "Can't write $file: $!";
- eval {
- my $data = retrieve($file);
- if (ref($data) eq "HASH" && $data->{one} eq "1") {
- print "ok $testno\n";
- }
- else {
- print "not ok $testno\n";
- }
- };
- warn $@ if $@;
+ my $data = eval { retrieve($file) };
+ is($@, '', "No errors for $file");
+ is(ref $data, 'HASH', "Got HASH for $file");
+ is($data->{one}, 1, "Got data for $file");
unlink($file);
}
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
- require 'st-dump.pl';
}
-sub ok;
-
-print "1..8\n";
+use Test::More tests => 8;
use Storable qw(freeze nfreeze thaw);
}
my $expected_length = $is_EBCDIC ? 217 : 278;
-ok 1, length $data == $expected_length;
+is(length $data, $expected_length);
my $y = thaw($data);
-ok 2, 1;
-ok 3, ref $y eq 'ROOT';
+isnt($y, undef);
+is(ref $y, 'ROOT');
$Storable::canonical = 1; # Prevent "used once" warning
$Storable::canonical = 1;
# Allow for long double string conversions.
$y->{num}->[3] += 0;
$r->{num}->[3] += 0;
-ok 4, nfreeze($y) eq nfreeze($r);
+is(nfreeze($y), nfreeze($r));
-ok 5, $y->ref->{key1} eq 'val1';
-ok 6, $y->ref->{key2} eq 'val2';
-ok 7, $hash_fetch == 2;
+is($y->ref->{key1}, 'val1');
+is($y->ref->{key2}, 'val2');
+is($hash_fetch, 2);
my $num = $r->num;
my $ok = 1;
for (my $i = 0; $i < @$num; $i++) {
do { $ok = 0; last } unless $num->[$i] == $y->num->[$i];
}
-ok 8, $ok;
+is($ok, 1);
__END__
#
use Storable qw(dclone);
-print "1..12\n";
+use Test::More tests => 14;
$a = 'toto';
$b = \$a;
@a = ('first', undef, 3, -4, -3.14159, 456, 4.5,
$b, \$a, $a, $c, \$c, \%a);
-print "not " unless defined ($aref = dclone(\@a));
-print "ok 1\n";
+my $aref = dclone(\@a);
+isnt($aref, undef);
$dumped = &dump(\@a);
-print "ok 2\n";
+isnt($dumped, undef);
$got = &dump($aref);
-print "ok 3\n";
+isnt($got, undef);
-print "not " unless $got eq $dumped;
-print "ok 4\n";
+is($got, $dumped);
package FOO; @ISA = qw(Storable);
package main;
$foo = FOO->make;
-print "not " unless defined($r = $foo->dclone);
-print "ok 5\n";
+my $r = $foo->dclone;
+isnt($r, undef);
-print "not " unless &dump($foo) eq &dump($r);
-print "ok 6\n";
+is(&dump($foo), &dump($r));
# Ensure refs to "undef" values are properly shared during cloning
my $hash;
push @{$$hash{''}}, \$$hash{a};
-print "not " unless $$hash{''}[0] == \$$hash{a};
-print "ok 7\n";
+is($$hash{''}[0], \$$hash{a});
my $cloned = dclone(dclone($hash));
-print "not " unless $$cloned{''}[0] == \$$cloned{a};
-print "ok 8\n";
+is($$cloned{''}[0], \$$cloned{a});
$$cloned{a} = "blah";
-print "not " unless $$cloned{''}[0] == \$$cloned{a};
-print "ok 9\n";
+is($$cloned{''}[0], \$$cloned{a});
# [ID 20020221.007] SEGV in Storable with empty string scalar object
package TestString;
my $empty_string_obj = TestString->new('');
my $clone = dclone($empty_string_obj);
# If still here after the dclone the fix (#17543) worked.
-print ref $clone eq ref $empty_string_obj &&
- $$clone eq $$empty_string_obj &&
- $$clone eq '' ? "ok 10\n" : "not ok 10\n";
+is(ref $clone, ref $empty_string_obj);
+is($$clone, $$empty_string_obj);
+is($$clone, '');
+SKIP: {
# Do not fail if Tie::Hash and/or Tie::StdHash is not available
-if (eval { require Tie::Hash; scalar keys %Tie::StdHash:: }) {
+ skip 'No Tie::StdHash available', 2
+ unless eval { require Tie::Hash; scalar keys %Tie::StdHash:: };
tie my %tie, "Tie::StdHash" or die $!;
$tie{array} = [1,2,3,4];
$tie{hash} = {1,2,3,4};
my $clone_array = dclone $tie{array};
- print "not " unless "@$clone_array" eq "@{$tie{array}}";
- print "ok 11\n";
+ is("@$clone_array", "@{$tie{array}}");
my $clone_hash = dclone $tie{hash};
- print "not " unless $clone_hash->{1} eq $tie{hash}{1};
- print "ok 12\n";
-} else {
- print <<EOF;
-ok 11 # skip No Tie::StdHash available
-ok 12 # skip No Tie::StdHash available
-EOF
+ is($clone_hash->{1}, $tie{hash}{1});
}
}
use Storable qw(store retrieve);
+use Test::More;
# problems with 5.00404 when in an BEGIN block, so this is defined here
if (!eval { require File::Spec; 1 } || $File::Spec::VERSION < 0.8) {
- print "1..0 # Skip: File::Spec 0.8 needed\n";
- exit 0;
+ plan(skip_all => "File::Spec 0.8 needed");
# Mention $File::Spec::VERSION again, as 5.00503's harness seems to have
# warnings on.
exit $File::Spec::VERSION;
}
-print "1..8\n";
+plan(tests => 8);
-my $test = 1;
*GLOB = *GLOB; # peacify -w
my $bad = ['foo', \*GLOB, 'bar'];
my $result;
eval {$result = store ($bad , 'store')};
-print ((!defined $result)?"ok $test\n":"not ok $test\n"); $test++;
-print (($@ ne '')?"ok $test\n":"not ok $test\n"); $test++;
+is($result, undef);
+isnt($@, '');
$Storable::forgive_me=1;
open(STDERR, ">&SAVEERR");
-print ((defined $result)?"ok $test\n":"not ok $test\n"); $test++;
-print (($@ eq '')?"ok $test\n":"not ok $test\n"); $test++;
+isnt($result, undef);
+is($@, '');
my $ret = retrieve('store');
-print ((defined $ret)?"ok $test\n":"not ok $test\n"); $test++;
-print (($ret->[0] eq 'foo')?"ok $test\n":"not ok $test\n"); $test++;
-print (($ret->[2] eq 'bar')?"ok $test\n":"not ok $test\n"); $test++;
-print ((ref $ret->[1] eq 'SCALAR')?"ok $test\n":"not ok $test\n"); $test++;
+isnt($ret, undef);
+is($ret->[0], 'foo');
+is($ret->[2], 'bar');
+is(ref $ret->[1], 'SCALAR');
END { 1 while unlink 'store' }
exit 0;
}
require 'st-dump.pl';
- sub ok;
}
use Storable qw(freeze nfreeze thaw);
-print "1..20\n";
+use Test::More tests => 21;
$a = 'toto';
$b = \$a;
@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, $d, \$d, \$e, $e,
$b, \$a, $a, $c, \$c, \%a);
-print "not " unless defined ($f1 = freeze(\@a));
-print "ok 1\n";
+my $f1 = freeze(\@a);
+isnt($f1, undef);
$dumped = &dump(\@a);
-print "ok 2\n";
+isnt($dumped, undef);
$root = thaw($f1);
-print "not " unless defined $root;
-print "ok 3\n";
+isnt($root, undef);
$got = &dump($root);
-print "ok 4\n";
+isnt($got, undef);
-print "not " unless $got eq $dumped;
-print "ok 5\n";
+is($got, $dumped);
package FOO; @ISA = qw(Storable);
package main;
$foo = FOO->make;
-print "not " unless $f2 = $foo->freeze;
-print "ok 6\n";
+my $f2 = $foo->freeze;
+isnt($f2, undef);
-print "not " unless $f3 = $foo->nfreeze;
-print "ok 7\n";
+my $f3 = $foo->nfreeze;
+isnt($f3, undef);
$root3 = thaw($f3);
-print "not " unless defined $root3;
-print "ok 8\n";
+isnt($root3, undef);
-print "not " unless &dump($foo) eq &dump($root3);
-print "ok 9\n";
+is(&dump($foo), &dump($root3));
$root = thaw($f2);
-print "not " unless &dump($foo) eq &dump($root);
-print "ok 10\n";
+is(&dump($foo), &dump($root));
-print "not " unless &dump($root3) eq &dump($root);
-print "ok 11\n";
+is(&dump($root3), &dump($root));
$other = freeze($root);
-print "not " unless length($other) == length($f2);
-print "ok 12\n";
+is(length$other, length $f2);
$root2 = thaw($other);
-print "not " unless &dump($root2) eq &dump($root);
-print "ok 13\n";
+is(&dump($root2), &dump($root));
$VAR1 = [
'method',
$x = nfreeze($VAR1);
$VAR2 = thaw($x);
-print "not " unless $VAR2->[3] eq $VAR1->[3];
-print "ok 14\n";
+is($VAR2->[3], $VAR1->[3]);
# Test the workaround for LVALUE bug in perl 5.004_04 -- from Gisle Aas
sub foo { $_[0] = 1 }
$foo = [];
foo($foo->[1]);
eval { freeze($foo) };
-print "not " if $@;
-print "ok 15\n";
+is($@, '');
# Test cleanup bug found by Claudio Garcia -- RAM, 08/06/2001
my $thaw_me = 'asdasdasdasd';
eval {
my $thawed = thaw $thaw_me;
};
-ok 16, $@;
+isnt($@, '');
my %to_be_frozen = (foo => 'bar');
my $frozen;
eval {
$frozen = freeze \%to_be_frozen;
};
-ok 17, !$@;
+is($@, '');
freeze {};
eval { thaw $thaw_me };
eval { $frozen = freeze { foo => {} } };
-ok 18, !$@;
+is($@, '');
thaw $frozen; # used to segfault here
-ok 19, 1;
+pass("Didn't segfault");
-if ($] >= 5.006) {
+SKIP: {
+ skip 'no av_exists', 2 unless $] >= 5.006;
+ my (@a, @b);
eval '
$a = []; $#$a = 2; $a->[1] = undef;
$b = thaw freeze $a;
@a = map { ~~ exists $a->[$_] } 0 .. $#$a;
@b = map { ~~ exists $b->[$_] } 0 .. $#$b;
- ok 20, "@a" eq "@b";
';
-}
-else {
- print "ok 20 # skipped (no av_exists)\n";
+ is($@, '');
+ is("@a", "@b");
}
require 'st-dump.pl';
}
-sub ok;
-
+use Test::More;
use Storable qw(lock_store lock_retrieve);
unless (&Storable::CAN_FLOCK) {
- print "1..0 # Skip: fcntl/flock emulation broken on this platform\n";
- exit 0;
+ plan(skip_all => "fcntl/flock emulation broken on this platform");
}
-print "1..5\n";
+plan(tests => 5);
@a = ('first', undef, 3, -4, -3.14159, 456, 4.5);
# We're just ensuring things work, we're not validating locking.
#
-ok 1, defined lock_store(\@a, 'store');
-ok 2, $dumped = &dump(\@a);
+isnt(lock_store(\@a, 'store'), undef);
+my $dumped = &dump(\@a);
+isnt($dumped, undef);
$root = lock_retrieve('store');
-ok 3, ref $root eq 'ARRAY';
-ok 4, @a == @$root;
-ok 5, &dump($root) eq $dumped;
+is(ref $root, 'ARRAY');
+is(scalar @a, scalar @$root);
+is(&dump($root), $dumped);
unlink 't/store';
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
- require 'st-dump.pl';
}
-sub ok;
-
use Storable qw(freeze thaw);
-print "1..19\n";
+use Test::More tests => 19;
package OVERLOADED;
$a = bless [77], OVERLOADED;
$b = thaw freeze $a;
-ok 1, ref $b eq 'OVERLOADED';
-ok 2, "$b" eq "77";
+is(ref $b, 'OVERLOADED');
+is("$b", "77");
$c = thaw freeze \$a;
-ok 3, ref $c eq 'REF';
-ok 4, ref $$c eq 'OVERLOADED';
-ok 5, "$$c" eq "77";
+is(ref $c, 'REF');
+is(ref $$c, 'OVERLOADED');
+is("$$c", "77");
$d = thaw freeze [$a, $a];
-ok 6, "$d->[0]" eq "77";
+is("$d->[0]", "77");
$d->[0][0]++;
-ok 7, "$d->[1]" eq "78";
+is("$d->[1]", "78");
package REF_TO_OVER;
$a = OVER->make();
$b = thaw freeze $a;
-ok 8, ref $b eq 'OVER';
-ok 9, $a + $a == 314;
-ok 10, ref $b->{ref} eq 'REF_TO_OVER';
-ok 11, "$b->{ref}->{over}" eq "$b";
-ok 12, $b + $b == 314;
+is(ref $b, 'OVER');
+is($a + $a, 314);
+is(ref $b->{ref}, 'REF_TO_OVER');
+is("$b->{ref}->{over}", "$b");
+is($b + $b, 314);
# nfreeze data generated by make_overload.pl
my $f = '';
# use a reference to an overloaded reference, rather than just a reference.
my $t = eval {thaw $f};
print "# $@" if $@;
-ok 13, $@ eq "";
-ok 14, ref ($t) eq 'REF';
-ok 15, ref ($$t) eq 'HAS_OVERLOAD';
-ok 16, $$$t eq 'snow';
+is($@, "");
+is(ref ($t), 'REF');
+is(ref ($$t), 'HAS_OVERLOAD');
+is($$$t, 'snow');
#---
{
my $a = bless [88], 'OVERLOADED';
my $c = thaw freeze bless \$a, 'main';
- ok 17, ref $c eq 'main';
- ok 18, ref $$c eq 'OVERLOADED';
- ok 19, "$$c" eq "88";
+ is(ref $c, 'main');
+ is(ref $$c, 'OVERLOADED');
+ is("$$c", "88");
}
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
- require 'st-dump.pl';
}
-sub ok;
-
use Storable qw(freeze thaw dclone);
-
-print "1..33\n";
+use Test::More tests => 33;
package OBJ_REAL;
my $real = OBJ_REAL->make;
my $x = freeze $real;
-ok 1, 1;
+isnt($x, undef);
my $y = thaw $x;
-ok 2, ref $y eq 'OBJ_REAL';
-ok 3, $y->[0] eq 'a';
-ok 4, $y->[1] == 1;
+is(ref $y, 'OBJ_REAL');
+is($y->[0], 'a');
+is($y->[1], 1);
my $sync = OBJ_SYNC->make;
$x = freeze $sync;
-ok 5, 1;
+isnt($x, undef);
$y = thaw $x;
-ok 6, 1;
-ok 7, $y->{ok} == $y;
+is(ref $y, 'OBJ_SYNC');
+is($y->{ok}, $y);
my $ext = [1, 2];
$sync = OBJ_SYNC2->make($ext);
$x = freeze [$sync, $ext];
-ok 8, 1;
+isnt($x, undef);
my $z = thaw $x;
$y = $z->[0];
-ok 9, 1;
-ok 10, $y->{ok} == $y;
-ok 11, ref $y->{sync} eq 'OBJ_SYNC';
-ok 12, $y->{ext} == $z->[1];
+is(ref $y, 'OBJ_SYNC2');
+is($y->{ok}, $y);
+is(ref $y->{sync}, 'OBJ_SYNC');
+is($y->{ext}, $z->[1]);
$real = OBJ_REAL2->make;
$x = freeze $real;
-ok 13, 1;
-ok 14, $OBJ_REAL2::recursed == $OBJ_REAL2::MAX;
-ok 15, $OBJ_REAL2::hook_called == $OBJ_REAL2::MAX;
+isnt($x, undef);
+is($OBJ_REAL2::recursed, $OBJ_REAL2::MAX);
+is($OBJ_REAL2::hook_called, $OBJ_REAL2::MAX);
$y = thaw $x;
-ok 16, 1;
-ok 17, $OBJ_REAL2::recursed == 0;
+is(ref $y, 'OBJ_REAL2');
+is($OBJ_REAL2::recursed, 0);
$x = dclone $real;
-ok 18, 1;
-ok 19, ref $x eq 'OBJ_REAL2';
-ok 20, $OBJ_REAL2::recursed == 0;
-ok 21, $OBJ_REAL2::hook_called == 2 * $OBJ_REAL2::MAX;
+isnt($x, undef);
+is(ref $x, 'OBJ_REAL2');
+is($OBJ_REAL2::recursed, 0);
+is($OBJ_REAL2::hook_called, 2 * $OBJ_REAL2::MAX);
-ok 22, !Storable::is_storing;
-ok 23, !Storable::is_retrieving;
+is(Storable::is_storing, '');
+is(Storable::is_retrieving, '');
#
# The following was a test-case that Salvador Ortiz Garcia <sog@msg.com.mx>
my $bar = new Bar;
my $bar2 = thaw freeze $bar;
-ok 24, ref($bar2) eq 'Bar';
-ok 25, ref($bar->{b}[0]) eq 'Foo';
-ok 26, ref($bar->{b}[1]) eq 'Foo';
-ok 27, ref($bar2->{b}[0]) eq 'Foo';
-ok 28, ref($bar2->{b}[1]) eq 'Foo';
+is(ref($bar2), 'Bar');
+is(ref($bar->{b}[0]), 'Foo');
+is(ref($bar->{b}[1]), 'Foo');
+is(ref($bar2->{b}[0]), 'Foo');
+is(ref($bar2->{b}[1]), 'Foo');
#
# The following attempts to make sure blessed objects are blessed ASAP
sub STORABLE_thaw {
my($self, $clonning, $frozen, $c1, $c3, $o) = @_;
- main::ok 29, ref $self eq "CLASS_2";
- main::ok 30, ref $c1 eq "CLASS_1";
- main::ok 31, ref $c3 eq "CLASS_3";
- main::ok 32, ref $o eq "CLASS_OTHER";
+ main::is(ref $self, "CLASS_2");
+ main::is(ref $c1, "CLASS_1");
+ main::is(ref $c3, "CLASS_3");
+ main::is(ref $o, "CLASS_OTHER");
$self->{c1} = $c1;
$self->{c3} = $c3;
}
$refcount_ok = 0;
thaw freeze(Foo3->new);
-ok 33, $refcount_ok == 1;
+is($refcount_ok, 1);
}
unshift @INC, 't';
}
- require 'st-dump.pl';
}
use Storable qw(dclone freeze thaw);
use Hash::Util qw(lock_hash unlock_value);
-
-print "1..100\n";
+use Test::More tests => 100;
my %hash = (question => '?', answer => 42, extra => 'junk', undef => undef);
lock_hash %hash;
my @in_keys = sort keys %$hash;
my @out_keys = sort keys %$copy;
- unless (ok ++$test, "@in_keys" eq "@out_keys") {
- print "# Failed: keys mis-match after deep clone.\n";
- print "# Original keys: @in_keys\n";
- print "# Copy's keys: @out_keys\n";
- }
+ is("@in_keys", "@out_keys", "keys match after deep clone");
# $copy = $hash; # used in initial debug of the tests
- ok ++$test, Internals::SvREADONLY(%$copy), "cloned hash restricted?";
+ is(Internals::SvREADONLY(%$copy), 1, "cloned hash restricted?");
- ok ++$test, Internals::SvREADONLY($copy->{question}),
- "key 'question' not locked in copy?";
+ is(Internals::SvREADONLY($copy->{question}), 1,
+ "key 'question' not locked in copy?");
- ok ++$test, !Internals::SvREADONLY($copy->{answer}),
- "key 'answer' not locked in copy?";
+ is(Internals::SvREADONLY($copy->{answer}), '',
+ "key 'answer' not locked in copy?");
eval { $copy->{extra} = 15 } ;
- unless (ok ++$test, !$@, "Can assign to reserved key 'extra'?") {
- my $diag = $@;
- $diag =~ s/\n.*\z//s;
- print "# \$\@: $diag\n";
- }
+ is($@, '', "Can assign to reserved key 'extra'?");
eval { $copy->{nono} = 7 } ;
- ok ++$test, $@, "Can not assign to invalid key 'nono'?";
+ isnt($@, '', "Can not assign to invalid key 'nono'?");
- ok ++$test, exists $copy->{undef},
- "key 'undef' exists";
+ is(exists $copy->{undef}, 1, "key 'undef' exists");
- ok ++$test, !defined $copy->{undef},
- "value for key 'undef' is undefined";
+ is($copy->{undef}, undef, "value for key 'undef' is undefined");
}
for $Storable::canonical (0, 1) {
for my $cloner (\&dclone, \&freeze_thaw) {
- print "# \$Storable::canonical = $Storable::canonical\n";
+ note("\$Storable::canonical = $Storable::canonical");
testit (\%hash, $cloner);
my $object = \%hash;
# bless {}, "Restrict_Test";
for (0..16) {
my $k = "k$_";
eval { $copy->{$k} = undef } ;
- unless (ok ++$test, !$@, "Can assign to reserved key '$k'?") {
- my $diag = $@;
- $diag =~ s/\n.*\z//s;
- print "# \$\@: $diag\n";
- }
+ is($@, '', "Can assign to reserved key '$k'?");
}
}
}
use Storable qw(store retrieve nstore);
-
-print "1..14\n";
+use Test::More tests => 14;
$a = 'toto';
$b = \$a;
@a = ('first', '', undef, 3, -4, -3.14159, 456, 4.5,
$b, \$a, $a, $c, \$c, \%a);
-print "not " unless defined store(\@a, 'store');
-print "ok 1\n";
-print "not " if Storable::last_op_in_netorder();
-print "ok 2\n";
-print "not " unless defined nstore(\@a, 'nstore');
-print "ok 3\n";
-print "not " unless Storable::last_op_in_netorder();
-print "ok 4\n";
-print "not " unless Storable::last_op_in_netorder();
-print "ok 5\n";
+isnt(store(\@a, 'store'), undef);
+is(Storable::last_op_in_netorder(), '');
+isnt(nstore(\@a, 'nstore'), undef);
+is(Storable::last_op_in_netorder(), 1);
+is(Storable::last_op_in_netorder(), 1);
$root = retrieve('store');
-print "not " unless defined $root;
-print "ok 6\n";
-print "not " if Storable::last_op_in_netorder();
-print "ok 7\n";
+isnt($root, undef);
+is(Storable::last_op_in_netorder(), '');
$nroot = retrieve('nstore');
-print "not " unless defined $nroot;
-print "ok 8\n";
-print "not " unless Storable::last_op_in_netorder();
-print "ok 9\n";
+isnt($root, undef);
+is(Storable::last_op_in_netorder(), 1);
$d1 = &dump($root);
-print "ok 10\n";
+isnt($d1, undef);
$d2 = &dump($nroot);
-print "ok 11\n";
+isnt($d2, undef);
-print "not " unless $d1 eq $d2;
-print "ok 12\n";
+is($d1, $d2);
# Make sure empty string is defined at retrieval time
-print "not " unless defined $root->[1];
-print "ok 13\n";
-print "not " if length $root->[1];
-print "ok 14\n";
+isnt($root->[1], undef);
+is(length $root->[1], 0);
END { 1 while unlink('store', 'nstore') }
}
use strict;
-BEGIN {
- if (!eval q{
- use Test::More;
- 1;
- }) {
- print "1..0 # skip: tests only work with Test::More\n";
- exit;
- }
-}
-
-BEGIN { plan tests => 1 }
+use Test::More tests => 1;
my @warns;
$SIG{__WARN__} = sub { push @warns, shift };
# in the README file that comes with the distribution.
#
-# NOTE THAT THIS FILE IS COPIED FROM ext/Storable/t/st-dump.pl
-# TO t/lib/st-dump.pl. One could also play games with
-# File::Spec->updir and catdir to get the st-dump.pl in
-# ext/Storable into @INC.
-
-sub ok {
- my ($num, $ok, $name) = @_;
- $num .= " - $name" if defined $name and length $name;
- print $ok ? "ok $num\n" : "not ok $num\n";
- $ok;
-}
-
-sub num_equal {
- my ($num, $left, $right, $name) = @_;
- my $ok = ((defined $left) ? $left == $right : undef);
- unless (ok ($num, $ok, $name)) {
- print "# Expected $right\n";
- if (!defined $left) {
- print "# Got undef\n";
- } elsif ($left !~ tr/0-9//c) {
- print "# Got $left\n";
- } else {
- $left =~ s/([^-a-zA-Z0-9_+])/sprintf "\\%03o", ord $1/ge;
- print "# Got \"$left\"\n";
- }
- }
- $ok;
-}
-
package dump;
use Carp;
require 'st-dump.pl';
}
-sub ok;
-
use Storable qw(freeze thaw);
-
-print "1..23\n";
+use Test::More tests => 23;
($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
$b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
-ok 1, defined($f = freeze(\@a));
+my $f = freeze(\@a);
+isnt($f, undef);
$dumped = &dump(\@a);
-ok 2, 1;
+isnt($dumped, undef);
$root = thaw($f);
-ok 3, defined $root;
+isnt($root, undef);
$got = &dump($root);
-ok 4, 1;
+isnt($got, undef);
### Used to see the manifestation of the bug documented above.
### print "original: $dumped";
### print "got: $got";
### print "--------\n";
-ok 5, $got eq $dumped;
+is($got, $dumped);
$g = freeze($root);
-ok 6, length($f) == length($g);
+is(length $f, length $g);
# Ensure the tied items in the retrieved image work
@old = ($scalar_fetch, $array_fetch, $hash_fetch);
@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
@type = qw(SCALAR ARRAY HASH);
-ok 7, tied $$tscalar;
-ok 8, tied @{$tarray};
-ok 9, tied %{$thash};
+is(ref tied $$tscalar, 'TIED_SCALAR');
+is(ref tied @$tarray, 'TIED_ARRAY');
+is(ref tied %$thash, 'TIED_HASH');
@new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
@new = ($scalar_fetch, $array_fetch, $hash_fetch);
# Tests 10..15
for ($i = 0; $i < @new; $i++) {
- print "not " unless $new[$i] == $old[$i] + 1;
- printf "ok %d\n", 10 + 2*$i; # Tests 10,12,14
- print "not " unless ref $tied[$i] eq $type[$i];
- printf "ok %d\n", 11 + 2*$i; # Tests 11,13,15
+ is($new[$i], $old[$i] + 1);
+ is(ref $tied[$i], $type[$i]);
}
# Check undef ties
my $h = {};
tie $h->{'x'}, 'FAULT', $h, 'x';
my $hf = freeze($h);
-ok 16, defined $hf;
-ok 17, $FAULT::fault == 0;
-ok 18, $h->{'x'} == 1;
-ok 19, $FAULT::fault == 1;
+isnt($hf, undef);
+is($FAULT::fault, 0);
+is($h->{'x'}, 1);
+is($FAULT::fault, 1);
my $ht = thaw($hf);
-ok 20, defined $ht;
-ok 21, $ht->{'x'} == 1;
-ok 22, $FAULT::fault == 2;
+isnt($ht, undef);
+is($ht->{'x'}, 1);
+is($FAULT::fault, 2);
{
package P;
$b = "not ok ";
sub TIESCALAR { bless \$a } sub FETCH { "ok " }
tie $a, P; my $r = thaw freeze \$a; $b = $$r;
- print $b , 23, "\n";
+ main::is($b, "ok ");
}
require 'st-dump.pl';
}
-sub ok;
-
use Storable qw(freeze thaw);
-
-print "1..25\n";
+use Test::More tests => 28;
($scalar_fetch, $array_fetch, $hash_fetch) = (0, 0, 0);
@a = ('first', 3, -4, -3.14159, 456, 4.5, $d, \$d,
$b, \$a, $a, $c, \$c, \%a, \@array, \%hash, \@tied);
-ok 1, defined($f = freeze(\@a));
-
+my $f = freeze(\@a);
+isnt($f, undef);
$dumped = &dump(\@a);
-ok 2, 1;
+isnt($dumped, undef);
$root = thaw($f);
-ok 3, defined $root;
+isnt($root, undef);
$got = &dump($root);
-ok 4, 1;
+isnt($got, undef);
-ok 5, $got ne $dumped; # our hooks did not handle refs in array
+isnt($got, $dumped); # our hooks did not handle refs in array
$g = freeze($root);
-ok 6, length($f) == length($g);
+is(length $f, length $g);
# Ensure the tied items in the retrieved image work
@old = ($scalar_fetch, $array_fetch, $hash_fetch);
@tied = ($tscalar, $tarray, $thash) = @{$root->[$#{$root}]};
@type = qw(SCALAR ARRAY HASH);
-ok 7, tied $$tscalar;
-ok 8, tied @{$tarray};
-ok 9, tied %{$thash};
+is(ref tied $$tscalar, 'TIED_SCALAR');
+is(ref tied @$tarray, 'TIED_ARRAY');
+is(ref tied %$thash, 'TIED_HASH');
@new = ($$tscalar, $tarray->[0], $thash->{'attribute'});
@new = ($scalar_fetch, $array_fetch, $hash_fetch);
# Tests 10..15
for ($i = 0; $i < @new; $i++) {
- ok 10 + 2*$i, $new[$i] == $old[$i] + 1; # Tests 10,12,14
- ok 11 + 2*$i, ref $tied[$i] eq $type[$i]; # Tests 11,13,15
+ is($new[$i], $old[$i] + 1); # Tests 10,12,14
+ is(ref $tied[$i], $type[$i]); # Tests 11,13,15
}
-ok 16, $$tscalar eq 'foo';
-ok 17, $tarray->[3] eq 'plaine scalaire';
-ok 18, $thash->{'attribute'} eq 'plain value';
+is($$tscalar, 'foo');
+is($tarray->[3], 'plaine scalaire');
+is($thash->{'attribute'}, 'plain value');
# Ensure hooks were called
-ok 19, ($scalar_hook1 && $scalar_hook2);
-ok 20, ($array_hook1 && $array_hook2);
-ok 21, ($hash_hook1 && $hash_hook2);
+is($scalar_hook1, 2);
+is($scalar_hook2, 1);
+is($array_hook1, 2);
+is($array_hook2, 1);
+is($hash_hook1, 2);
+is($hash_hook2, 1);
#
# And now for the "blessed ref to tied hash" with "store hook" test...
my $bc = bless \%hash, 'FOO'; # FOO does not exist -> no hook
my $bx = thaw freeze $bc;
-ok 22, ref $bx eq 'FOO';
+is(ref $bx, 'FOO');
my $old_hash_fetch = $hash_fetch;
my $v = $bx->{attribute};
-ok 23, $hash_fetch == $old_hash_fetch + 1; # Still tied
+is($hash_fetch, $old_hash_fetch + 1, 'Still tied');
package TIED_HASH_REF;
$bc = bless \%hash, 'TIED_HASH_REF';
$bx = thaw freeze $bc;
-ok 24, ref $bx eq 'TIED_HASH_REF';
+is(ref $bx, 'TIED_HASH_REF');
$old_hash_fetch = $hash_fetch;
$v = $bx->{attribute};
-ok 25, $hash_fetch == $old_hash_fetch + 1; # Still tied
+is($hash_fetch, $old_hash_fetch + 1, 'Still tied');
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
- require 'st-dump.pl';
}
-sub ok;
$^W = 0;
-print "1..8\n";
-
use Storable qw(dclone);
+use Test::More tests => 8;
$h_fetches = 0;
$ref = \$h{77};
$ref2 = dclone $ref;
-ok 1, $h_fetches == 0;
-ok 2, $$ref2 eq $$ref;
-ok 3, $$ref2 == 7;
-ok 4, $h_fetches == 2;
+is($h_fetches, 0);
+is($$ref2, $$ref);
+is($$ref2, 7);
+is($h_fetches, 2);
$a_fetches = 0;
$ref = \$a[78];
$ref2 = dclone $ref;
-ok 5, $a_fetches == 0;
-ok 6, $$ref2 eq $$ref;
-ok 7, $$ref2 == 8;
+is($a_fetches, 0);
+is($$ref2, $$ref);
+is($$ref2, 8);
# a bug in 5.12 and earlier caused an extra FETCH
-ok 8, $a_fetches == 2 || $a_fetches == 3 ;
+is($a_fetches, $] < 5.013 ? 3 : 2);
-
#!./perl -w
#
# Copyright (c) 1995-2000, Raphael Manfredi
print "1..0 # Skip: Storable was not built\n";
exit 0;
}
- require 'st-dump.pl';
}
use strict;
-sub ok;
use Storable qw(thaw freeze);
-
-print "1..6\n";
+use Test::More tests => 6;
my $x = chr(1234);
-ok 1, $x eq ${thaw freeze \$x};
+is($x, ${thaw freeze \$x});
# Long scalar
$x = join '', map {chr $_} (0..1023);
-ok 2, $x eq ${thaw freeze \$x};
+is($x, ${thaw freeze \$x});
# Char in the range 127-255 (probably) in utf8
$x = chr (175) . chr (256);
chop $x;
-ok 3, $x eq ${thaw freeze \$x};
+is($x, ${thaw freeze \$x});
# Storable needs to cope if a frozen string happens to be internall utf8
# encoded
$x = chr 256;
my $data = freeze \$x;
-ok 4, $x eq ${thaw $data};
+is($x, ${thaw $data});
$data .= chr 256;
chop $data;
-ok 5, $x eq ${thaw $data};
+is($x, ${thaw $data});
$data .= chr 256;
# This definately isn't valid
eval {thaw $data};
-ok 6, $@ =~ /corrupt.*characters outside/;
+like($@, qr/corrupt.*characters outside/);
projects / platform / upstream / perl.git / commitdiff